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
'<<==========
