GDIplusCODE


Private Sub test()
    Dim lData As Variant
    Dim TFile As String
    Dim clGdip As clgdiplus
    Dim lretHBITMAP As Long
    Dim tagArray As Variant
    
    Set clGdip = New clgdiplus
    TFile = "C:\IMG_1234.JPG"
' 新しいファイルを開く
    clGdip.OpenFile TFile
    Range("A1").Value = "画像のサイズ"
    Range("B1").Value = clGdip.GetExifData(TagImageWidth) & " x " & clGdip.GetExifData(TagImageHeight)
    Range("A2").Value = "ISO感度"
    Range("B2").Value = Format(clGdip.GetExifData(TagISOSpeedRatings), "\I\S\O 000")
    Range("A3").Value = "機種名"
    Range("B3").Value = clGdip.GetExifData(TagEquipModel)
    Range("A4").Value = "メーカー"
    Range("B4").Value = clGdip.GetExifData(TagEquipMake)
    Range("A5").Value = "撮影日時"
    Range("B5").Value = Format(clGdip.GetExifData(TagDateTimeOriginal), "yyyy/mm/dd" & " " & "hh:nn:ss")
    Range("A6").Value = "シャッター速度"
    lData = clGdip.GetExifData(TagExposureTime)
    If Not IsNull(lData) Then
        If lData(1) > lData(0) Then
            '1秒未満のとき
            Range("B6").Value = "1/" & Int(lData(1) / lData(0)) & " seconds"
        Else
            '1秒以上の時
            Range("B6").Value = Int(lData(0) / lData(1)) & " seconds"
        End If
    Else
        Range("B6").Value = ""
    End If
    Range("A7").Value = "絞り値"
    lData = clGdip.GetExifData(TagFNumber)
    If Not IsNull(lData) Then
        Range("B7").Value = Format(lData(0) / lData(1), "F0.0")
    Else
        Range("B7").Value = Null
    End If
    Range("A8").Value = "Flash"
    lData = clGdip.GetExifData(TagFlash)
    If Not IsNull(lData) Then
    Range("B8").Value = IIf(Mid(lData, 8, 1) = "1", "Flash 発光", "Flash 非発光")
    Range("B8").Value = Range("B8").Value & vbCrLf & Switch(Mid(lData, 4, 2) = "00", "モード不詳", _
                                              Mid(lData, 4, 2) = "01", "Flash forced", _
                                              Mid(lData, 4, 2) = "10", "Flash deactive", _
                                              Mid(lData, 4, 2) = "11", "Flash auto")
    Range("B8").Value = Range("B8").Value & vbCrLf & Switch(Mid(lData, 2, 1) = "0", "Red anti-eyes deactive", _
                                              Mid(lData, 2, 1) = "1", "Red anti-eyes active")
    Else
        Range("B8").Value = ""
    End If
    
    ' サムネイル画像をクリップボード経由でワークシートに貼り付ける
　　' 少々まだるっこしい感あり。
    Range("A9").Value = "Thumbnail"
    lretHBITMAP = HBitmapFromPicture(clGdip.GetExifData(TagThumbnailData))
    '画像をクリップボードにコピー
    If OpenClipboard(0) <> 0 Then
        EmptyClipboard
        SetClipboardData CF_BITMAP, lretHBITMAP
        CloseClipboard
    End If
    'ワークシートに貼付
    Range("B9").Activate
    ActiveSheet.Paste
End Sub

'http://www.vbaccelerator.com/home/VB/Tips/Creating_a_new_GDI_Bitmap_from_a_VB_Picture_or_DC/article.asp
Public Function HBitmapFromPicture(picThis As StdPicture) As Long
    ' Create a copy of the bitmap:
    Dim lhDC As Long
    Dim lhDCCopy As Long
    Dim lhBmpCopy As Long
    Dim lhBmpCopyOld As Long
    Dim lhBmpOld As Long
    Dim lhDCC As Long
    Dim tBM As BITMAP
    Const vbSrcCopy As Long = 13369376
    
    GetObjectAPI picThis.Handle, Len(tBM), tBM
    lhDCC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
    lhDC = CreateCompatibleDC(lhDCC)
    lhBmpOld = SelectObject(lhDC, picThis.Handle)
    lhDCCopy = CreateCompatibleDC(lhDCC)
    lhBmpCopy = CreateCompatibleBitmap(lhDCC, tBM.bmWidth, tBM.bmHeight)
    lhBmpCopyOld = SelectObject(lhDCCopy, lhBmpCopy)
    BitBlt lhDCCopy, 0, 0, tBM.bmWidth, tBM.bmHeight, lhDC, 0, 0, vbSrcCopy
    If Not (lhDCC = 0) Then DeleteDC lhDCC
    If Not (lhBmpOld = 0) Then SelectObject lhDC, lhBmpOld
    If Not (lhDC = 0) Then DeleteDC lhDC
    If Not (lhBmpCopyOld = 0) Then SelectObject lhDCCopy, lhBmpCopyOld
    If Not (lhDCCopy = 0) Then DeleteDC lhDCCopy
    HBitmapFromPicture = lhBmpCopy
End Function
サムネイル画像をExifから取得
