Re: Saving a shape to a file

Tech-Archive recommends: Fix windows errors by optimizing your registry

From: Michel Pierron (michel.pierron_at_free.fr)
Date: 03/17/04 

Date: Wed, 17 Mar 2004 22:24:19 +0100

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" <anonymous@discussions.microsoft.com> a écrit dans le message de
news:18E2B7D9-9340-4841-B2D2-8AFF76533D9C@microsoft.com...
> Hello,
> I have a spread*** 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.
> Anyone have any ideas?
>
> TIA,
> Tgeorge

Quantcast