Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(指定なし : 指定なし)
ユーザーフォームのImageコントローラについてのさむさむさんへ
投稿日時: 17/11/19 03:59:52
投稿者: baoo

Exif情報についてですが、画像の方向についての情報が含まれている場合に
以下はそれを確認する方法になります。
 
1.Explorer上で[表示]リボンにして[レイアウト]から"詳細"を選択します。
2.詳細表示になりますとファイルが表示されているところに
  "名前"、"更新日時"、"種類"、"サイズ"などの見出しが表示されます。
  この見出しを右クリックしてメニューから[その他]を選択します。
3.[詳細表示の設定]ダイアログのリストの中から"向き"にチェックを付けて
  [OK]ボタンをクリックします。
4.Exif情報で画像の向きについての情報があればそれが表示されます。
  情報が無ければ何も表示されません。
 
次にプログラムを組む場合にどのように画像の向きを取得するかですが、
私が作成した90度回転した画像を例にします。
これをバイナリで開くとその先頭部分は下記のようになります。
 
FF D8 FF E1 18 DC 45 78 69 66 00 00 49 49 2A 00
08 00 00 00 06 00 12 01 03 00 01 00 00 00 06 00
00 00
1A 01 05 00 01 00 00 00 56 00 00 00 1B 01
05 00 01 00 00 00 5E 00 00 00
28 01 03 00 01 00
00 00 02 00 00 00
31 01 02 00 16 00 00 00 66 00
00 00
69 87 04 00 01 00 00 00 7C 00 00 00
 
この後もデータは続くのですがそれぞれ値には意味があります。
FF D8 ->JPEG画像であることを表す
FF E1 18 DC ->APP1マーカ
45 78 69 66 00 00 ->Exif情報があることを示す
49 49 ->エンディアン情報
2A 00 ->固定
08 00 00 00 ->固定
06 00 ->以下につらなるタグの数
12 01 03 00 01 00 00 00 06 00 00 00 ->最初のタグ
1A 01 05 00 01 00 00 00 56 00 00 00 ->2番目のタグ
 
1.最初の2バイトを読み込んでJPEGかどうかを確認(JPEGでない場合は終了)
2.続く4バイトを読み込んでAPP1マーカというデータの連なりかどうかを確認
  APP1でない場合は後半2バイト(今回は18 DCの部分)がマーカのサイズなので
  そのサイズ分読み飛ばして次のマーカを確認。(今回は最初のマーカがAPP1でした。)
3.APP1マーカが見つかったらExif情報かを確認。
4.エンディアンを確認。これによりデータの値の扱いが変わる。
  49 49の場合リトルエンディアン。4D 4Dの場合ビックエンディアン。
5.タグの数を確認。今回はリトルエンディアンなので6個のタグがあります。
6.1つのタグにつき12バイトとして各タグを取得して画像の向きを表すタグかどうかを確認。
 
なお、画像の向きを表すタグは12 01(リトルエンディアン)で始まるので今回の画像の場合は
一番最初のタグが該当します。
タグの内容は最初の2バイトがタグの種類、次の2バイトが値のタイプ、次の4バイトが値の個数、
最後の4バイトが値あるいは値へのオフセットになりますが、タグの種類が画像の向きであれば、
最後の4バイトの値を見れば良いと思います。
各値の意味は下記のとおりです。
1:そのまま
2:水平反転
3:180度回転
4:180度回転して水平反転
5:90度回転して水平反転
6:90度回転
7:270度回転して水平反転
8:270度回転

投稿日時: 17/11/22 19:24:32
投稿者: baoo

バイナリで画像を読み込んでExif情報から画像の向きを取得するプログラムを組んだのですが、
お試しで組んだのでコードが汚い状態で、そのままにしていました。
ですが、GDI+で取得する方法があることを知り、Abyss2さんのコードに組み込んでみました。
Exif情報から画像の向きを取得してそれに合わせて画像を表示します。
 
フォーム上には
TextBox1:ファイル名表示用
CommandButton1:ファイル選択用
Image1:ファイル表示用
を配置します。
 

Option Explicit
Private Declare PtrSafe Function GdiplusStartup& Lib "gdiplus" _
    (ByRef token As LongPtr, _
     ByVal input_ As LongPtr, _
     Optional ByVal output_ As LongPtr)
Private Declare PtrSafe Sub GdiplusShutdown Lib "gdiplus" _
    (ByVal token As LongPtr)
Private Declare PtrSafe Function GdipCreateBitmapFromFile& Lib "gdiplus" _
    (ByVal filename_ As LongPtr, _
     ByRef bitmap_ As LongPtr)
Private Declare PtrSafe Function GdipImageRotateFlip& Lib "gdiplus" _
    (ByVal Image As LongPtr, _
     ByVal rfType As Long)
Private Declare PtrSafe Function GdipDisposeImage& Lib "gdiplus" _
    (ByVal image_ As LongPtr)
Private Declare PtrSafe Function GdipSaveImageToStream& Lib "gdiplus" _
    (ByVal image_ As LongPtr, _
     ByVal stream_ As IUnknown, _
     ByVal clsidEncoder As LongPtr, _
     Optional ByVal encoderParams As LongPtr)
Private Declare PtrSafe Function GdipGetImageWidth& Lib "gdiplus" _
    (ByVal Image As LongPtr, _
     ByRef width_ As Long)
Private Declare PtrSafe Function GdipGetImageHeight& Lib "gdiplus" _
    (ByVal Image As LongPtr, _
     ByRef height_ As Long)
Private Declare PtrSafe Function SHCreateMemStream Lib "Shlwapi" _
    (Optional ByVal pInit As LongPtr, _
     Optional ByVal cbInit As Long) As IUnknown
Private Declare PtrSafe Function IStream_Reset& Lib "Shlwapi" _
    (ByVal pstm As IUnknown)
Private Declare PtrSafe Function IIDFromString& Lib "Ole32" _
    (ByVal lpsz As LongPtr, _
     ByVal lpiid As LongPtr)
Private Declare PtrSafe Function OleLoadPicture& Lib "Oleaut32" _
    (ByVal lpstream As IUnknown, _
     Optional ByVal lSize As Long, _
     Optional ByVal fRunmode As Long, _
     Optional ByVal riid As LongPtr, _
     Optional ByRef lplpvObj As IUnknown)

Private Declare Function GdipGetPropertyItemSize& Lib "gdiplus" _
    (ByVal hImage As Long, _
    ByVal propId As Long, _
    ByRef lngSize As Long)
Private Declare Function GdipGetPropertyItem& Lib "gdiplus" _
    (ByVal Image As Long, _
    ByVal propId As Long, _
    ByVal propSize As Long, _
    ByRef buffer As Any)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, _
    Source As Any, _
    ByVal Length As Long)
Private Const PropertyTagOrientation  As Long = &H112&


Private Type PropertyItem
    id As Long
    Length As Long
    Type As Integer
    Value As Long
End Type


Private Type GdiplusStartupInput
    GdiplusVersion As Long
    dummy1 As LongPtr
    dummy2 As Long
    dummy3 As Long
End Type

'Private Const RotateNonFlipNone = 0
'Private Const Rotate90FlipNone  = 1
'Private Const Rotate180FlipNone = 2
'Private Const Rotate270FlipNone = 3

Private Const GUID_ENCODER_BMP = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Private Sub UserForm_Initialize()
    
    CommandButton1.Caption = "ファイル"

End Sub
Private Sub CommandButton1_Click()
        
    Dim mszPath As String
    mszPath = Application.GetOpenFilename("*.*,*.*")
    If mszPath = "False" Then
        Exit Sub
    End If
    TextBox1.Text = mszPath
    PictureRotate mszPath
    
End Sub
Private Sub PictureRotate(mszPath As String)

    Dim info As GdiplusStartupInput
    Dim pt As stdole.IPicture
    Dim pBm As LongPtr     '*Bitmapオブジェクト
    Dim stm As IUnknown    'IStream格納用として使う
    Dim tk As LongPtr      'トークン
    Dim hr As Long         'HRESULT
    Dim wd As Long, ht As Long
    Dim iid(3) As Long
    Dim piid As LongPtr
    Dim rto As Double      'point / pixel 単位変換用係数
    Dim acc As IAccessible
    Dim pic As stdole.IPictureDisp
    Dim mCnt As Long
    
    Set acc = Me
    acc.accLocation 0, 0, wd, 0 'Form自身のpixel単位幅を取得
    rto = InsideWidth / wd      '係数を確保
    
    piid = VarPtr(iid(0))
    
    info.GdiplusVersion = 1
    hr = GdiplusStartup(tk, VarPtr(info))
    If GdipCreateBitmapFromFile(StrPtr(mszPath), pBm) Then
        GdiplusShutdown tk
        MsgBox "ファイル指定エラー": Exit Sub
    End If
    
    '==============================baoo add==============================
    Dim lngSize As Long
    Dim buff() As Byte
    Dim PropItm As PropertyItem
    Dim intOnt As Integer       'プロパティ毎に型が変わるがOrientationはShort
    
    '取得プロパティサイズ
    hr = GdipGetPropertyItemSize(pBm, PropertyTagOrientation, lngSize)
    If lngSize = 0 Then '画像の向きについての情報が無い場合
        Image1.Picture = LoadPicture(mszPath)
        Exit Sub
    End If
    ReDim buff(lngSize - 1) As Byte

    'プロパティをバイト配列へ
    hr = GdipGetPropertyItem(pBm, PropertyTagOrientation, lngSize, buff(0))

    'バイト配列からPropertyItem型へ
    Call CopyMemory(PropItm, buff(0), LenB(PropItm))

    'PropItm.ValueはポインタなのでIntegerへ
    Call CopyMemory(intOnt, ByVal PropItm.Value, PropItm.Length)
    
    Select Case intOnt
    Case 1  'そのまま
        mCnt = 0
    Case 3  '180度回転
        mCnt = 2
    Case 6  '90度回転
        mCnt = 1
    Case 8  '270度回転
        mCnt = 3
    End Select
    '====================================================================
    
    hr = GdipImageRotateFlip(pBm, mCnt)  'イメージを回転
    hr = GdipGetImageWidth(pBm, wd)      'イメージ幅取得(pixel)
    hr = GdipGetImageHeight(pBm, ht)     'イメージ高さ取得(pixel)
    
    
    Set stm = SHCreateMemStream()        'メモリ上にIStream生成

    'エンコーディングに使うFormat指定(今回はBMP形式)
    hr = IIDFromString(StrPtr(GUID_ENCODER_BMP), piid)
    'イメージをメモリ上に保存
    hr = GdipSaveImageToStream(pBm, stm, piid)
    'Bitmapオブジェクト破棄
    hr = GdipDisposeImage(pBm)
    GdiplusShutdown tk

    'IStreamのカーソルを先頭へ移動
    hr = IStream_Reset(stm)
    'IID_IUnknown
    iid(0) = 0: iid(1) = 0: iid(2) = &HC0: iid(3) = &H46000000
    'IStreamからIPictureを抽出
    hr = OleLoadPicture(stm, , 1, piid, pt)
    
    Image1.Picture = pt
    
End Sub

回答
投稿日時: 17/11/22 20:30:30
投稿者: さむさむ

baooさん。
その後いろいろお調べいただき、また結果をご提示いただきありがとうございます。
私にはバイナリを読む力もなく、コードを見よう見まねで利用させていただくだけで
美味しいところだけつまんでいるようで、お恥ずかしいです。
 
ご提示のコードはまだ確認していないのですが、本当にありがとうございます。
もし、わからないところ(だらけなのですが)があれば、またご質問をさせてください。
 
このスレッドで申し訳ないのですが、Exif情報には位置情報と撮影時間も記録されると思うのですが取り出す方法も知りたいと思っています。
 
というのは、私が組んでるコードはハイキングの行程で撮った写真を地図上に落としていくものですが、
時間軸と座標軸が分かれば、コードを使って位置を取れればと思っています。
現在はJPGを見ながら手作業で行っています。
別の質問にしたほうがいいのかもしれませんが、コンセプトを書かせていただきました。
 
本当にありがとうございました。
 

投稿日時: 17/11/25 20:26:43
投稿者: baoo

位置情報についてはGPSによって記録された緯度、経度、高度の情報は取得できますが、
住所のようなものは取得できません。
住所については緯度、経度情報から別の方法で取得する必要があります。
(Google GeoCoding API等、ライセンスについては不明)
 
前回のコードでは画像の向きに合わせて表示するようにしましたが、
位置情報、撮影日情報は画像の向きとは関係ないので、
画像を表示する処理とは別にした方が良いかと考えました。
しかし、GDI+の初期化処理、終了処理をそれぞれで行うのはよろしくないと考え、
ビットマップオブジェクトからIPictureオブジェクトを取得する部分を分離し、
 
1.初期化およびビットマップオブジェクト作成
2.ビットマップオブジェクトから位置情報、撮影日情報の取得
3.ビットマップオブジェクトからIPictureオブジェクトの取得及び表示
4.ビットマップオブジェクトの破棄及び終了処理
 
の流れとなるように変更しました。
 
フォーム上に
テキストボックス:TextBox1,TextBox2,TextBox3,TextBox4,TextBox5,TextBox6
ボタン:CommandButton1,CommandButton2
イメージ:Image1
を配置してください。

Option Explicit
Private Declare PtrSafe Function GdiplusStartup& Lib "gdiplus" _
    (ByRef token As LongPtr, _
     ByVal input_ As LongPtr, _
     Optional ByVal output_ As LongPtr)
Private Declare PtrSafe Sub GdiplusShutdown Lib "gdiplus" _
    (ByVal token As LongPtr)
Private Declare PtrSafe Function GdipCreateBitmapFromFile& Lib "gdiplus" _
    (ByVal filename_ As LongPtr, _
     ByRef bitmap_ As LongPtr)
Private Declare PtrSafe Function GdipImageRotateFlip& Lib "gdiplus" _
    (ByVal Image As LongPtr, _
     ByVal rfType As Long)
Private Declare PtrSafe Function GdipDisposeImage& Lib "gdiplus" _
    (ByVal image_ As LongPtr)
Private Declare PtrSafe Function GdipSaveImageToStream& Lib "gdiplus" _
    (ByVal image_ As LongPtr, _
     ByVal stream_ As IUnknown, _
     ByVal clsidEncoder As LongPtr, _
     Optional ByVal encoderParams As LongPtr)
Private Declare PtrSafe Function GdipGetImageWidth& Lib "gdiplus" _
    (ByVal Image As LongPtr, _
     ByRef width_ As Long)
Private Declare PtrSafe Function GdipGetImageHeight& Lib "gdiplus" _
    (ByVal Image As LongPtr, _
     ByRef height_ As Long)
Private Declare PtrSafe Function SHCreateMemStream Lib "Shlwapi" _
    (Optional ByVal pInit As LongPtr, _
     Optional ByVal cbInit As Long) As IUnknown
Private Declare PtrSafe Function IStream_Reset& Lib "Shlwapi" _
    (ByVal pstm As IUnknown)
Private Declare PtrSafe Function IIDFromString& Lib "Ole32" _
    (ByVal lpsz As LongPtr, _
     ByVal lpiid As LongPtr)
Private Declare PtrSafe Function OleLoadPicture& Lib "Oleaut32" _
    (ByVal lpstream As IUnknown, _
     Optional ByVal lSize As Long, _
     Optional ByVal fRunmode As Long, _
     Optional ByVal riid As LongPtr, _
     Optional ByRef lplpvObj As IUnknown)

Private Declare PtrSafe Function GdipGetPropertyItemSize& Lib "gdiplus" _
    (ByVal Image As LongPtr, _
    ByVal propId As Long, _
    ByRef lngSize As Long)
Private Declare PtrSafe Function GdipGetPropertyItem& Lib "gdiplus" _
    (ByVal Image As LongPtr, _
    ByVal propId As Long, _
    ByVal propSize As Long, _
    ByRef buffer As Any)
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, _
    Source As Any, _
    ByVal Length As LongPtr)

Private Const PropertyTagOrientation  As Long = &H112&  '画像の方向
Private Const PropertyTagGpsLatitudeRef As Long = &H1&  '北緯 or 南緯
Private Const PropertyTagGpsLatitude As Long = &H2&     '緯度
Private Const PropertyTagGpsLongitudeRef As Long = &H3& '東経 or 西経
Private Const PropertyTagGpsLongitude As Long = &H4&    '経度
Private Const PropertyTagGpsAltitudeRef As Long = &H5&  '高度単位
Private Const PropertyTagGpsAltitude As Long = &H6&     '高度
Private Const PropertyTagExifDTOrig As Long = &H9003&   '元画像生成日(撮影日?)

Private Type PropertyItem
    id As Long
    Length As Long
    Type As Integer
    Value As Long
End Type

Private Const PropertyTagTypeByte = 1
Private Const PropertyTagTypeAscii = 2
Private Const PropertyTagTypeShort = 3
Private Const PropertyTagTypeLong = 4
Private Const PropertyTagTypeRational = 5
Private Const PropertyTagTypeUndefined = 7
Private Const PropertyTagTypeSLong = 9
Private Const PropertyTagTypeSRational = 10


Private Type GdiplusStartupInput
    GdiplusVersion As Long
    dummy1 As LongPtr
    dummy2 As Long
    dummy3 As Long
End Type

'Private Const RotateNonFlipNone = 0
'Private Const Rotate90FlipNone  = 1
'Private Const Rotate180FlipNone = 2
'Private Const Rotate270FlipNone = 3

Private Const GUID_ENCODER_BMP = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Private Sub UserForm_Initialize()
    
    CommandButton1.Caption = "ファイル"
    CommandButton2.Caption = "GoogleMap"
    CommandButton2.Enabled = False
    TextBox1.BorderStyle = fmBorderStyleSingle
    TextBox2.BorderStyle = fmBorderStyleSingle
    TextBox3.BorderStyle = fmBorderStyleSingle
    TextBox4.BorderStyle = fmBorderStyleSingle
    TextBox5.BorderStyle = fmBorderStyleSingle
    TextBox6.BorderStyle = fmBorderStyleSingle
    
    
End Sub
Private Sub CommandButton1_Click()
        
    Dim mszPath As String
    mszPath = Application.GetOpenFilename("*.*,*.*")
    If mszPath = "False" Then
        Exit Sub
    End If
    
    TextBox1.Text = mszPath
    MyMainLoadImage mszPath
    
End Sub
Private Sub MyMainLoadImage(mszPath As String)

    Dim info As GdiplusStartupInput
    Dim tk As LongPtr      'トークン
    Dim hr As Long
    Dim pBm As LongPtr
    Dim pt As stdole.IPicture
    
    Dim varLatRef As Variant
    Dim varLonRef As Variant
    Dim varLat As Variant
    Dim varLon As Variant
    Dim varAlt As Variant
    Dim varAltRef As Variant
    Dim varDate As Variant
    
    Dim strLat As String    'GoogleMap用緯度文字列
    Dim strLon As String    'GoogleMap用経度文字列
    Dim strURL As String    'GoogleMap URL
    
    '初期化とビットマップオブジェクト取得
    info.GdiplusVersion = 1
    hr = GdiplusStartup(tk, VarPtr(info))
    If GdipCreateBitmapFromFile(StrPtr(mszPath), pBm) Then
        GdiplusShutdown tk
        MsgBox "ファイル指定エラー": Exit Sub
    End If
    
    '緯度
    varLatRef = GetExifProperty(pBm, PropertyTagGpsLatitudeRef)
    If IsEmpty(varLatRef) Then
        TextBox2.Text = "No Data"
    Else
        varLat = GetExifProperty(pBm, PropertyTagGpsLatitude)
        If IsEmpty(varLat) Then
            TextBox2.Text = "No Data"
        Else
            If varLatRef = "N" Then
                TextBox2.Text = "北緯" & varLat(0) & "°" & varLat(1) & "'" & varLat(2) & """"
            ElseIf varLatRef = "S" Then
                TextBox2.Text = "南緯" & varLat(0) & "°" & varLat(1) & "'" & varLat(2) & """"
            End If
        End If
    End If
    
    '経度
    varLonRef = GetExifProperty(pBm, PropertyTagGpsLongitudeRef)
    If IsEmpty(varLonRef) Then
        TextBox3.Text = "No Data"
    Else
        varLon = GetExifProperty(pBm, PropertyTagGpsLongitude)
        If IsEmpty(varLon) Then
            TextBox3.Text = "No Data"
        Else
            If varLonRef = "E" Then
                TextBox3.Text = "東経" & varLon(0) & "°" & varLon(1) & "'" & varLon(2) & """"
            ElseIf varLonRef = "W" Then
                TextBox3.Text = "西経" & varLon(0) & "°" & varLon(1) & "'" & varLon(2) & """"
            End If
        End If
    End If

    '高度
    varAltRef = GetExifProperty(pBm, PropertyTagGpsAltitudeRef)
    If IsEmpty(varAltRef) Then
        TextBox4.Text = "No Data"
    Else
        varAlt = GetExifProperty(pBm, PropertyTagGpsAltitude)
        If IsEmpty(varAlt) Then
            TextBox4.Text = "No Data"
        Else
            If varAltRef(0) = &H0 Then
                TextBox4.Text = varAlt(0)
            ElseIf varAltRef(0) = &H1 Then
                TextBox4.Text = -(varAlt(0))
            End If
        End If
    End If
    
    'GoogleMapのURL作成
    If TextBox2.Text <> "No Data" And TextBox3.Text <> "No Data" Then
        strLat = CStr(varLat(0) + varLat(1) / 60 + varLat(2) / 3600)
        strLon = CStr(varLon(0) + varLon(1) / 60 + varLon(2) / 3600)
        If varLatRef = "S" Then
            strLat = "-" & strLat
        End If
        If varLonRef = "W" Then
            strLon = "-" & strLon
        End If
        
        strURL = "http://maps.google.com/maps?q=" & strLat & "," & strLon
        TextBox6.Text = strURL
        CommandButton2.Enabled = True
    Else
        TextBox6.Text = "No Data"
        CommandButton2.Enabled = False
    End If

    '日付
    varDate = GetExifProperty(pBm, PropertyTagExifDTOrig)
    If IsEmpty(varDate) Then
        TextBox5.Text = "No Data"
    Else
        TextBox5.Text = varDate
    End If

    'Image1に画像の読み込み
    Set pt = GetIPictureFromBitmap(pBm)
    If pt Is Nothing Then
        Image1.Picture = LoadPicture(mszPath)
    Else
        Image1.Picture = pt
    End If
    
    
    'Bitmapオブジェクト破棄
    hr = GdipDisposeImage(pBm)
    GdiplusShutdown tk
    
End Sub
'BitmapオブジェクトからIPictureを取得
Private Function GetIPictureFromBitmap(pBm As LongPtr) As stdole.IPicture
    
    Dim hr As Long
    Dim varOrnt As Variant
    Dim mCnt As Long
    Dim wd As Long
    Dim ht As Long
    Dim stm As IUnknown
    Dim piid As LongPtr
    Dim iid(3) As Long
    Dim pt As stdole.IPicture
    
    varOrnt = GetExifProperty(pBm, PropertyTagOrientation)
    If IsEmpty(varOrnt) Then
        'GetIPictureFromBitmap = LoadPicture(mszPath)
        Exit Function
    End If
    
    Select Case varOrnt(0)
    Case 1  'そのまま
        mCnt = 0
    Case 3  '180度回転
        mCnt = 2
    Case 6  '90度回転
        mCnt = 1
    Case 8  '270度回転
        mCnt = 3
    End Select
    
    piid = VarPtr(iid(0))

    hr = GdipImageRotateFlip(pBm, mCnt)  'イメージを回転
    hr = GdipGetImageWidth(pBm, wd)      'イメージ幅取得(pixel)
    hr = GdipGetImageHeight(pBm, ht)     'イメージ高さ取得(pixel)
    
    
    Set stm = SHCreateMemStream()        'メモリ上にIStream生成

    'エンコーディングに使うFormat指定(今回はBMP形式)
    hr = IIDFromString(StrPtr(GUID_ENCODER_BMP), piid)
    'イメージをメモリ上に保存
    hr = GdipSaveImageToStream(pBm, stm, piid)

    'IStreamのカーソルを先頭へ移動
    hr = IStream_Reset(stm)
    'IID_IUnknown
    iid(0) = 0: iid(1) = 0: iid(2) = &HC0: iid(3) = &H46000000
    'IStreamからIPictureを抽出
    hr = OleLoadPicture(stm, , 1, piid, pt)
    
    Set GetIPictureFromBitmap = pt
        
End Function
Private Sub CommandButton2_Click()
    
    Shell "explorer.exe '" & TextBox6.Text & "'"
    Dim objIE As Object
    Set objIE = CreateObject("InternetExplorer.Application")
    objIE.Visible = True
    objIE.Navigate2 TextBox6.Text
        
End Sub
'Exifタグ情報取得
Private Function GetExifProperty(pBm As LongPtr, intPropId As Long) As Variant

    Dim varTmp As Variant
    Dim lngSize As Long
    Dim buff() As Byte
    Dim PropItm As PropertyItem
    Dim intOnt As Integer
    Dim i As Long
    Dim hr As Long
    
'    Dim lngCount As Long
'    Dim lngProp() As Long
'    hr = GdipGetPropertyCount(pBm, lngCount)               'タグの数を取得
'    ReDim lngProp(lngCount - 1) As Long
'    hr = GdipGetPropertyIdList(pBm, lngCount, lngProp(0))  'タグのリストを取得
'    For i = 0 To lngCount - 1
'        Debug.Print Hex(lngProp(i))
'    Next i
    
    
    '取得プロパティサイズ
    hr = GdipGetPropertyItemSize(pBm, intPropId, lngSize)
    If lngSize = 0 Then
        Exit Function
    End If
    ReDim buff(lngSize - 1) As Byte
    
    'プロパティをバイト配列へ
    hr = GdipGetPropertyItem(pBm, intPropId, lngSize, buff(0))
    
    'バイト配列からPropertyItem型へ
    Call CopyMemory(PropItm, buff(0), LenB(PropItm))
    
    
    
    Dim bytProp() As Byte
    Dim strProp As String
    Dim intShrt() As Integer
    Dim lngShrt() As Long
    Dim lngLng() As Long
    Dim lngRat() As Long
    Dim lngSLng() As Long
    Dim lngSRat() As Long
    Dim dblRat() As Double
    Dim dblLng() As Double
    
    
    Select Case PropItm.Type
    Case PropertyTagTypeByte    'バイト配列
        ReDim bytProp(PropItm.Length - 1) As Byte
        Call CopyMemory(bytProp(0), ByVal PropItm.Value, PropItm.Length)
        GetExifProperty = bytProp
    Case PropertyTagTypeAscii   '文字列
        strProp = String(PropItm.Length - 1, vbNullChar)
        Call CopyMemory(ByVal strProp, ByVal PropItm.Value, PropItm.Length)
        GetExifProperty = strProp
    Case PropertyTagTypeShort   'unsigned short配列
        ReDim intShrt(PropItm.Length / 2 - 1) As Integer
        ReDim lngShrt(PropItm.Length / 2 - 1) As Long
        Call CopyMemory(intShrt(0), ByVal PropItm.Value, PropItm.Length)
        For i = 0 To UBound(intShrt)
            If intShrt(i) < 0 Then
                lngShrt(i) = intShrt(i) + 256 ^ 2
            Else
                lngShrt(i) = intShrt(i)
            End If
        Next i
        GetExifProperty = lngShrt
    Case PropertyTagTypeLong    'unsigned long配列
        ReDim lngLng(PropItm.Length / 4 - 1) As Long
        ReDim dblLng(PropItm.Length / 4 - 1) As Double
        Call CopyMemory(lngLng(0), ByVal PropItm.Value, PropItm.Length)
        For i = 0 To UBound(lngLng)
            If lngLng(i) < 0 Then
                dblLng(i) = lngLng(i) + 256 ^ 4
            Else
                dblLng(i) = lngLng(i)
            End If
        Next i
        GetExifProperty = dblLng
    Case PropertyTagTypeRational    'pair of unsigned long配列
        ReDim lngLng(PropItm.Length / 4 - 1) As Long
        ReDim dblLng(PropItm.Length / 4 - 1) As Double
        ReDim dblRat(PropItm.Length / 8 - 1) As Double
        Call CopyMemory(lngLng(0), ByVal PropItm.Value, PropItm.Length)
        For i = 0 To UBound(dblRat)
            If lngLng(i * 2) < 0 Then
                dblLng(i * 2) = lngLng(i * 2) + 256 ^ 4
            Else
                dblLng(i * 2) = lngLng(i * 2)
            End If
            If lngLng(i * 2 + 1) < 0 Then
                dblLng(i * 2 + 1) = lngLng(i * 2 + 1) + 256 ^ 4
            Else
                dblLng(i * 2 + 1) = lngLng(i * 2 + 1)
            End If
            dblRat(i) = dblLng(i * 2) / dblLng(i * 2 + 1)
        Next i
        GetExifProperty = dblRat
    Case PropertyTagTypeSLong   'Long配列
        ReDim lngSLng(PropItm.Length / 4 - 1) As Long
        Call CopyMemory(lngSLng(0), ByVal PropItm.Value, PropItm.Length)
        GetExifProperty = lngSLng
    
    Case PropertyTagTypeSRational   'pair of Long配列
        ReDim lngRat(PropItm.Length / 4 - 1) As Long
        ReDim dblRat(PropItm.Length / 8 - 1) As Double
        Call CopyMemory(lngRat(0), ByVal PropItm.Value, PropItm.Length)
        For i = 0 To UBound(dblRat)
            dblRat(i) = lngRat(i * 2) / lngRat(i * 2 + 1)
        Next i
        GetExifProperty = dblRat
    Case PropertyTagTypeUndefined   'バイト配列
        ReDim bytProp(PropItm.Length - 1) As Byte
        Call CopyMemory(bytProp(0), ByVal PropItm.Value, PropItm.Length)
        GetExifProperty = bytProp
    End Select

End Function

トピックに返信