Incompatibilidade de código

[thiro]

Tenho um código que salva um range de células como imagem .bmp.

Ele funcionava no office 2007 com windows xp; mas não funciona no office 2011 com win 7 64 bits.

Pedi para um amigo testar e ele concluiu que o problema não é sistema operacional, mas sim a versao do office.

Mesmo botando PtrSafe, não funciona...

Segue o código.

Testo com: SaveRangePic Range("B2:D30"), "C:\teste.bmp"

Option Explicit

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long

Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" _

(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _

IPic As IPicture) As Long

'\\ Declare a UDT to store a GUID for the IPicture OLE Interface

Private Type GUID

Data1 As Long

Data2 As Integer

Data3 As Integer

Data4(0 To 7) As Byte

End Type

'\\ Declare a UDT to store the bitmap information

Private Type uPicDesc

Size As Long

Type As Long

hPic As Long

hPal As Long

End Type

Private Const CF_BITMAP = 2

Private Const PICTYPE_BITMAP = 1

Sub SaveRangePic(SourceRange As Range, FilePathName As String)

Dim IID_IDispatch As GUID

Dim uPicinfo As uPicDesc

Dim IPic As IPicture

Dim hPtr As Long

'\\ Copy Range to ClipBoard

SourceRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

OpenClipboard 0

hPtr = GetClipboardData(CF_BITMAP)

CloseClipboard

'\\ Create the interface GUID for the picture

With IID_IDispatch

.Data1 = &H7BF80980

.Data2 = &HBF32

.Data3 = &H101A

.Data4(0) = &H8B

.Data4(1) = &HBB

.Data4(2) = &H0

.Data4(3) = &HAA

.Data4(4) = &H0

.Data4(5) = &H30

.Data4(6) = &HC

.Data4(7) = &HAB

End With

'\\ Fill uPicInfo with necessary parts.

With uPicinfo

.Size = Len(uPicinfo) '\\ Length of structure.

.Type = PICTYPE_BITMAP '\\ Type of Picture

.hPic = hPtr '\\ Handle to image.

.hPal = 0 '\\ Handle to palette (if bitmap).

End With

'\\ Create the Range Picture Object

OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic

'\\ Save Picture Object

stdole.SavePicture IPic, FilePathName

End Sub