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で質問しましょう!
このQ&Aを見た人はこんなQ&Aも見ています
-
【大喜利】【投稿~9/7】 ロボットの住む世界で流行ってる罰ゲームとは?
ロボットの住む世界で流行ってる罰ゲームとは?
-
フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
あなたが普段思っている「これまだ誰も言ってなかったけど共感されるだろうな」というあるあるを教えてください
-
映画のエンドロール観る派?観ない派?
映画が終わった後、すぐに席を立って帰る方もちらほら見かけます。皆さんはエンドロールの最後まで観ていきますか?
-
海外旅行から帰ってきたら、まず何を食べる?
帰国して1番食べたくなるもの、食べたくなるだろうなと思うもの、皆さんはありますか?
-
天使と悪魔選手権
悪魔がこんなささやきをしていたら、天使のあなたはなんと言って止めますか?
-
bmp画像をjpegやpng画像に圧縮する方法
Visual Basic(VBA)
-
bmp画像をtiff圧縮する方法
Visual Basic(VBA)
-
レコードを保存するコード アクセスvba
その他(Microsoft Office)
-
-
4
エクセルのVBAでクリップボードにコピーした画像をpng(or jpg or bmp)保存したい
Visual Basic(VBA)
-
5
DoEventsがやはり分からない
Visual Basic(VBA)
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・人生のプチ美学を教えてください!!
- ・10秒目をつむったら…
- ・あなたの習慣について教えてください!!
- ・牛、豚、鶏、どれか一つ食べられなくなるとしたら?
- ・【大喜利】【投稿~9/18】 おとぎ話『桃太郎』の知られざるエピソード
- ・街中で見かけて「グッときた人」の思い出
- ・「一気に最後まで読んだ」本、教えて下さい!
- ・幼稚園時代「何組」でしたか?
- ・激凹みから立ち直る方法
- ・1つだけ過去を変えられるとしたら?
- ・【あるあるbot連動企画】あるあるbotに投稿したけど採用されなかったあるある募集
- ・【あるあるbot連動企画】フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
- ・映画のエンドロール観る派?観ない派?
- ・海外旅行から帰ってきたら、まず何を食べる?
- ・誕生日にもらった意外なもの
- ・天使と悪魔選手権
- ・ちょっと先の未来クイズ第2問
- ・【大喜利】【投稿~9/7】 ロボットの住む世界で流行ってる罰ゲームとは?
- ・推しミネラルウォーターはありますか?
- ・都道府県穴埋めゲーム
- ・この人頭いいなと思ったエピソード
- ・準・究極の選択
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルファイルを2か所に保存...
-
ホームページビルダー20でサイ...
-
ペイント等で保存すると絵が滲...
-
macでのWEBブラウザの画像の保...
-
円の中に縁に沿って 文字列を...
-
PhotoshopのようにCMYKモードで...
-
オートシェイプをJPG保存
-
連番画像の保存について
-
★エクセルをGIF保存したいので...
-
スクロール先のスクショ方法
-
画像を拡大して保存する方法
-
画像が薄くなります。
-
拡張子.xtxファイルがPDFで保存...
-
ファイルを文字列としてコピー...
-
エクセルの画像をJPGファイ...
-
ワードアートを画像として保存...
-
つくった画像をBMP形式に保存す...
-
フィナーレで作成した楽譜をM...
-
現在使用中の壁紙のファイルの...
-
フォルダ内のファイルは削除せ...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセルファイルを2か所に保存...
-
画像を拡大して保存する方法
-
macでのWEBブラウザの画像の保...
-
つくった画像をBMP形式に保存す...
-
ペイント等で保存すると絵が滲...
-
拡張子.xtxファイルがPDFで保存...
-
PDFの修正できるソフトで修正し...
-
EXCELをJPEGで保存ができますか。
-
PaintShop編集データをPDF保存...
-
PhotoshopのようにCMYKモードで...
-
ネット上で公開されている小説...
-
スクロール先のスクショ方法
-
オートシェイプをJPG保存
-
添付ファイルを保存しないで開...
-
ペイントでテキストが、にじみます
-
pdfの保存方法を教えてください
-
手のひらツールって何ですか。
-
連番画像の保存について
-
画像掲示板のURLの先の画像を保...
-
相手のホームページ画面を画像...
おすすめ情報