No.2ベストアンサー
- 回答日時:
こちらにあります。
事前にグループ化する必要がある様です。標準モジュールに貼り付けて、出力先のファイルパスだけいじってやると動きました。圧縮率の指定方法は分かりません。ご参考まで。
http://vbatips.blog37.fc2.com/blog-entry-26.html …
No.5
- 回答日時:
こんにちは。
#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
No.4
- 回答日時:
#3です。
セレクトしないと動かないコードなので、
For Each shp In Sheets("Sheet1").Shapes
→ActiveSheet.Shapes
に変更願います。
No.3
- 回答日時:
#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:\testshape.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
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- その他(パソコン・スマホ・電化製品) 拡張子の選択方法について 4 2022/09/22 22:04
- Excel(エクセル) EXCELのグラフを画像(JPG形式)で保存、通常実行がうまく行かない。ステップインはうまく行く 3 2022/08/30 12:06
- Visual Basic(VBA) Excelのマクロコードについて教えてください。 1 2022/03/27 13:25
- Excel(エクセル) 【困っています】VBA 追加処理の記述を教えてください。 1 2022/08/25 22:54
- Visual Basic(VBA) 【前回の続き続きです、ご教示ください】VBAの記述方法がわかりません。 2 2022/08/24 20:49
- Excel(エクセル) エクセルシートのデータを1列飛ばしで別ブックのシートに貼り付けるマクロが知りたい 2 2023/06/05 22:37
- Visual Basic(VBA) 【VBA】写真の縦横比を変えずに貼り付ける 5 2023/06/13 11:42
- Visual Basic(VBA) 【困っています2】VBA 追加処理の記述を教えてください。 2 2022/08/26 11:42
- Excel(エクセル) ExcelVBA メモ帳を起動し名前を付けて指定フォルダに保存 2 2022/04/18 13:15
- PDF 画像調整してスクショし保存した画像を印刷する方法 1 2022/03/31 18:42
このQ&Aを見た人はこんなQ&Aも見ています
-
性格の違いは生まれた順番で決まる?長男長女・中間子・末っ子・一人っ子の性格の傾向
同じ環境で生まれ育っても、生まれ順で性格は違うものなのだろうか。家庭教育研究家の田宮由美さんに教えてもらった。
-
bmp画像をjpegやpng画像に圧縮する方法
Visual Basic(VBA)
-
bmp画像をtiff圧縮する方法
Visual Basic(VBA)
-
エクセルのVBAでクリップボードにコピーした画像をpng(or jpg or bmp)保存したい
Visual Basic(VBA)
-
-
4
VBAで画像圧縮はできますか?
Visual Basic(VBA)
-
5
DoEventsがやはり分からない
Visual Basic(VBA)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
pdfの保存方法を教えてください
-
オートシェイプをJPG保存
-
手のひらツールって何ですか。
-
エクセルファイルを2か所に保存...
-
エクセルに貼り付けてある画像...
-
PaintShop編集データをPDF保存...
-
フィナーレで作成した楽譜をM...
-
スクロール先のスクショ方法
-
拡張子.xtxファイルがPDFで保存...
-
ペイント等で保存すると絵が滲...
-
画像を拡大して保存する方法
-
macでのWEBブラウザの画像の保...
-
ホームページビルダー20でサイ...
-
つくった画像をBMP形式に保存す...
-
キャプチャ画像が真っ黒に・・・!
-
パソコン画面の保存の仕方。
-
弥生会計の保存の仕方
-
連番画像の保存について
-
解像度を連続変更しつつリネー...
-
なんとか動画の保存方法
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
pdfの保存方法を教えてください
-
エクセルファイルを2か所に保存...
-
拡張子.xtxファイルがPDFで保存...
-
画像を拡大して保存する方法
-
macでのWEBブラウザの画像の保...
-
ネット上で公開されている小説...
-
手のひらツールって何ですか。
-
つくった画像をBMP形式に保存す...
-
ペイント等で保存すると絵が滲...
-
スクロール先のスクショ方法
-
連番画像の保存について
-
オートシェイプをJPG保存
-
相手のホームページ画面を画像...
-
PaintShop編集データをPDF保存...
-
ホームページビルダー20でサイ...
-
PhotoshopのようにCMYKモードで...
-
添付ファイルを保存しないで開...
-
★エクセルをGIF保存したいので...
-
キャプチャ画像が真っ黒に・・・!
-
ペイントでテキストが、にじみます
おすすめ情報