Option Explicit
' ----==== GDI+ 宣言 ====----
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Declare Function GdiplusStartup Lib "GDIPlus" ( _
token As Long, _
inputbuf As GdiplusStartupInput, _
Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" ( _
ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" ( _
ByVal hbm As Long, _
ByVal hpal As Long, _
Bitmap As Long) As Long
Private Declare Function GdipGetImageThumbnail Lib "GDIPlus" ( _
ByVal Image As Long, _
ByVal thumbWidth As Long, _
ByVal thumbHeight As Long, _
thumbImage As Long, _
ByVal callback As Long, _
ByVal callbackData As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" ( _
ByVal Image As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" ( _
ByVal Bitmap As Long, _
hbmReturn As Long, _
ByVal background As Long) As Long
' ----==== OLE API 宣言 ====----
Private Type PICTDESC
cbSizeOfStruct As Long
picType As Long
hgdiObj As Long
hPalOrXYExt As Long
End Type
Private Type IID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Public Enum GDIPlusStatusConstants
Ok = 0
GenericError = 1
InvalidParameter = 2
OutOfMemory = 3
ObjectBusy = 4
InsufficientBuffer = 5
NotImplemented = 6
Win32Error = 7
WrongState = 8
Aborted = 9
FileNotFound = 10
ValueOverflow = 11
AccessDenied = 12
UnknownImageFormat = 13
FontFamilyNotFound = 14
FontStyleNotFound = 15
NotTrueTypeFont = 16
UnsupportedGdiplusVersion = 17
GdiplusNotInitialized = 18
PropertyNotFound = 19
PropertyNotSupported = 20
ProfileNotFound = 21
End Enum
Private Type UUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type EncoderParameter
Guid As UUID
NumberOfValues As Long
TypeAPI As Long
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter(15) As EncoderParameter
End Type
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" ( _
lpPictDesc As PICTDESC, _
riid As IID, _
ByVal fOwn As Boolean, _
lplpvObj As Object)
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" _
(ByVal Image As Long, _
ByVal filename As Long, _
ByRef clsidEncoder As UUID, _
ByVal encoderParams As Long) As GDIPlusStatusConstants
Private Declare Function CLSIDFromString Lib "ole32" _
(ByVal lpszCLSID As Long, _
ByRef pclsid As UUID) As Long
'----------------------------------------------------------
' Procedure : CreateThumbnail
' Purpose : サムネイル生成
'----------------------------------------------------------
'
Function CreateThumbnail( _
ByVal Image As StdPicture, _
ByVal Width As Long, _
ByVal Height As Long) As StdPicture
Dim tSI As GdiplusStartupInput
Dim lGDIP As Long
Dim lRes As Long
Dim lBitmap As Long
' GDI+ の初期化
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI)
If lRes = 0 Then
' イメージハンドル（Image）から GDI+ ビットマップ生成
lRes = GdipCreateBitmapFromHBITMAP(Image.Handle, 0, lBitmap)
If lRes = 0 Then
Dim lThumb As Long
Dim hBitmap As Long
' サムネイル生成
lRes = GdipGetImageThumbnail(lBitmap, Width, Height, lThumb, 0, 0)
If lRes = 0 Then
' サムネイルから GDI ビットマップ生成
lRes = GdipCreateHBITMAPFromBitmap(lThumb, hBitmap, 0)
' StdPicture オブジェクト生成
Set CreateThumbnail = HandleToPicture(hBitmap, _
vbPicTypeBitmap)
' サムネイルイメージ破棄
GdipDisposeImage lThumb
End If
' image破棄
GdipDisposeImage lBitmap
End If
' GDI+ 終了
GdiplusShutdown lGDIP
End If
If lRes Then MsgBox "イメージ読み込み失敗！"
End Function
'----------------------------------------------------------
' ピクチャーオブジェクト生成
'----------------------------------------------------------
'
Public Function HandleToPicture( _
ByVal hGDIHandle As Long, _
ByVal ObjectType As PictureTypeConstants, _
Optional ByVal hpal As Long = 0) As StdPicture
Dim tPictDesc As PICTDESC
Dim IID_IPicture As IID
Dim oPicture As IPicture
' tPictDesc 初期化
With tPictDesc
.cbSizeOfStruct = Len(tPictDesc)
.picType = ObjectType
.hgdiObj = hGDIHandle
.hPalOrXYExt = hpal
End With
' IPicture interface ID 初期化
With IID_IPicture
.Data1 = &H7BF80981
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(3) = &HAA
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
' オブジェクト生成
OleCreatePictureIndirect tPictDesc, IID_IPicture, _
True, oPicture
' 返却値−ピクチャーオブジェクト
Set HandleToPicture = oPicture
End Function
'--------------------------------------------------------------
'Pict: ビットマップ画像
'Filename: 保存先ファイル名
'Quality: 画質(0:低〜100:高)
'--------------------------------------------------------------
Public Function SavePictureToJpeg(ByVal Pict As IPictureDisp, ByVal filename As String, ByVal Quality As Long) As GDIPlusStatusConstants
Dim udtGdiplusStartupInput As GdiplusStartupInput
Dim lngGDIPToken As Long
Dim lngBitmap As Long
Dim udtEncoderParameters As EncoderParameters
If Pict Is Nothing Then
SavePictureToJpeg = GDIPlusStatusConstants.UnknownImageFormat
Exit Function
End If
If Quality > 100 Then Quality = 100
udtGdiplusStartupInput.GdiplusVersion = 1
If GdiplusStartup(lngGDIPToken, udtGdiplusStartupInput, 0&) <> 0 Then
Exit Function
End If
SavePictureToJpeg = GdipCreateBitmapFromHBITMAP(Pict.Handle, 0&, lngBitmap)
If SavePictureToJpeg = GDIPlusStatusConstants.Ok Then
udtEncoderParameters.Count = 1
With udtEncoderParameters.Parameter(0) 'Quality
.Guid = ToCLSID(Chr(123) & "1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}")
.NumberOfValues = 1
.TypeAPI = 4
.Value = VarPtr(Quality)
End With
SavePictureToJpeg = GdipSaveImageToFile(lngBitmap, StrPtr(filename), ToCLSID(Chr(123) & "557CF401-1A04-11D3-9A73-0000F81EF32E}"), VarPtr(udtEncoderParameters))
GdipDisposeImage lngBitmap
End If
GdiplusShutdown lngGDIPToken
End Function
Private Function ToCLSID(ByVal S As String) As UUID
CLSIDFromString StrPtr(S), ToCLSID
End Function