オートシェイプをJPG保存

Question

お世話になります。
オートシェープがいくつかシートに貼りついており
それをすべて選択してJPGとして別名保存がしたいのですが
可能でしょうか？
お分かりの方、ぜひ教えてください。
よろしくお願いいたします。

mitarashi · Accepted Answer

こちらにあります。事前にグループ化する必要がある様です。
標準モジュールに貼り付けて、出力先のファイルパスだけいじってやると動きました。圧縮率の指定方法は分かりません。ご参考まで。
http://vbatips.blog37.fc2.com/blog-entry-26.html#more

Hayashi_Trek · Answer

２種類の方法を
●方法１
画面のハードコピー（PrintScreenキー）を取り、ペイントに貼り付ける。
必要な部分のみ切り出して、jpegで保存する。

●方法２
エクセルをHTML形式で保存する。
オートシェープはgifとして保存される。
ペイントでgifを読込み、jpegで保存する。

mitarashi · Answer

#2です。
参考URLのコードを改造させていただいて、コントロールツールボックスのアイテム以外を選択して、クリップボードにコピーし、JPEGで保存する様にしてみました。当該ブログのオーナー様ご容赦下さい。
'参考URLのSaveClipToJpgの代わりに使う
Sub SaveShapesToJpg()
    Dim tFltImg As FLTIMAGE
    Dim tFltFile As FLTFILE
    Dim hemf As Long
    Dim hMem As Long
    Dim shp As Shape
    Dim myArray() As Variant
    Dim lcnt As Long
    Const sSavePath As String = "c:	estshape.jpg"
    
    For Each shp In Sheets("Sheet1").Shapes
        If Not shp.Type = msoOLEControlObject Then
            ReDim Preserve myArray(lcnt)
            myArray(UBound(myArray)) = shp.Name
            lcnt = lcnt + 1
        End If
    Next shp
    'クリップボードにコピー
    ActiveSheet.Shapes.Range(myArray).Select
    Selection.Copy
    If OpenClipboard(0) Then
        hemf = CopyEnhMetaFile( _
                GetClipboardData(CF_ENHMETAFILE), _
                vbNullString)
        CloseClipboard
    End If
    If hemf = 0 Then Exit Sub
    ' パラメータ設定
    tFltFile.Path = sSavePath & 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
            MsgBox "失敗しました"
        End If
    End If
    If hMem Then GlobalFree hMem
    DeleteEnhMetaFile hemf
End Sub

mitarashi · Answer

#3です。
セレクトしないと動かないコードなので、
For Each shp In Sheets("Sheet1").Shapes
→ActiveSheet.Shapes
に変更願います。

KenKen_SP · Answer

こんにちは。

#3 ご紹介の方法はオフィスのグラフィックフィルタを利用したものですね。
現在は大抵の環境でインストールされているでしょうし、ソースも簡易で
いいですね＾＾

以前 VB6 向けに作った画像処理クラスから抜粋してみました。
GdiPlus.dll というライブラリを利用した方法です。

GdiPlus.dll は WinXP 以降の OS で標準搭載されています。他の古い OS
では Microsoft の Web ページからダウンロードする必要があるかもしれ
ませんが、現在の PC ならば問題なく動くと思います。

BMP, JPG, GIF, TIF, PNG などの各種フォーマットが選択でき、JPG の場合は、
圧縮品質を指定できるようにしてあります。

SaveImageToFile 関数の連続呼び出しを考慮して GDI+ の初期化と終了を
別プロシージャにしましたが、最後に必ず GDI+ の終了プロシージャを呼び
出す必要がありますので、デバッグ時やエラー時にご注意を。


Option Explicit

' // クリップボード関係
Private Declare Function OpenClipboard Lib "user32.dll" ( _
　　　　ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" ( _
　　　　ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Const CF_BITMAP　 As Long = 2

' // GDI+関係
Private Declare Function GdiplusStartup Lib "gdiplus" ( _
　　　　ByRef token As Long, _
　　　　ByRef inputBuf As GdiplusStartupInput, _
　　　　ByVal outputBuf As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" ( _
　　　　ByVal token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" ( _
　　　　ByVal hbm As Long, _
　　　　ByVal hpal As Long, _
　　　　ByRef bitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" ( _
　　　　ByVal image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" ( _
　　　　ByVal image As Long, _
　　　　ByVal filename As Long, _
　　　　ByRef clsidEncoder As GUID, _
　　　　ByVal encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" ( _
　　　　ByVal lpszCLSID As Long, _
　　　　ByRef pCLSID As GUID) As Long

Private Type GdiplusStartupInput
　　　　GdiplusVersion　　　　　 As Long　　' UINT32 GdiplusVersion
　　　　DebugEventCallback　　　 As Long　　' DebugEventProc DebugEventCallback
　　　　SuppressBackgroundThread As Long　　' BOOL SuppressBackgroundThread
　　　　SuppressExternalCodecs　 As Long　　' BOOL SuppressExternalCodecs
End Type
Private Type GUID
　　　　Data1　　　　　　　　　　As Long　　' unsigned long　Data1
　　　　Data2　　　　　　　　　　As Integer ' unsigned short Data2
　　　　Data3　　　　　　　　　　As Integer ' unsigned short Data3
　　　　Data4(7)　　　　　　　　 As Byte　　' unsigned char　Data4[8]
End Type
Private Type EncoderParameter
　　　　GUID　　　　　　　　　　 As GUID　　' GUID Encoder Guid
　　　　NumberOfValues　　　　　 As Long　　' ULONG NumberOfValues
　　　　TypeAPI　　　　　　　　　As Long　　' ULONG Type
　　　　Value　　　　　　　　　　As Long　　' VOID* Value
End Type
Private Type EncoderParameters
　　　　count　　　　　As Long　　　　　　　' UINT Count
　　　　Parameter(15)　As EncoderParameter　' EncoderParameter Parameter[l]
End Type

Private Const QUALITY_PARAMS As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Const ENCODER_BMP　　As String = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_JPG　　As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_GIF　　As String = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_TIF　　As String = "{557CF405-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_PNG　　As String = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"

Private m_GDIplusToken As Long

' // GDI+ 初期化
Private Function GDIplus_Initialize() As Boolean
　　
　　Dim uGdiStartupInput As GdiplusStartupInput
　　Dim nStatus　　　　　As Long
　　
　　If m_GDIplusToken Then Call Gdiplus_Shutdown
　　With uGdiStartupInput
　　　　.GdiplusVersion = 1
　　　　.DebugEventCallback = 0
　　　　.SuppressBackgroundThread = 0
　　　　.SuppressExternalCodecs = 0
　　End With
　　nStatus = GdiplusStartup(m_GDIplusToken, uGdiStartupInput, 0&)
　　GDIplus_Initialize = CBool(nStatus = 0)

End Function

' // GDI+ 終了
Private Function Gdiplus_Shutdown() As Long
　　If m_GDIplusToken Then
　　　　Call GdiplusShutdown(m_GDIplusToken)
　　　　m_GDIplusToken = 0
　　End If
End Function

' // GDI+ hBitmap からファイルへ書き出し
Public Function SaveImageToFile( _
　　ByVal hBmp As OLE_HANDLE, _
　　ByVal sFilename As String, _
　　Optional ByVal sFormat As String = "JPG", _
　　Optional ByVal nQuarity As Long = 60 _
) As Boolean

　　'@ sFormat : BMP, JPG, GIF, TIF, PNG
　　'@ nQuality: 0-100(0:高圧縮低画質, 100:低圧縮高画質, Jpg のみ有効)

　　If hBmp = 0 Then Exit Function
　　
　　Dim sEncoderStr　As String
　　Select Case UCase$(sFormat)
　　　　Case "JPG": sEncoderStr = ENCODER_JPG
　　　　Case "GIF": sEncoderStr = ENCODER_GIF
　　　　Case "TIF": sEncoderStr = ENCODER_TIF
　　　　Case "PNG": sEncoderStr = ENCODER_PNG
　　　　Case Else:　sEncoderStr = ENCODER_BMP
　　End Select

　　Dim uEncoderParams　 As EncoderParameters
　　' Jpeg のクオリティー設定
　　If UCase$(sFormat) = "JPG" Then
　　　　nQuarity = Abs(nQuarity)
　　　　If nQuarity > 100 Then nQuarity = 100
　　　　uEncoderParams.count = 1
　　　　With uEncoderParams.Parameter(0)
　　　　　　.GUID = pvToCLSID(QUALITY_PARAMS)
　　　　　　.TypeAPI = 4 ' Type Long
　　　　　　.Value = VarPtr(nQuarity)
　　　　　　.NumberOfValues = 1
　　　　End With
　　End If
　　
　　' 保存処理
　　Dim nStatus　 As Long
　　Dim pNewImage As Long
　　nStatus = GdipCreateBitmapFromHBITMAP(hBmp, 0&, pNewImage)
　　If nStatus = 0 Then
　　　　If UCase$(sFormat) = "JPG" Then
　　　　　　nStatus = GdipSaveImageToFile(pNewImage, _
　　　　　　　　　　　　　　　　　　　　　StrPtr(sFilename), _
　　　　　　　　　　　　　　　　　　　　　pvToCLSID(sEncoderStr), _
　　　　　　　　　　　　　　　　　　　　　VarPtr(uEncoderParams))
　　　　Else
　　　　　　nStatus = GdipSaveImageToFile(pNewImage, _
　　　　　　　　　　　　　　　　　　　　　StrPtr(sFilename), _
　　　　　　　　　　　　　　　　　　　　　pvToCLSID(sEncoderStr), _
　　　　　　　　　　　　　　　　　　　　　ByVal 0&)
　　　　End If
　　　　SaveImageToFile = CBool(nStatus = 0)
　　　　Call GdipDisposeImage(pNewImage)
　　End If
　 
End Function

' // クリップボード hBitmap を取得する
Private Function pvGetHBitmapFromClipboard() As OLE_HANDLE
　　If OpenClipboard(0&) <> 0 Then
　　　　pvGetHBitmapFromClipboard = GetClipboardData(CF_BITMAP)
　　　　Call CloseClipboard
　　End If
End Function

' // 文字列から CLSID を取得する
Private Function pvToCLSID(ByVal S As String) As GUID
　　CLSIDFromString StrPtr(S), pvToCLSID
End Function


' // サンプル： Active シート内のシェープを Jpeg で保存する
Sub Sample()
　　
　　Dim shp　　As Shape
　　Dim hBmp　 As OLE_HANDLE
　　Dim nCount As Long
　　
　　' シート内のシェープを選択する
　　nCount = 0
　　For Each shp In ActiveSheet.Shapes
　　　　' shp.Type プロパティーの値で選択するか決める
　　　　Select Case shp.Type
　　　　　　Case msoFormControl, msoOLEControlObject
　　　　　　Case Else
　　　　　　　　shp.Select Replace:=False
　　　　　　　　nCount = nCount + 1
　　　　End Select
　　Next
　　
　　If nCount > 0 Then
　　　　' GDI+ を初期化する
　　　　If GDIplus_Initialize() = False Then
　　　　　　MsgBox "GDI+ を初期化できません", vbCritical
　　　　　　Exit Sub
　　　　End If
　　　　' クリップボードにコピーする
　　　　Selection.CopyPicture xlScreen, xlBitmap
　　　　' Bitmap のハンドル(メモリ上のアドレスみたいなもの)を取得
　　　　hBmp = pvGetHBitmapFromClipboard()
　　　　' 保存(JPEG でクオリティー30の場合）
　　　　If SaveImageToFile(hBmp, "C:\sample.jpg", "jpg", 30) = False Then
　　　　　　MsgBox "保存に失敗", vbCritical
　　　　Else
　　　　　　MsgBox "保存に成功", vbInformation
　　　　End If
　　　　' GDI+ を終了させる（必ず呼び出すこと）
　　　　Call Gdiplus_Shutdown
　　Else
　　　　MsgBox "保存すべきものがない", vbCritical
　　End If

End Sub

オートシェイプをJPG保存

２種類の方法を

この回答への補足

こちらにあります。

#2です。

#3です。

こんにちは。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング