| |
こんにちは。かみちゃん です。
> 別面でjpeg保存する部分まで、vbaではできないのでしょうか？
ｈｔｔｐ://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=57318;id=excel
で、kanabunさんが紹介されていた
>> シート上の図や画像をjpgファイルとして保存するには
>>
>> SaveCBPictureAs
>>
>> というshiraさんという方の関数
を利用すると、以下のような感じてできませんか？
なお、
ｈｔｔｐ://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=69743;id=excel
の質問と何が違うのかよくわかりませんが、
以下のコードは、アクティブシートのすべての
msoPicture をファイルに保存する方法です。
すべてのシートの特定のセルにある msoPicture であれば、これをベースに修正すればできると思います。
Option Explicit
'ｈｔｔｐ://www4.ocn.ne.jp/~outfocus/gdip/pic2bmp2.html
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
'ここで出力形式を選択する
#Const FLT_MODE = -1
#If FLT_MODE = -1 Then 'PNG
Private Declare Function GetFilterInfo Lib _
"C:\Program Files\Common Files\Microsoft Shared\Grphflt\PNG32.FLT" _
(ByVal Ver As Integer, ByVal Reserved As Long, _
phMem As Long, ByVal flags As Long) As Long
Private Declare Function ExportGr Lib "PNG32.FLT" _
(ff As FLTFILE, fi As FLTIMAGE, ByVal hMem As Long) As Long
Private Const SaveExt As String = "PNG保存,*.png"
#ElseIf FLT_MODE = 1 Then 'JPEG
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 Const SaveExt As String = "Jpeg保存,*.Jpg"
#ElseIf FLT_MODE = 2 Then 'TIFF
Private Declare Function GetFilterInfo Lib _
"C:\Program Files\Common Files\Microsoft Shared\Grphflt\TIFFIM32.FLT" _
(ByVal Ver As Integer, ByVal Reserved As Long, _
phMem As Long, ByVal flags As Long) As Long
Private Declare Function ExportGr Lib "TIFFIM32.FLT" _
(ff As FLTFILE, fi As FLTIMAGE, ByVal hMem As Long) As Long
Private Const SaveExt As String = "TIFF保存,*.Tif"
#Else ' GIF
Private Declare Function GetFilterInfo Lib _
"C:\Program Files\Common Files\Microsoft Shared\Grphflt\GIFIMP32.FLT" _
(ByVal Ver As Integer, ByVal Reserved As Long, _
phMem As Long, ByVal flags As Long) As Long
Private Declare Function ExportGr Lib "GIFIMP32.FLT" _
(ff As FLTFILE, fi As FLTIMAGE, ByVal hMem As Long) As Long
Private Const SaveExt As String = "GIF保存,*.Gif"
#End If
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
Function SaveCBPictureAs(ByVal SavePath As String) As Boolean
' クリップボードにコピーされたEMFイメージを _
定数 FLT_MODE で指定された形式で保存
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
' パラメータ設定
ff.Path = SavePath & vbNullChar
With fi
.StructSize = LenB(fi)
.Type = 1
.hImage = hemf
End With
' フィルタ呼び出し
If GetFilterInfo(3, 0, hMem, &H10000) And &H10 Then
If ExportGr(ff, fi, hMem) = 0 Then
SaveCBPictureAs = True
End If
End If
If hMem Then GlobalFree hMem
DeleteEnhMetaFile hemf
End Function
Sub 動作テスト()
Dim AWorksheet As Worksheet
Dim wShape As Shape
Dim myW As Double, myH As Double, myRatio As Double
Dim oW As Double, oH As Double
Dim strPath As String
Dim lngCount As Long
Application.ScreenUpdating = False
Set AWorksheet = ActiveSheet
For Each wShape In AWorksheet.Shapes
If wShape.Type = msoPicture Then
With wShape
myW = .Width
myH = .Height
'図を元の大きさに変更
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
oH = .Height
oW = .Width
.Copy
'縮小後のサイズに戻す
.Width = myW
.Height = myH
End With
Application.ScreenUpdating = True
myRatio = WorksheetFunction.Round(myW / oW * 100, 0)
lngCount = lngCount + 1
' strPath = ThisWorkbook.Path & "\testABC_" & Format(lngCount, "000") & ".jpg"
strPath = "C:\tpic\testABC_" & Format(lngCount, "000") & ".jpg"
Call SaveCBPictureAs(strPath)
End If
Next
End Sub
|
|
かみちゃん
- 11/8/26(金) 6:16 -
