作業を効率化させるExcel VBA Tips集

上記の広告は１ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

このブログ以外でもブログを書いてますが、記事を書く際、Excel上で作成したオートシェイプを記事中に掲載することがあります。それを行うには、以下の手順を踏むことになります。

[Excelオートシェイプをブログへアップロードする手順]
１．Excelで図形を作成する
　↓
２．Excelで図形をコピー
　↓
３．グラフィックソフトを開く
　↓
４．コピーした図形を貼り付ける
　↓
５．JPEG指定で保存する
　↓
６．ブログの管理画面を開く
　↓
７．JPGファイルをブログへアップロード

一番力を入れたいのが、手順１の作業なのですが、それ以外の作業も意外に時間かかります。
ということで、今回２、３、４、５の手順をExcel VBAで自動化させることにしました。という経緯です。
なので、Excel上で作成したオートシェイプの図形をボタン一つでファイルに保存させたい方向けのサンプルです。

【制限事項】
今回のサンプルの仕様として、指定できる図形は、１つのみです。
例えば、下図のようにExcelシート状に複数の図形が存在し、それを１枚の画像として扱いたい場合は、複数の図形を選択してグループ化してください。そのグループ化した図形に対してJPGファイルを出力させることが可能です。



[図１　複数図形が存在する場合]

今回のサンプルはネット上のソースを流用しています。その為、内部でおこなっている動作については良くわかっていません。少しは調べましたが、情報に乏しく断念しました。

---

定義セクションに関しては特に知らなくても大丈夫だと思います。SaveClipToJpg関数を呼び出すことで、指定図形を指定のパスへ保存します。関数仕様については、ソース内のコメントを参照してください。

---

'--------------------------------------------------------------------
' 定義セクション
'--------------------------------------------------------------------
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
Private Declare Function GetFilterInfo Lib _
  "C:\Program Files\Common Files\Microsoft Shared\Grphflt\JPEGIM32.FLT" _
       (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 Declare Function OpenClipboard Lib "user32" _
        (ByVal hWndNewOwner As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" _
        (ByVal uFormat As Long) 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
'--------------------------------------------------------------------
' 関数名 : SaveClipToJpg
' 機能   : 指定図形をJPGファイルとして保存する
' 引数   : img : シェイプオブジェクト[I]
'          path ：格納先パス（ファイル名も含む）
' 戻り値 : 成否
' 作成日 : 2008/03/08
' 作成者 : lily(http://vbatips.blog37.fc2.com/)
'--------------------------------------------------------------
Function SaveClipToJpg(img As Shape, Path As String) As Boolean
Dim tFltImg As FLTIMAGE
Dim tFltFile As FLTFILE
Dim hemf As Long
Dim hMem As Long
  
    SaveClipToJpg = False
    
    'クリップボードにコピー
    img.CopyPicture
    'Selection.CopyPicture
    If OpenClipboard(0) Then
        hemf = CopyEnhMetaFile( _
                GetClipboardData(CF_ENHMETAFILE), _
                vbNullString)
        CloseClipboard
    End If
    If hemf = 0 Then Exit Function
    
    ' パラメータ設定
    tFltFile.Path = Path & vbNullChar
    With tFltImg
        .StructSize = LenB(tFltImg)
        .Type = 1
        .hImage = hemf
    End With
    ' フィルタ呼び出し
    If GetFilterInfo(3, 0, hMem, &H10000) And &H10 Then
        If ExportGr(tFltFile, tFltImg, hMem) = 0 Then
            SaveClipToJpg = True
        End If
    End If
    
    If hMem Then GlobalFree hMem
    DeleteEnhMetaFile hemf

End Function

---

呼び出し元のサンプルを以下に掲載します。

Sub testsave()
Dim bSaveFlg As Boolean
Dim sShapeName As String
Dim sSavePath As String

    sShapeName = Selection.Name
    sSavePath = "E:/test/shape.jpg"

    bSaveFlg = SaveClipToJpg(ActiveSheet.shapes(sShapeName), sSavePath)
    If bSaveFlg = True Then
        MsgBox "保存に成功しました"
    Else
        MsgBox "保存に失敗しました"
    End If
      
End Sub