’☆フォームモジュール
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PICTDESC
cbSizeofstruct As Long
picType As Long
hbitmap As Long
hpal As Long
unused_wmf_yExt As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'スクリーン座標系の座標を入れる構造体
Private Type scrnDim
x As Long
y As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(lpPictDesc As PICTDESC, riid As GUID, _
ByVal fOwn As Long, lplpvObj As Any) As Long
Const PICTYPE_BITMAP = 1
Private Declare Function UpdateWindow Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowRect Lib "user32" _
(ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetDC Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function GetWindowDC Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hgdiobj As Long) As Long
Private Declare Function BitBlt Lib "gdi32" _
(ByVal hdcDest As Long, ByVal nXDest As Long, _
ByVal nYDest As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hdcSrc As Long, _
ByVal nXSrc As Long, ByVal nYSrc As Long, _
ByVal dwRop As Long) As Long
Const SRCCOPY = &HCC0020
Private Declare Function SetROP2 Lib "gdi32" _
(ByVal hdc As Long, ByVal fnDrawMode As Long) As Long
Const R2_NOT = 6
Private Declare Function GetStockObject Lib "gdi32" _
(ByVal fnObject As Long) As Long
Const NULL_BRUSH = 5
Private Declare Function Rectangle Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nLeftRect As Long, ByVal nTopRect As Long, _
ByVal nRightRect As Long, ByVal nBottomRect As Long) As Long
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Const GWL_STYLE = -16
Const GWL_EXSTYLE = -20
Const WS_CAPTION = &HC00000 'タイトルバーを持つウィンドウ
Const WS_SYSMENU = &H80000 'タイトルバー上にウィンドウメニューボックスを持つウィンドウ
Const WS_MINIMIZEBOX = &H20000 '最小化ボタンを持つウィンドウを作成します。
Const WS_MAXIMIZEBOX = &H10000 '最大化ボタンを持つウィンドウ
Const WS_EX_DLGMODALFRAME = &H1& '二重の境界線を持つウィンドウ
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal uFlags As Long) As Long
Const HWND_TOPMOST = -1& '常に手前に表示
Const HWND_TOP = 0 '手前に表示
Const SWP_FRAMECHANGED = &H20
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private m_hwnd As Long ' ユーザーフォームのハンドル
Private m_SelPicture As Object ' stdole.StdPicture キャプチャした画像を収納
'============================================================
'完全な縁なしフォームを表示する
Private Sub UserForm_Initialize()
With Me
'UserFormのpicture設定
.StartUpPosition = 0
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
'フォームに時刻を名前としてつける
.Caption = .Caption & Timer()
End With
'名前を手がかりとして、ユーザーフォームのハンドルを取得
'Office 2000 以降のユーザーフォームのクラス名は 「 ThunderDFrame 」 です
m_hwnd = FindWindow("ThunderDFrame", Me.Caption)
' フォームのメニュー、最大最小化ボタン等は一切表示しない設定とする
SetWindowLong m_hwnd, GWL_STYLE, _
GetWindowLong(m_hwnd, GWL_STYLE) And _
Not (WS_SYSMENU Or WS_CAPTION Or _
WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
SetWindowLong m_hwnd, GWL_EXSTYLE, _
GetWindowLong(m_hwnd, GWL_EXSTYLE) And _
Not WS_EX_DLGMODALFRAME
'フォームの表示順（Zオーダー）、サイズをここで指定している
'SWP_FRAMECHANGED SetWindowLong 関数を使って新しいフレームスタイルの設定を適用します。
If lngHeight > lngWidth Then
tatenagaFlag = True
Else
tatenagaFlag = False
End If
If tatenagaFlag = False Then
SetWindowPos m_hwnd, HWND_TOPMOST, leftYokonaga, topYokonaga, lngWidth, lngHeight, _
SWP_FRAMECHANGED
Else
SetWindowPos m_hwnd, HWND_TOPMOST, leftTatenaga, topTatenaga, lngWidth, lngHeight, _
SWP_FRAMECHANGED
End If
End Sub
'============================================================
'キーを押したときの処理
Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
Select Case KeyCode.Value
Case vbKeyEscape 'ESCでフォームを閉じる
Unload Me
ActiveSheet.Select
Exit Sub
End Select
If tatenagaFlag = False Then
leftYokonaga = Me.Left
Range("横長left").Value = leftYokonaga
topYokonaga = Me.Top
Range("横長top").Value = topYokonaga
Else
leftTatenaga = Me.Left
Range("縦長left").Value = leftTatenaga
topTatenaga = Me.Top
Range("縦長top").Value = topTatenaga
End If
End Sub
'☆標準モジュール２
'画面の解像度取得
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
'フォームの表示位置
Public leftYokonaga As Long
Public topYokonaga As Long
Public leftTatenaga As Long
Public topTatenaga As Long
'フォームのサイズ
Public lngWidth As Long
Public lngHeight As Long
'画面解像度
Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1
Public desktopWidth As Long
Public desktopHeight As Long
Sub Auto_Open()
Assistant.Visible = False
End Sub
'シートにサムネイル画像貼り付け
'画像のAlternativTextに、画像のパスを記録する事で、画像名の管理を不要にした
Sub makeThumbnail()
Dim FSO As Object
Dim fileList As Object
Dim myfile As Object
Dim i As Long, j As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO.GetFolder(myGetFolder)
Set fileList = .Files
End With
i = 1: j = 1
Application.ScreenUpdating = False
Call deleteAllPictures
For Each myfile In fileList
If UCase(FSO.GetExtensionName(myfile.Path)) = "JPG" Then
Call resizePicture(myfile.Path, "C:\test.jpg", scalerate:=20, _
InterpolationMode:=InterpolationModeHighQualityBicubic, _
jpegQuality:=10)
Cells(i, j).Activate
ActiveSheet.Pictures.Insert("C:\test.jpg").Select
Selection.Height = ActiveCell.Height
Selection.Width = ActiveCell.Width
' ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.item(1), Address:=myfile.Path
Selection.ShapeRange.Item(1).AlternativeText = myfile.Path
Selection.OnAction = "Picture_Click"
i = i + 1
If i > 20 Then
i = 1
j = j + 1
End If
End If
Next myfile
Application.ScreenUpdating = True
Set FSO = Nothing
End Sub
Sub Picture_Click(Optional dummy As Long)
If Application.VBE.MainWindow.Visible = True Then Application.VBE.MainWindow.Visible = False
desktopWidth = GetSystemMetrics(SM_CXSCREEN)
desktopHeight = GetSystemMetrics(SM_CYSCREEN)
Call loadPhoto(ActiveSheet.Shapes(Application.Caller).AlternativeText)
End Sub
Private Sub loadPhoto(FileName As String)
Dim xsize As Long
Dim ysize As Long
Dim longSize As Long
longSize = desktopHeight
With UserForm1
'xsize,ysizeはLoadPictureSizeSpecify側で設定して戻す
Set .Picture = LoadPictureSizeSpecify(FileName, xsize, ysize, longSideLength:=longSize, _
InterpolationMode:=InterpolationModeHighQualityBicubic)
'.PictureSizeMode = fmPictureSizeModeClip
.Width = xsize / 1.333
.Height = ysize / 1.333
'UserForm1.Initializeでの設定はうまいかなかった
.Top = 0
.Left = 0
.Show
End With
End Sub
'画像の全削除
Private Sub deleteAllPictures()
Dim shps As Shapes
Set shps = ActiveSheet.Shapes
shps.SelectAll
Selection.Delete
End Sub
'==================================================================================
'ダイアログを表示して、フォルダー名を取得
Private Function myGetFolder() As String
Dim objShell As Object 'Shell
Dim objFolder As Object 'Shell32.Folder
Const strTitle = "フォルダを選択してください。"
'シェルのオブジェクトを作成する
Set objShell = CreateObject("Shell.Application")
'フォルダー参照に設定
Const lngRef = &H1
'ルートフォルダーをデスクトップに設定
'5でMy Documents、6でFavoritesなど
Const fldRoot = &H0
Set objFolder = _
objShell.BrowseForFolder(0, _
strTitle, lngRef, fldRoot)
Set objShell = Nothing
'フォルダー名を取出す
Dim strMSG
If objFolder Is Nothing Then 'キャンセルチェック
myGetFolder = ""
Else
If objFolder.ParentFolder Is Nothing Then
'ルートが選択された時
myGetFolder = ""
Else
myGetFolder = objFolder.Items.Item.Path
End If
End If
End Function
'☆標準モジュール１ GDI+関係
'--------
Public Enum InterpolationMode ' 補間方法
InterpolationModeInvalid = -1
InterpolationModeDefault = 0
InterpolationModeLowQuality = 1
InterpolationModeHighQuality = 2
InterpolationModeBilinear = 3
InterpolationModeBicubic = 4
InterpolationModeNearestNeighbor = 5
InterpolationModeHighQualityBilinear = 6
InterpolationModeHighQualityBicubic = 7
End Enum
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PICTDESC
cbSizeofstruct As Long
picType As Long
hbitmap As Long
hpal As Long
unused_wmf_yExt As Long
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
Type As Long
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter(15) As EncoderParameter
End Type
'画像ファイル保存関係
Private Const CLSID_BMP As String = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_JPEG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_QUALITY As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Declare Function GdiplusStartup Lib "gdiplus" _
(token As Long, pInput As GdiplusStartupInput, _
pOutput As Any) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" _
(ByVal token As Long)
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" _
(ByVal image As Long, graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" _
(ByVal graphics As Long) As Long
Private Declare Function GdipSetInterpolationMode Lib "gdiplus" _
(ByVal graphics As Long, _
ByVal nInterpolationMode As InterpolationMode) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" _
(ByVal image As Long) As Long
Private Declare Function GdipGetImageWidth Lib "gdiplus" _
(ByVal image As Long, Width As Long) As Long
Private Declare Function GdipGetImageHeight Lib "gdiplus" _
(ByVal image As Long, Height As Long) As Long
Private Declare Function GdipDrawImageRectI Lib "gdiplus" _
(ByVal graphics As Long, ByVal image As Long, _
ByVal x As Long, ByVal y As Long, _
ByVal Width As Long, ByVal Height As Long) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" _
(FileName As Any, bitmap As Long) As Long
Private Declare Function GdipCreateBitmapFromGraphics Lib "gdiplus" _
(ByVal Width As Long, ByVal Height As Long, _
ByVal Target As Long, bitmap As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" _
(ByVal bitmap As Long, hbmReturn As Long, _
ByVal background As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(lpPictDesc As PICTDESC, riid As GUID, _
ByVal fOwn As Long, lplpvObj As Any) As Long
Const PICTYPE_BITMAP = 1
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" ( _
ByVal image As Long, _
ByVal FileName As Long, _
ByRef clsidEncoder As GUID, _
ByVal encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" ( _
ByVal lpszCLSID As Long, _
ByRef pCLSID As GUID) As Long
'画像が縦長かどうかのフラグ
Public tatenagaFlag As Boolean
Const UnitWorld = 0 ' World coordinate (non-physical unit)
Const UnitDisplay = 1 ' Variable -- for PageTransform only
Const UnitPixel = 2 ' Each unit is one device pixel.
Const UnitPoint = 3 ' Each unit is a printer's point, or 1/72 inch.
Const UnitInch = 4 ' Each unit is 1 inch.
Const UnitDocument = 5 ' Each unit is 1/300 inch.
Const UnitMillimeter = 6 ' Each unit is 1 millimeter.
Const PixelFormatIndexed As Long = &H10000 ' Indexes into a palette
Const PixelFormatGDI As Long = &H20000 ' Is a GDI-supported format
Const PixelFormatAlpha As Long = &H40000 ' Has an alpha component
Const PixelFormatPAlpha As Long = &H80000 ' Pre-multiplied alpha
Const PixelFormatExtended As Long = &H100000 ' Extended color 16 bits/channel
Const PixelFormatCanonical As Long = &H200000
Const PixelFormatUndefined As Long = 0
Const PixelFormatDontCare As Long = 0
'Imageの複写
Private Declare Function GdipCloneImage Lib "gdiplus.dll" (ByVal pImage As Long, ByRef cloneImage As Long) As Long
Private Declare Function GdipCreateSolidFill Lib "gdiplus.dll" (ByVal pColor As Long, ByRef brush As Long) As Long
'塗りつぶし四角形を描画
Private Declare Function GdipFillRectangle Lib "gdiplus.dll" (ByVal graphics As Long, ByVal brush As Long, ByVal x As Single, ByVal y As Single, ByVal nWidth As Single, ByVal nHeight As Single) As Long
'GDI+のブラシ削除
Private Declare Function GdipDeleteBrush Lib "gdiplus.dll" (ByVal brush As Long) As Long
'座標変換
Private Declare Function GdipTranslateWorldTransform Lib "gdiplus.dll" (ByVal graphics As Long, ByVal dx As Single, ByVal dy As Single, ByVal order As Long) As Long
'メモリ上にBitmapを生成
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus.dll" (ByVal nWidth As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, nBitmap As Long) As Long
'原寸のままでGraphicsにImageを貼付
Private Declare Function GdipDrawImageRectRectI Lib "gdiplus.dll" (ByVal graphics As Long, ByVal nImage As Long, ByVal dstx As Long, ByVal dsty As Long, ByVal dstwidth As Long, ByVal dstheight As Long, ByVal srcx As Long, ByVal srcy As Long, ByVal srcWidth As Long, ByVal srcHeight As Long, ByVal srcUnit As Long, Optional ByVal imageAttributes As Long, Optional ByVal pCALLBACK As Long, Optional ByVal callbackData As Long) As Long
'GdipCreateBitmapFromScan0の引数に使用
Dim PixelFormat32bppARGB As Long
Type POINTAPI
x As Long
y As Long
End Type
' 表示寸法と補間モードを指定してファイルから画像をロード
Public Function LoadPictureSizeSpecify( _
ByVal FileName As String, _
ByRef xsize, ByRef ysize, _
Optional ByVal longSideLength As Long = 800, _
Optional ByVal InterpolationMode As InterpolationMode _
= InterpolationModeBilinear) As stdole.IPictureDisp
Dim IID_IDispatch As GUID
Dim pd As PICTDESC
Dim udtInput As GdiplusStartupInput
Dim objPicture As Object
Dim hBmp As Long
Dim lngToken As Long
Dim pGraphics As Long
Dim pSrcBmp As Long
Dim pDstBmp As Long
Dim srcWidth As Long, srcHeight As Long, hBrush As Long, pImageTemp As Long, angle As Single
Dim lngStatus As Long
Dim scalerate As Long
Dim hvRatio As Double '縦横比
' 初期化
udtInput.GdiplusVersion = 1
If GdiplusStartup(lngToken, udtInput, ByVal 0&) <> 0 Then
Exit Function
End If
' 画像の読みこみ
If GdipCreateBitmapFromFile( _
ByVal StrPtr(FileName), pSrcBmp) <> 0 Then
GdiplusShutdown lngToken
Exit Function
End If
'画像の回転 2010/2/6
' 元画像サイズの取得
GdipGetImageWidth pSrcBmp, srcWidth
GdipGetImageHeight pSrcBmp, srcHeight
' Debug.Print srcHeight, srcWidth
If srcHeight > srcWidth Then
tatenagaFlag = True
Else
tatenagaFlag = False
End If
' 元画像サイズの取得
GdipGetImageWidth pSrcBmp, srcWidth
GdipGetImageHeight pSrcBmp, srcHeight
If srcHeight > srcWidth Then
tatenagaFlag = True
Else
tatenagaFlag = False
End If
' Debug.Print "幅", lngWidth, "高", lngHeight, "縦長", tatenagaFlag
'縦横比算出
hvRatio = srcWidth / srcHeight
' サイズの変更 (エラー処理は必要に応じて追加のこと)
If tatenagaFlag = False Then
'横長の時
lngWidth = longSideLength
lngHeight = longSideLength / hvRatio
Else
' 縦長の時
lngHeight = longSideLength
lngWidth = longSideLength * hvRatio
End If
' Debug.Print "幅", lngWidth, "高", lngHeight
xsize = lngWidth
ysize = lngHeight
If GdipGetImageGraphicsContext(pSrcBmp, pGraphics) = 0 Then
' コピー先Bitmap作成
lngStatus = GdipCreateBitmapFromGraphics( _
lngWidth, lngHeight, pGraphics, pDstBmp)
GdipDeleteGraphics pGraphics
If lngStatus = 0 Then
' コピー用Graphics作成
If GdipGetImageGraphicsContext(pDstBmp, pGraphics) = 0 Then
' 補間方法の設定
GdipSetInterpolationMode pGraphics, InterpolationMode
'縁が出来てしまうので白で塗りつぶしておく2010/2/5
GdipCreateSolidFill &HFFFFFFFF, hBrush
GdipFillRectangle pGraphics, hBrush, 0, 0, lngWidth, lngHeight
GdipDeleteBrush hBrush
' イメージのコピー
GdipDrawImageRectI pGraphics, pSrcBmp, _
0, 0, lngWidth, lngHeight
GdipDeleteGraphics pGraphics
' GDIのビットマップ作成
GdipCreateHBITMAPFromBitmap pDstBmp, hBmp, 0
End If
GdipDisposeImage pDstBmp
End If
End If
GdipDisposeImage pSrcBmp
GdiplusShutdown lngToken
If hBmp = 0 Then Exit Function
' 以降はOLEのPictureオブジェクト作成処理
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With pd
.cbSizeofstruct = Len(pd)
.picType = PICTYPE_BITMAP
.hbitmap = hBmp
End With
If OleCreatePictureIndirect(pd, IID_IDispatch, _
1, objPicture) >= 0 Then
Set LoadPictureSizeSpecify = objPicture
Else
' エラー時
DeleteObject hBmp
End If
End Function
' 拡大率と補間モードを指定してファイルから画像をロードしてPictureに変換
Public Function resizePicture( _
ByVal srcPath As String, _
ByVal dstPath As String, _
Optional ByVal scalerate As Long = 100, _
Optional ByVal InterpolationMode As InterpolationMode _
= InterpolationModeHighQualityBicubic, _
Optional ByVal jpegQuality As Long = 85 _
)
Dim IID_IDispatch As GUID
Dim pd As PICTDESC
Dim udtInput As GdiplusStartupInput
Dim lngToken As Long, lngStatus As Long
Dim pGraphics As Long
Dim pSrcBmp As Long, pDstBmp As Long
Dim lngWidth As Long, lngHeight As Long
Dim EncodParameters As EncoderParameters
' 初期化
udtInput.GdiplusVersion = 1
If GdiplusStartup(lngToken, udtInput, ByVal 0&) <> 0 Then
Exit Function
End If
' 画像の読みこみ
If GdipCreateBitmapFromFile(ByVal StrPtr(srcPath), pSrcBmp) <> 0 Then
GdiplusShutdown lngToken
Exit Function
End If
' 元画像サイズの取得
GdipGetImageWidth pSrcBmp, lngWidth
GdipGetImageHeight pSrcBmp, lngHeight
' サイズの変更 (エラー処理は必要に応じて追加のこと)
lngWidth = lngWidth * scalerate \ 100
lngHeight = lngHeight * scalerate \ 100
If GdipGetImageGraphicsContext(pSrcBmp, pGraphics) = 0 Then
' コピー先Bitmap作成
lngStatus = GdipCreateBitmapFromGraphics( _
lngWidth, lngHeight, pGraphics, pDstBmp)
GdipDeleteGraphics pGraphics
If lngStatus = 0 Then
' コピー用Graphics作成
If GdipGetImageGraphicsContext(pDstBmp, pGraphics) = 0 Then
' 補間方法の設定
GdipSetInterpolationMode pGraphics, InterpolationMode
' イメージのコピー
GdipDrawImageRectI pGraphics, pSrcBmp, 0, 0, lngWidth, lngHeight
GdipDeleteGraphics pGraphics
' エンコーダパラメータ設定
EncodParameters.Count = 1
With EncodParameters.Parameter(0)
.GUID = ConvCLSID(CLSID_QUALITY)
.NumberOfValues = 1
' 4=EncoderParameterValueTypeLong
.Type = 4
' 圧縮品質
.Value = VarPtr(jpegQuality)
End With
' JPG変換で保存
Call GdipSaveImageToFile(pDstBmp, StrPtr(dstPath), ConvCLSID(CLSID_JPEG), VarPtr(EncodParameters))
End If
GdipDisposeImage pDstBmp
End If
End If
GdipDisposeImage pSrcBmp
GdiplusShutdown lngToken
End Function
Private Function ConvCLSID(ByVal sGuid As String) As GUID
CLSIDFromString StrPtr(sGuid), ConvCLSID
End Function