Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Save picture using VBA
As it is possible to keep picture on a disk from Excel (2007) using code VBA,
picture are ordered on cells |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Save picture using VBA
Hi Alex.
In a standard module (see below), at the head of the module at before any other routine, paste the following code: '========== Option Explicit '--------------- Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(8) As Byte End Type Private Type PICTDESC cbSize As Long picType As Long hImage As Long End Type '--------------- Private Declare Function OpenClipboard& _ Lib "user32" _ (ByVal hwnd&) Private Declare Function EmptyClipboard& _ Lib "user32" () Private Declare Function GetClipboardData& _ Lib "user32" _ (ByVal wFormat%) Private Declare Function SetClipboardData& _ Lib "user32" _ (ByVal wFormat&, _ ByVal hMem&) Private Declare Function CloseClipboard& _ Lib "user32" () Private Declare Function CopyImage& _ Lib "user32" _ (ByVal handle&, _ ByVal un1&, _ ByVal n1&, _ ByVal n2&, _ ByVal un2&) Private Declare Function IIDFromString _ Lib "ole32" _ (ByVal lpsz As String, _ ByRef lpiid As GUID) _ As Long Private Declare Function OleCreatePictureIndirect _ Lib "olepro32" _ (pPictDesc As PICTDESC, _ ByRef riid As GUID, _ ByVal fOwn As Long, _ ByRef ppvObj As IPicture) _ As Long '--------------- Private Sub SavePicAsBitmap(sFile As String) Dim hCopy&: OpenClipboard 0& hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4) CloseClipboard If hCopy = 0 Then Exit Sub Const IPictureIID = _ "{7BF80981-BF32-101A-8BBB-00AA00300CAB}" Dim iPic As IPicture Dim tIID As GUID Dim tPICTDEST As PICTDESC Dim Ret As Long Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID) If Ret Then Exit Sub With tPICTDEST .cbSize = Len(tPICTDEST) .picType = 1 .hImage = hCopy End With Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic) SavePicture iPic, sFile Set iPic = Nothing End Sub '--------------- Public Sub Tester() Dim WB As Workbook Dim SH As Worksheet Dim sPath As String Dim sStr As String Dim oPic As Picture Dim sSep As String Const sFileName As String = _ "myPic.bmp" '<<==== CHANGE Const sPicName As String = _ "Picture 1" '<<==== CHANGE sPath = _ "C:\Users\Norman\Documents\" '<<==== CHANGE Set WB = 'Workbooks("myBook.xls")'<<==== CHANGE Set SH = WB.Sheets("Sheet1") '<<==== CHANGE Set oPic = SH.Pictures(sPicName) sSep = Application.PathSeparator If Right(sPath, 1) < sSep Then sPath = sPath & sSep End If sStr = sPath & sFileName oPic.Copy Call SavePicAsBitmap(sFile:=sStr) End Sub '<<========== --- Regards. Norman "Alex_1000" wrote in message ... As it is possible to keep picture on a disk from Excel (2007) using code VBA, picture are ordered on cells |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Can I save a worksheet as a picture? | Excel Discussion (Misc queries) | |||
Save Picture from excel. | Excel Discussion (Misc queries) | |||
insert a picture in to a comment but picture not save on hard disk | Excel Discussion (Misc queries) | |||
save picture in a worksheet programmatically | Excel Programming | |||
Save as a picture | Excel Discussion (Misc queries) |