Excel

JPEG画像の回転情報を変更するVBAマクロ

moug「マクロでJPEG画像のExif(Orientation)を書き換えたい」という質問(https://www.moug.net/faq/viewtopic.php?t=78227)がありました。

標準機能では処理できなさそうだったので、軽い気持ちでExifの回転情報について調べてみましたが、即断念。

リンクを辿ってこのサイトとか見てみましたが、これは無理。
バイナリから攻めるのは早々に諦めます。

.NetだとEncoder.Transformationで比較的簡単に変更できるようですが(「EXIFの情報に基づいて画像を回転する」参考)、画像の再保存となるので画質的にはあまり好ましくありません。

F6 Exif」のようなExifの編集ツールを使えば、画質を損なうことなく回転情報を変更できますが、それだともはやマクロを使う必要すらなくなってしまいます。

というわけで、別の方向からのアプローチとして、エクスプローラーの「向き」情報を変更する方法を調べてみたところ、Windows Vista以降であれば、IPropertyStore経由で何とかできそうなことが分かりました。
(エクスプローラーの「向き」=ExifのOrientation、なのかどうかは未確認ですが、この際置いておきます。)

とはいえ、VBAからの処理はどう考えてもキツそうです・・・。

そこでさらにググったところ、海外のフォーラムでタイプライブラリ(oleexp.tlb)を作ってくださっている方を見つけました。

良さげなサンプルコードもあるし、もうこれで良いじゃん!
サンキュー!VBForums!!

というわけで、以下コードです。

'oleexp.tlb要参照
' http://www.vbforums.com/showthread.php?786079-VB6-Modern-Shell-Interface-Type-Library-oleexp-tlb#dloleexp
'下記コード参考
' http://www.vbforums.com/showthread.php?803855-Vista-Code-Snippet-Get-and-set-the-Rating-(stars)-of-a-file
Option Explicit

Private Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
Private Declare Function SHCreateItemFromIDList Lib "shell32" (ByVal pidl As Long, riid As UUID, ppv As Any) As Long
Private Declare Sub ILFree Lib "shell32" (ByVal pidl As Long)

'System.Photo.Orientation
' https://docs.microsoft.com/en-us/windows/desktop/properties/props-system-photo-orientation
Public Enum PKEY_Photo_Orientation
  PHOTO_ORIENTATION_NORMAL = 1         '標準(Normal)
  PHOTO_ORIENTATION_FLIPHORIZONTAL = 2 '左右反転(Flip horizontal)
  PHOTO_ORIENTATION_ROTATE180 = 3      '180度回転(Rotate 180 degrees)
  PHOTO_ORIENTATION_FLIPVERTICAL = 4   '上下反転(Flip vertical)
  PHOTO_ORIENTATION_TRANSPOSE = 5      '転置(Transpose)
  PHOTO_ORIENTATION_ROTATE270 = 6      '270度回転(Rotate 270 degrees)
  PHOTO_ORIENTATION_TRANSVERSE = 7     '横置き(Transverse)
  PHOTO_ORIENTATION_ROTATE90 = 8       '90度回転(Rotate 90 degrees)
End Enum

Public Sub Sample()
  Dim img As String: img = "C:\Test\Picture\kuma.jpg"
  
  With CreateObject("Scripting.FileSystemObject")
    Select Case LCase(.GetExtensionName(img))
      Case "jpg", "jpeg"
      Case Else: Exit Sub
    End Select
  End With
  SetFileOrientation img, PHOTO_ORIENTATION_FLIPVERTICAL
End Sub

Public Function SetFileOrientation(ByVal sFile As String, ByVal lRotation As PKEY_Photo_Orientation) As Long
  Dim vvar As Variant
  Dim isi As IShellItem2
  Dim pidlFile As Long
  Dim pps As IPropertyStore
  Dim hr As Long
  Dim pkOrientation As PROPERTYKEY '{14B81DA1-0135-4D31-96D9-6CBFC9671A99}, 274
  
  DEFINE_PROPERTYKEY pkOrientation, &H14B81DA1, CInt(&H135), CInt(&H4D31), &H96, &HD9, &H6C, &HBF, &HC9, &H67, &H1A, &H99, 274
  
  vvar = CVar(lRotation)
  pidlFile = ILCreateFromPathW(StrPtr(sFile))
  Call SHCreateItemFromIDList(pidlFile, IID_IShellItem2, isi)
  
  isi.GetPropertyStore GPS_READWRITE, IID_IPropertyStore, pps
  hr = pps.SetValue(pkOrientation, vvar) 'returns S_OK if successful
  If hr = 0 Then hr = pps.Commit 'save the changes; returns S_OK if successful
  
  Set pps = Nothing
  Set isi = Nothing
  Call ILFree(pidlFile) 'always set your pidl free!
  
  SetFileOrientation = hr
End Function

Public Sub DEFINE_PROPERTYKEY(Name As PROPERTYKEY, L As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte, pid As Long)
  With Name.fmtid
    .Data1 = L
    .Data2 = w1
    .Data3 = w2
    .Data4(0) = B0
    .Data4(1) = b1
    .Data4(2) = b2
    .Data4(3) = B3
    .Data4(4) = b4
    .Data4(5) = b5
    .Data4(6) = b6
    .Data4(7) = b7
  End With
  Name.pid = pid
End Sub

Public Sub DEFINE_UUID(Name As UUID, L As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte)
  With Name
    .Data1 = L
    .Data2 = w1
    .Data3 = w2
    .Data4(0) = B0
    .Data4(1) = b1
    .Data4(2) = b2
    .Data4(3) = B3
    .Data4(4) = b4
    .Data4(5) = b5
    .Data4(6) = b6
    .Data4(7) = b7
  End With
End Sub

Public Function IID_IShellItem2() As UUID
'7e9fb0d3-919f-4307-ab2e-9b1860310c93
  Static iid As UUID

  If (iid.Data1 = 0) Then Call DEFINE_UUID(iid, &H7E9FB0D3, CInt(&H919F), CInt(&H4307), &HAB, &H2E, &H9B, &H18, &H60, &H31, &HC, &H93)
  IID_IShellItem2 = iid
End Function

Public Function IID_IPropertyStore() As UUID
'DEFINE_GUID(IID_IPropertyStore,0x886d8eeb, 0x8cf2, 0x4446, 0x8d,0x02,0xcd,0xba,0x1d,0xbd,0xcf,0x99);
  Static iid As UUID

  If (iid.Data1 = 0) Then Call DEFINE_UUID(iid, &H886D8EEB, CInt(&H8CF2), CInt(&H4446), &H8D, &H2, &HCD, &HBA, &H1D, &HBD, &HCF, &H99)
  IID_IPropertyStore = iid
End Function

oleexp.tlbをダウンロードして参照する必要がありますが、おかげさまで思ったより短いコードになりました。

しかしながら「oleexp.tlb」はすごい!
どれだけのインターフェースをサポートしてるんだ!?コレ。

「【JCUEセミナー】ストランディング個体からのメッセージ」に参加しました。前のページ

【感想】明日ちゃんのセーラー服5巻次のページ

関連記事

  1. Office アドイン

    [Office用アプリ]日経パソコン 2013/8/26号 の記事

    日経パソコン 2013/8/26号 のニュース&トレンドにOffice…

  2. Office関連

    VBAを学ぶときの参考資料

    知人から「Excelのマクロを勉強したいんだけど、どうやって勉強したら…

  3. Office関連

    Excelのアイデア機能でグラフやピボットグラフを一発作成

    Insider版のExcelに「アイデア」機能が追加されました。…

  4. Office関連

    Wikipediaの検索予測キーワードの一覧を取得するVBAマクロ

    Wikipediaのサーチボックスにキーワードを入力すると、入力したキ…

  5. Office関連

    [Office]OutlookとIMEの利用に関するアンケートへの回答でAmazonギフト券が当たる…

    昨年の11月、「シンプルリボン」に関するアンケートが行われました(下記…

  6. Office関連

    [VBA]CommandBars(“○○”).Controls.Addでメニ…

    Officeのユーザインタフェースがリボンに変わってから、下記のように…

コメント

  • コメント (0)

  • トラックバックは利用できません。

  1. この記事へのコメントはありません。

Time limit is exhausted. Please reload CAPTCHA.

※本ページはプロモーションが含まれています。

Translate

最近の記事

アーカイブ

PAGE TOP