Hi tgeorge;
If the format does not matter, why not bmp:
Option Explicit
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal
wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As
Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As
Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll"
(PicDesc As uPicDesc _
, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As
Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal
un1 As Long _
, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Function PasteBmp() As IPicture
Dim hCopy As Long
OpenClipboard 0&
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
CloseClipboard
If hCopy Then Set PasteBmp = CreateBmp(hCopy, 0, 2)
End Function
Private Function CreateBmp(ByVal hPic As Long, ByVal hPal As Long, ByVal
lPicType) As IPicture
Dim i As Long, PicInfo As uPicDesc, OlePicStore As GUID, IPic As IPicture
' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
With OlePicStore
.Data1 = &H7BF80980: .Data2 = &HBF32: .Data3 = &H101A
For i = 1 To 8
.Data4(i - 1) = Choose(i, &H8B, &HBB, &H0, &HAA, &H0, &H30, &HC, &HAB)
Next i
End With
With PicInfo
.Size = Len(PicInfo)
.Type = 1
.hPic = hPic
.hPal = hPal
End With
If OleCreatePictureIndirect(PicInfo, OlePicStore, True, IPic) Then Exit
Function
Set CreateBmp = IPic
End Function
Sub SaveShapeAsBmp()
If ThisWorkbook.Sheets(1).Shapes.Count = 0 Then Exit Sub
On Error GoTo SaveBmp_Error
Dim Img As Shape, oPic As IPictureDisp, BmpFile As String
For Each Img In ThisWorkbook.Sheets(1).Shapes
Img.CopyPicture xlScreen, xlBitmap
BmpFile = ThisWorkbook.Path & "\" & Img.Name & ".bmp"
Set oPic = PasteBmp: SavePicture oPic, BmpFile
Next Img
Exit Sub
SaveBmp_Error:
MsgBox "Error " & Err.Number & vbLf & Err.Description, 48
End Sub
MP
tgeorge said:
Hello,
I have a spreadsheet that contains several hundred shapes (images). I am
looking for a way to use vba to save each shape off to its own file (format
does not matter, either .gif of .jpg). I can manage all the code necessary
to select the images and loop through each one. the only thing I need to do
is actually save them off to the file.
