| |
どうもありがとうございます。
非常に難しそうですが、できそうです。
前回に引き続き、色々ありがとうございます。
お伺いしたことをベースに
今週末、なんとかチャレンジして克服してみます。
これからもどうぞよろしくお願いします。
▼かみちゃん さん：
>こんにちは。かみちゃん です。
>
>> 別面で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
|
|
takataka
- 11/8/26(金) 14:05 -
