GDIplusCODE


Option Explicit

Private Type FLTIMAGE
StructSize As Integer
Type As Byte
Reserved1(0 To 8) As Byte
hImage As Long
Reserved3(0 To 19) As Byte
End Type
Private Type FLTFILE
Reserved1 As Integer
Ext As String * 4
Reserved2 As Integer
Path As String * 260
Reserved3 As Currency
End Type

'32bit OS
Private Declare Function GetFilterInfo64 Lib _
"C:\Program Files (x86)\Common Files\microsoft shared\GRPHFLT\JPEGIM32.FLT" _
Alias "GetFilterInfo" (ByVal Ver As Integer, ByVal Reserved As Long, _
phMem As Long, ByVal flags As Long) As Long
'64bit OS
Private Declare Function GetFilterInfo32 Lib _
"C:\Program Files\Common Files\Microsoft Shared\Grphflt\JPEGIM32.FLT" _
Alias "GetFilterInfo" (ByVal Ver As Integer, ByVal Reserved As Long, _
phMem As Long, ByVal flags As Long) As Long

Private Declare Function ExportGr Lib "JPEGIM32.FLT" _
(ff As FLTFILE, fi As FLTIMAGE, ByVal hMem As Long) As Long
Private Const SaveExt As String = "Jpeg保存,*.Jpg"

Private Declare Function OpenClipboard Lib "user32" _
(ByVal hWndNewOwner As Long) As Long
Private Declare Function GetClipboardData Lib "user32" _
(ByVal uFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Const CF_ENHMETAFILE = 14
Private Declare Function CopyEnhMetaFile Lib "gdi32" _
Alias "CopyEnhMetaFileA" _
(ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" _
(ByVal hemf As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" _
(ByVal hMem As Long) As Long

'============================================================
'☆選択したオートシェープ、セル等をJPEGで保存
'DLLの宣言のAliasを活用して、OSのbit数により別々の場所から読み込んでいる

Sub saveSelectionAsJpeg()
  Dim myPath
  
  myPath = GetDesktopPath & "\fltTest.jpg"
  Call Selection.CopyPicture(xlPrinter, xlPicture)
  If SaveCBPictureAs(myPath) Then
  MsgBox "保存しました", vbInformation, Dir(myPath)
  Else
  MsgBox "失敗しました"
  End If
End Sub

Private Function SaveCBPictureAs(ByVal SavePath As String) As Boolean
  Dim fi As FLTIMAGE
  Dim ff As FLTFILE
  Dim hemf As Long
  Dim hMem As Long
  
  If OpenClipboard(0) Then
    hemf = CopyEnhMetaFile( _
    GetClipboardData(CF_ENHMETAFILE), vbNullString)
    CloseClipboard
  End If
  If hemf = 0 Then
    Exit Function
  End If
  ff.Path = SavePath & vbNullChar
  With fi
    .StructSize = LenB(fi)
    .Type = 1
    .hImage = hemf
  End With
  ' フィルタ呼び出し
  Select Case CheckOSbitCount
    Case 32
      If GetFilterInfo32(3, 0, hMem, &H10000) And &H10 Then
        If ExportGr(ff, fi, hMem) = 0 Then
        SaveCBPictureAs = True
        End If
      End If
    Case 64
      If GetFilterInfo64(3, 0, hMem, &H10000) And &H10 Then
        If ExportGr(ff, fi, hMem) = 0 Then
        SaveCBPictureAs = True
        End If
      End If
  End Select
  If hMem Then GlobalFree hMem
  DeleteEnhMetaFile hemf
End Function

'Windowsのbit数を求める
Private Function CheckOSbitCount() As Long
  'WMIにて使用する各種オブジェクトを定義・生成する。
  Dim oClassSet
  Dim oClass
  Dim oLocator
  Dim oService
  Dim sMesStr
  
  'ローカルコンピュータに接続する。
  Set oLocator = CreateObject("WbemScripting.SWbemLocator")
  Set oService = oLocator.ConnectServer
  'クエリー条件をWQLにて指定する。
  Set oClassSet = oService.ExecQuery("Select * From Win32_OperatingSystem")
  
  'コレクションを解析する。
  For Each oClass In oClassSet
    '最初の一個で打ち切って良いか不明だが...
    '元コードは複数取得して繋いでいた
    sMesStr = CStr(oClass.OSArchitecture)
    Exit For
  Next
  '32ビットといった文字列で取得される
  CheckOSbitCount = Val(sMesStr)
  
  '使用した各種オブジェクトを後片付けする。
  Set oClassSet = Nothing
  Set oClass = Nothing
  Set oService = Nothing
  Set oLocator = Nothing
End Function

'============================================================
'☆おまけ1 Office Graphic Filter のJPEG画質設定
Sub jpegQualityTest()
  setGraphicFilterJpegQuality 90
End Sub

'Office Graphic Filterの画質設定
Private Sub setGraphicFilterJpegQuality(jpegQuality As Long)
  Dim WshShell As Object
  Dim strNew As String
  Dim strRtn As String
  
'regedit.exeで確認するとQualityはREG_SZ：文字列とされている
  Const defaultValue As String = "0x0000004b"
  Const location32 As String = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Shared Tools\Graphics Filters\Export\JPEG\Options\Quality"
  Const location64 As String = "HKEY_CURRENT_USER\Software\Microsoft\Shared Tools\Graphics Filters\Export\JPEG\Options\Quality"
  
  If jpegQuality < 10 Or jpegQuality > 95 Then
    MsgBox "Invalid Jpeg Quality"
     Exit Sub
  End If
  strNew = defaultValue
  Set WshShell = CreateObject("WScript.Shell")
  Mid(strNew, 9, 2) = LCase(Hex(jpegQuality))
  On Error GoTo errHandle
  Select Case CheckOSbitCount
    Case 32
       strRtn = WshShell.RegRead(location32)
      WshShell.RegWrite location32, strNew, "REG_SZ"
    Case 64
       strRtn = WshShell.RegRead(location64)
      WshShell.RegWrite location64, strNew, "REG_SZ"
  End Select
'  Debug.Print strRtn
  
errHandle:
  If Err.Number <> 0 Then MsgBox "Read error of registry"
  Set WshShell = Nothing
End Sub

'============================================================
'☆おまけ2 Office Graphic Filter DLLへのパスをユーザー環境変数に設定
'ユーザー環境変数のPathに設定することで､DllのDeclareのパスを外して動作する事を確認した

Sub setJpegFlt2EnvPath()
  Dim rtnName As String
  
  Const filePath32 As String = "C:\Program Files\Common Files\Microsoft Shared\Grphflt\JPEGIM32.FLT"
  Const filePath64 As String = "C:\Program Files (x86)\Common Files\microsoft shared\GRPHFLT\JPEGIM32.FLT"
  
  rtnName = Dir(filePath32)
  If rtnName = "" Then
    rtnName = Dir(filePath64)
    If rtnName = "" Then
      MsgBox "JPEG Filter Not Found"
      Exit Sub
    Else
      setUserPathEnv filePath64
    End If
    setUserPathEnv filePath32
  End If
End Sub

Private Sub setUserPathEnv(strNewPath As String)
  Dim objShell, strSystemPath, strUserPath, rCode ', strNewPath
  
  Set objShell = CreateObject("wscript.shell")
  On Error Resume Next
  strUserPath = objShell.RegRead("HKCU\Environment\Path")
  Select Case Err.Number
    '正常に取得できた場合は追記する　重複チェック
    Case 0
      If InStr(strUserPath, strNewPath) = 0 Then
        rCode = objShell.RegWrite("HKCU\Environment\Path", strUserPath & ";" & strNewPath, "REG_SZ")
      End If
    '存在しないとエラーになるので新規生成
'  -2147024894   レジストリ キー hoge  を開いて読み取ることができません。
    Case -2147024894
      rCode = objShell.RegWrite("HKCU\Environment\Path", strNewPath, "REG_SZ")
    Case Else
      MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & Err.Source
      Exit Sub
  End Select
End Sub

Private Function GetDesktopPath() As String
Dim wScriptHost As Object, strInitDir As String
Set wScriptHost = CreateObject("Wscript.Shell")
GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
Set wScriptHost = Nothing
End Function
Office Graphic Filter あれこれ
