トップ　>　備忘録　>　選択オブジェクトを画像で保存

'///宣言セクションに記述///
Private Const QUALITY_PARAMS As String _
    = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Const ENCODER_BMP    As String _
    = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_JPG    As String _
    = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_GIF    As String _
    = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_TIF    As String _
    = "{557CF405-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_PNG    As String = _
    "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Private Type GdiplusStartupInput
    #If VBA7 Then
        GdiplusVersion As Long
        DebugEventCallback As LongPtr
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    #Else
        GdiplusVersion As Long
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    #End If
End Type
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
#If VBA7 Then
    'クリップボード関係
    Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
            ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" ( _
            ByVal wFormat As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
    ' // GDI+関係
    Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" ( _
            token As LongPtr, _
            inputBuf As GdiplusStartupInput, _
            Optional ByVal outputBuf As LongPtr = 0) As Long
    Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" ( _
            ByVal token As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" ( _
            ByVal hbm As LongPtr, _
            ByVal hpal As LongPtr, _
            ByRef bitmap As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "GDIPlus" ( _
            ByVal filename As LongPtr, _
            bitmap As LongPtr) As Long
    Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" ( _
            ByVal image As LongPtr) As Long
    Private Declare PtrSafe Function GdipSaveImageToFile Lib "GDIPlus" ( _
            ByVal image As LongPtr, _
            ByVal filename As LongPtr, _
            ByRef clsidEncoder As GUID, _
            encoderParams As Any) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" ( _
            ByVal lpsz As Any, _
            ByRef pCLSID As GUID) As Long
    Private Declare PtrSafe Function GdipGetImageHeight Lib "GDIPlus" ( _
            ByVal image As LongPtr, _
            ByRef Height As LongPtr) As Long
    Private Declare PtrSafe Function GdipGetImageWidth Lib "GDIPlus" ( _
            ByVal image As LongPtr, _
            ByRef Width As LongPtr) As Long
    Private Type EncoderParameter
        GUID As GUID
        NumberOfValues As LongPtr
        TypeAPI As LongPtr
        Value As LongPtr
    End Type
    Private Type EncoderParameters
        Count As LongPtr
        Parameter(0 To 15) As EncoderParameter
    End Type
    Public m_GDIplusToken As LongPtr
#Else
    Private Declare Function OpenClipboard Lib "user32.dll" ( _
            ByVal hWnd As Long) As Long
    Private Declare Function GetClipboardData Lib "user32.dll" ( _
            ByVal wFormat As Long) As Long
    Private Declare Function CloseClipboard Lib "user32.dll" () As Long
    Private Declare Function GdiplusStartup Lib "gdiplus.dll" ( _
            ByRef token As Long, _
            ByRef inputBuf As GdiplusStartupInput, _
            Optional ByVal outputBuf As Long = 0) As Long
    Private Declare Function GdiplusShutdown Lib "gdiplus.dll" ( _
            ByVal token As Long) As Long
    Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" ( _
            ByVal hbm As Long, _
            ByVal hpal As Long, _
            bitmap As Long) As Long
    Private Declare Function GdipDisposeImage Lib "gdiplus.dll" ( _
            ByVal image As Long) As Long
    Private Declare Function GdipSaveImageToFile Lib "gdiplus.dll" ( _
            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 Any, _
            ByRef pCLSID As GUID) As Long
    Private Declare Function GdipGetImageHeight Lib "gdiplus.dll" ( _
            ByVal image As Long, _
            ByRef Height As Long) As Long
    Private Declare Function GdipGetImageWidth Lib "gdiplus.dll" ( _
            ByVal image As Long, _
            ByRef Width As Long) As Long
    Private Type EncoderParameter
        GUID As GUID
        NumberOfValues As Long
        TypeAPI As Long
        Value As Long
    End Type
    Private Type EncoderParameters
        Count As Long
        Parameter(0 To 15) As EncoderParameter
    End Type
    Public m_GDIplusToken As Long
#End If
Private Const CF_BITMAP As Long = 2 'クリップボードのデータタイプ
'///ここまで///
Sub Sample_WithoutPicture()
    Dim strExt As String
    Dim strSep As String
    Dim strSelFilePath As String
    Dim varOption As Variant
    strSelFilePath = STI_Select_Path()
    If Len(strSelFilePath) = 0 Then Exit Sub
    If InStrRev(strSelFilePath, ".", , vbBinaryCompare) = 0 Then Exit Sub
    strExt = LCase$(Mid$(strSelFilePath, InStrRev(strSelFilePath, ".", , vbBinaryCompare) + 1))
    On Error Resume Next
        Application.Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        If Err.Number <> 0 Then
            MsgBox Err.Description, vbExclamation + vbOKOnly
            Err.Clear
            Exit Sub
        End If
    On Error GoTo 0
    Call Selection_WithoutPicture(strSelFilePath, strExt, 85)
End Sub

Private Function STI_Select_Path() As String '保存場所とファイル名の指定
    Const strFilter As String = "PNG,*.png,JPG,*.jpg,GIF,*.gif,BMP,*.bmp,TIFF,*.tif"
    Dim lngLD As Long
    Dim strIFN As String
    Dim strFilePath As String
    With Excel.Application
        strIFN = Date_Time_FN() '日時からファイル名を作成
        strFilePath = .GetSaveAsFilename(InitialFileName:=strIFN, FileFilter:=strFilter)
        If UCase$(strFilePath) = "FALSE" Then Exit Function
        If Dir(strFilePath) <> "" Then
            If MsgBox("上書きしますか？", vbQuestion + vbYesNo, "確認") = vbNo Then
                Exit Function
            End If
        End If
        STI_Select_Path = strFilePath
    End With
End Function

Private Function Date_Time_FN() As String '日時からファイル名を作成
    Dim datTime As Date
    Dim datToday As Date
    Dim strFileName(0 To 8) As String
    datToday = Date: datTime = Time
    strFileName(0) = Mid$(CStr(Year(datToday)), 3)
    strFileName(1) = "_"
    strFileName(2) = Format$(datToday, "mm")
    strFileName(3) = Format$(datToday, "dd")
    strFileName(4) = "_"
    strFileName(5) = Format$(datTime, "hh")
    strFileName(6) = Format$(datTime, "nn")
    strFileName(7) = "_"
    strFileName(8) = Format$(datTime, "ss")
    Date_Time_FN = Join$(strFileName, vbNullString)
End Function

Private Sub Selection_WithoutPicture(ByVal filePath As String, _
                                    ByVal strExt As String, ByVal lngQ As Long)
    Dim lngWidth, lngHeight
    Dim strReceive As String
    Dim objGdipBmp
    Dim hBmp As OLE_HANDLE
    If GDIplus_Initialize() = False Then 'GDI+初期化
        MsgBox "GDI+ を初期化できません", vbCritical: Exit Sub
    End If
    hBmp = pvGetHBitmapFromClipboard() 'クリップボードのBitmap ハンドル取得
    If hBmp = 0 Then GoSub FINGDIP
    'BitmapハンドルからBitmapオブジェクト（イメージ）を作成。objGdipBmpは作成されたイメージ
    If GdipCreateBitmapFromHBITMAP(hBmp, 0&, objGdipBmp) = 0 Then
        Call GdipGetImageWidth(objGdipBmp, lngWidth) '幅取得
        Call GdipGetImageHeight(objGdipBmp, lngHeight) '高さ取得
        If Not (lngWidth <= 3200 And lngHeight <= 3200) Then
            MsgBox "イメージが大きすぎます", vbExclamation + vbOKOnly
            GoSub TERMINATE
        End If
        Call SaveImageToFile(objGdipBmp, filePath, strExt, lngQ) '保存
    End If
TERMINATE: 'イメージの廃棄
    Call GdipDisposeImage(objGdipBmp)
FINGDIP: 'GDI+終了
    Call Gdiplus_Shutdown
End Sub

Private Function GDIplus_Initialize() As Boolean 'GDI+初期化
    Dim lngStatus As Long
    Dim uGdiStartupInput As GdiplusStartupInput
    If m_GDIplusToken <> 0 Then Call Gdiplus_Shutdown
    With uGdiStartupInput
        .GdiplusVersion = 1
        .DebugEventCallback = 0
        .SuppressBackgroundThread = 0
        .SuppressExternalCodecs = 0
    End With
    GDIplus_Initialize = CBool(GdiplusStartup(m_GDIplusToken, uGdiStartupInput, 0&) = 0)
End Function

Private Function Gdiplus_Shutdown() As Long 'GDI+終了
    If m_GDIplusToken <> 0 Then
        Call GdiplusShutdown(m_GDIplusToken): m_GDIplusToken = 0
    End If
End Function

'GDI+からファイルへ書き出し
Private Sub SaveImageToFile(ByVal objBmp, ByVal sFilename As String, _
                                ByVal sFormat As String, ByVal nQuarity As Long)
    Dim strEncoder As String
    Dim uEncoderParams As EncoderParameters
    Select Case UCase$(sFormat)
        Case "JPG": strEncoder = ENCODER_JPG
        Case "GIF": strEncoder = ENCODER_GIF
        Case "TIF": strEncoder = ENCODER_TIF
        Case "PNG": strEncoder = ENCODER_PNG
        Case Else: strEncoder = ENCODER_BMP
    End Select
    If UCase$(sFormat) = "JPG" Then 'JPEGのクオリティー設定
        nQuarity = Abs(nQuarity)
        If nQuarity = 0 Or 100 < nQuarity Then nQuarity = 100
        uEncoderParams.Count = 1
        With uEncoderParams.Parameter(0)
            .GUID = pvToCLSID(ENCODER_JPG)
            .TypeAPI = 4
            .NumberOfValues = 1
            .Value = VarPtr(nQuarity)
        End With
    End If
    If UCase$(sFormat) = "JPG" Then
        Call GdipSaveImageToFile(objBmp, StrPtr(sFilename), _
                pvToCLSID(strEncoder), uEncoderParams)
    Else
        Call GdipSaveImageToFile(objBmp, StrPtr(sFilename), _
                pvToCLSID(strEncoder), ByVal 0&)
    End If
End Sub

 'クリップボードのBitmap取得
Private Function pvGetHBitmapFromClipboard() As OLE_HANDLE
    If OpenClipboard(0&) <> 0 Then
        pvGetHBitmapFromClipboard = GetClipboardData(CF_BITMAP)
    Else
        pvGetHBitmapFromClipboard = 0
    End If
    Call CloseClipboard
End Function

Private Function pvToCLSID(ByVal S As String) As GUID '文字列からCLSID取得
    Call CLSIDFromString(StrPtr(S), pvToCLSID)
End Function