bmp画像をjpegやpng画像に圧縮する方法

http://oshiete.goo.ne.jp/qa/8809275.html

このページでbmp画像をtiff圧縮する方法を教えていただきました。


このプログラムを改良して
jpegやpng画像にも対応したプログラムを作ることはできないでしょうか？

恐らく、

　　　CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .Guid ' 圧縮方法

というところを書き換えれば、他の形式にも対応できると思うのですが、
CLSIDFromString　で検索しても、情報は見つかりませんでした。

どうか教えてください。

No.3 ベストアンサー 回答者： mitarashi 回答日時： 2014/11/09 12:58

#1,2です。

KenKen_SP様には失礼して、改造部分のコードを提示させていただきます。Win7Home(64) xl2010(32) で試しています。
出典：http://oshiete.goo.ne.jp/qa/5124395.html

' // Bitmapオブジェクトからファイルへ書き出し
Public Function SaveImageToFile( _
ByVal hBmp As OLE_HANDLE, _
ByVal sFilename As String, _
Optional ByVal sFormat As String = "JPG", _
Optional ByVal nQuarity As Long = 60 _
) As Boolean

'@ sFormat : BMP, JPG, GIF, TIF, PNG
'@ nQuality: 0-100(0:高圧縮低画質, 100:低圧縮高画質, Jpg のみ有効)

Dim sEncoderStr As String
Dim nStatus As Long

Select Case UCase$(sFormat)
Case "JPG": sEncoderStr = ENCODER_JPG
Case "GIF": sEncoderStr = ENCODER_GIF
Case "TIF": sEncoderStr = ENCODER_TIF
Case "PNG": sEncoderStr = ENCODER_PNG
Case Else: sEncoderStr = ENCODER_BMP
End Select

Dim uEncoderParams As EncoderParameters
' Jpeg のクオリティー設定
If UCase$(sFormat) = "JPG" Then
nQuarity = Abs(nQuarity)
If nQuarity > 100 Then nQuarity = 100
uEncoderParams.count = 1
With uEncoderParams.Parameter(0)
.GUID = pvToCLSID(QUALITY_PARAMS)
.TypeAPI = 4 ' Type Long
.Value = VarPtr(nQuarity)
.NumberOfValues = 1
End With
End If

' 保存処理
If UCase$(sFormat) = "JPG" Then
nStatus = GdipSaveImageToFile(hBmp, _
StrPtr(sFilename), _
pvToCLSID(sEncoderStr), _
VarPtr(uEncoderParams))
Else
nStatus = GdipSaveImageToFile(hBmp, _
StrPtr(sFilename), _
pvToCLSID(sEncoderStr), _
ByVal 0&)
End If
SaveImageToFile = CBool(nStatus = 0)
Call GdipDisposeImage(hBmp)

End Function

' // サンプル
Sub Sample()
Dim hBmp As OLE_HANDLE
Dim file1 As String

file1 = GetDesktopPath & "\Hydrangeas.bmp"
' GDI+ を初期化する
If GDIplus_Initialize() = False Then
MsgBox "GDI+ を初期化できません", vbCritical
Exit Sub
End If
'変換元ファイル読込
If GdipCreateBitmapFromFile(ByVal StrPtr(file1), hBmp) <> 0 Then
Gdiplus_Shutdown
Exit Sub
End If

' 保存(JPEG でクオリティー30の場合）
If SaveImageToFile(hBmp, GetDesktopPath & "\sample.jpg", "jpg", 30) = False Then
MsgBox "保存に失敗", vbCritical
Else
MsgBox "保存に成功", vbInformation
End If
' GDI+ を終了させる（必ず呼び出すこと）
Call Gdiplus_Shutdown
End Sub

'テスト用
Private Function GetDesktopPath() As String
Dim wScriptHost As Object, strInitDir As String
Set wScriptHost = CreateObject("Wscript.Shell")
GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
Set wScriptHost = Nothing
End Function

この回答へのお礼

うまくいきました。


ありがとうございます。

　

お礼日時：2014/11/09 14:26

No.2 回答者： mitarashi 回答日時： 2014/11/08 20:33

#1です。

確認不足で申し訳ありません。
Function SaveImageToFileの中の、
下記が余分です。
nStatus = GdipCreateBitmapFromHBITMAP(hBmp, 0&, pNewImage)
これはHBITMAPオブジェクトから、ビットマップオブジェクトに変換する処理になります。

クリップボードから、CF_BITMAP指定で取得したデータは（GDIの描画結果を保持しておくために用いられる）デバイス依存ビットマップオブジェクトHBITMAPというものだそうで、上記の処理が必要になりますが、
GdipCreateBitmapFromFileが与えるのはデバイス非依存のビットマップオブジェクトなので、この変換処理が不要です。（行うと不具合が出ます）
という訳で、GdipCreateBitmapFromFileで取得したビットマップオブジェクトのハンドルを、GdipCreateBitmapFromHBITMAPを介さずに以降の処理に渡して下さい。
元の記事のかなりの改造になりますので、投稿は控えておきますが、KUZUYさんは、ご自分でこの程度の改造はできるスキルをお持ちとお見受けします。もし、うまくいかない場合は補足して下さい。

この回答へのお礼

ありがとうございます。

nStatus = GdipCreateBitmapFromHBITMAP(hBmp, 0&, pNewImage)

を削除するだけではうまくいかないのですが。

その後の
SaveImageToFile = CBool(nStatus = 0)

などの改造する必要があると思いますがどのようにすれば良いでしょうか？
いろいろと試してみましたがわかりませんでした。

お時間あるときで構いませんので具体的に教えていただけないでしょうか？

お礼日時：2014/11/09 12:16

No.1 回答者： mitarashi 回答日時： 2014/11/08 00:36

前のご質問であげられていたURLを辿っていくと存在するのですが、

http://oshiete.goo.ne.jp/qa/5124395.html
の#5のKenKen_SPさんの回答がご参考になるでしょう。
こちらでは、クリップボードから、
' Bitmap のハンドル(メモリ上のアドレスみたいなもの)を取得
hBmp = pvGetHBitmapFromClipboard()

としていますが、先のご質問で紹介したページにあるコードの、
'-- 元ファイル読込
　　Dim image As Long
　　If GdipCreateBitmapFromFile(ByVal StrPtr(file1), image) <> 0 Then Goto Finally
imageという変数が、上記のhBmpに相当します。
これらを組み合わせればお望みの事が出来ると思います。
明日は早いので試している時間が取れません。あしからず。

この回答へのお礼

ありがとうございます。

#5のプログラムをそのままコピーした後に
下記のようにやってみましたが、
「保存に失敗」となってしまいます。

どこを改良すれば良いでしょうか？

急いでいるわけではありませんので、
週明けで構いませんのでご指示いただけないでしょうか？

よろしくお願いいたします。


option explicitに

Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (filename As Any, bitmap As Long) As Long

を追加した上で、以下をsubにコピー。



Sub Sample()

Dim hBmp As OLE_HANDLE


Const file1 = "D:\Documents and Settings\desktop\新しいフォルダー\00000.bmp"
Const file2 = "D:\Documents and Settings\desktop\新しいフォルダー\00000.tif"
Const file3 = "D:\Documents and Settings\desktop\新しいフォルダー\00000.jpg"

' GDI+ を初期化する
If GDIplus_Initialize() = False Then
MsgBox "GDI+ を初期化できません", vbCritical
Exit Sub
End If


'-- 元ファイル読込
'Dim hBmp As Long
If GdipCreateBitmapFromFile(ByVal StrPtr(file1), hBmp) <> 0 Then GoTo Finally


' 保存(JPEG でクオリティー30の場合）
If SaveImageToFile(hBmp, file3, "jpg", 30) = False Then
MsgBox "保存に失敗", vbCritical
Else
MsgBox "保存に成功", vbInformation
End If

Finally:

' GDI+ を終了させる（必ず呼び出すこと）
Call Gdiplus_Shutdown



End Sub

お礼日時：2014/11/08 12:12