[VB6] GDI+ を使ったJPEGファイルの作成

@GDI+ を使ったJPEGファイルの作成.md

• VB6 で、Jpeg ファイルを作成するサンプルです。少し手直しすれば Excel VBA などでも使えるはず。
• 初版は VB初心者友の会 の、今は無き "テーマ掲示板2" に投稿したサンプルです。(2004/10/01)
• 同じものを私の blog にも掲載していたのですが、yaplog! が 2020/01/31 にサービス終了を迎えて置き場が無くなっていたので、今回、GitHub Gist に再掲載してみました。

Form1.frm

Sub Command1_Click()
	Dim Status As GDIPlusStatusConstants
	Status = SavePictureJpeg(Image1.Picture, "C:\Sample.jpg", 70)
End Sub

Module1.bas

Option Explicit

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    'unsigned long  Data1
	Data2    As Integer 'unsigned short Data2
	Data3    As Integer 'unsigned short Data3
	Data4(7) As Byte    'unsigned char  Data4[8]
End Type

Private Type GdiplusStartupInput
	GdiplusVersion           As Long 'UINT32 GdiplusVersion
	DebugEventCallback       As Long 'DebugEventProc DebugEventCallback
	SuppressBackgroundThread As Long 'BOOL SuppressBackgroundThread
	SuppressExternalCodecs   As Long 'BOOL SuppressExternalCodecs
End Type

Private Type EncoderParameter
	Guid           As UUID 'GUID Guid
	NumberOfValues As Long 'ULONG NumberOfValues
	TypeAPI        As Long 'ULONG Type
	Value          As Long 'VOID* Value
End Type

Private Type EncoderParameters
	Count         As Long             'UINT Count
	Parameter(15) As EncoderParameter 'EncoderParameter Parameter[l]
End Type

' Status GdiplusStartup(
'   ULONG_PTR token *token,
'   const GdiplusStartupInput *input,
'   GdiplusStartupOutput *output);
Private Declare Function GdiplusStartup Lib "GDIPlus" _
   (ByRef token As Long, _
    ByRef inputBuf As GdiplusStartupInput, _
    ByVal outputBuf As Long) As GDIPlusStatusConstants

' void GdiplusShutdown(
'   ULONG_PTR token);
Private Declare Sub GdiplusShutdown Lib "GDIPlus" _
   (ByVal token As Long)

' GpStatus WINGDIPAPI GdipCreateBitmapFromHBITMAP(
'   HBITMAP hbm,
'   HPALETTE hpal,
'   GpBitmap** bitmap)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" _
   (ByVal hbm As Long, _
    ByVal hpal As Long, _
    ByRef bitmap As Long) As GDIPlusStatusConstants

' GpStatus WINGDIPAPI GdipDisposeImage(
'   GpImage *image)
Private Declare Function GdipDisposeImage Lib "GDIPlus" _
   (ByVal Image As Long) As GDIPlusStatusConstants

' GpStatus WINGDIPAPI GdipSaveImageToFile(
'   GpImage *image,
'   GDIPCONST WCHAR* filename,
'   GDIPCONST CLSID* clsidEncoder,
'   GDIPCONST EncoderParameters* encoderParams)
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" _
   (ByVal Image As Long, _
    ByVal filename As Long, _
    ByRef clsidEncoder As UUID, _
    ByVal encoderParams As Long) As GDIPlusStatusConstants

' HRESULT CLSIDFromString(
'   LPOLESTR lpsz,
'   LPCLSID pclsid );
Private Declare Function CLSIDFromString Lib "ole32" _
   (ByVal lpszCLSID As Long, _
    ByRef pclsid As UUID) As Long

'pict: Pictureオブジェクト。ビットマップ画像を指定して下さい。
'filename: 保存先ファイル名。既存のファイルは上書きされます。
'quality: 品質設定(0～100)。0は高圧縮低画質、100は低圧縮高画質。
Public Function SavePictureJpeg(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
		SavePictureJpeg = GDIPlusStatusConstants.UnknownImageFormat
		Exit Function
	End If
	If quality > 100 Then quality = 100
	udtGdiplusStartupInput.GdiplusVersion = 1
	SavePictureJpeg = GdiplusStartup(lngGDIPToken, udtGdiplusStartupInput, 0&)
	If SavePictureJpeg <> GDIPlusStatusConstants.Ok Then
		Exit Function
	End If
	SavePictureJpeg = GdipCreateBitmapFromHBITMAP(pict.Handle, 0&, lngBitmap)
	If SavePictureJpeg = GDIPlusStatusConstants.Ok Then
		udtEncoderParameters.Count = 1
		With udtEncoderParameters.Parameter(0)	'Quality
			.Guid = ToCLSID("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}")
			.NumberOfValues = 1
			.TypeAPI = 4
			.Value = VarPtr(quality)
		End With
		SavePictureJpeg = 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