OK. Here's one that works and only needs basic API.
OleSavePictureFile just doesn't seem to like VB.
This is ridiculously complex, but I had this code already
written for an image editor.
This has to be a DLL. An AxEXE won't work.
------------------------------------------------
VBScript loads image:
Dim oPic, PS, picpath
Set oPic = LoadPicture("C:\Windows\Desktop\deer.jpg")
Set PS = CreateObject("PicSaverDLL.Saver")
picpath = "C:\Windows\Desktop\Up\deer.bmp"
PS.PicToFile oPic.Handle, picpath
Set PS = Nothing
Set oPic = Nothing
-------------------------------------------------
Total code for class module:
Public Sub PicToFile(oPicHandle As Variant, vPath As Variant)
Dim sPath As String
Dim LRet As Long
Dim Boo As Boolean
Dim PicHandle As Long
PicHandle = CLng(oPicHandle)
sPath = CStr(vPath)
LRet = CopyStdPicture(PicHandle)
If LRet = 0 Then
Boo = WriteBMP(sPath)
End If
End Sub
---------------------------------------
Total code for bas module that goes with cls
to make DLL:
Option Explicit
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER '40
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPFILEHEADER '14
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Private Type Bitmap
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type BITMAPINFO '24 bit
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal
hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X
As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long)
As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long)
As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal
hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits
As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long,
pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal Handle
As Long, ByVal dw As Long) As Long 'lplpVoid changed to ByRef
Private Declare Function GetLastError Lib "kernel32.dll" () As Long
Private CurPic As Long ' Handle to the current DIBSection
BITMAP
Private hBMPOld As Long ' Handle to the old bitmap in the DC, for
clear up
Private CurPicDC As Long ' Handle to the Device context
holding the DIBSection
Private CurPicBytes As Long ' Address of memory pointing to
the DIBSection's bits
Private BMPInfo As BITMAPINFO ' Type containing the Bitmap
information
Public Function CopyStdPicture(ByRef StdPicHandle As Long) As Long
Dim DC1 As Long
Dim LBMPOld As Long
Dim tBMP As Bitmap
Dim LRet As Long
On Error Resume Next
GetObjectAPI StdPicHandle, Len(tBMP), tBMP
LRet = CreateDIB(tBMP.bmWidth, tBMP.bmHeight)
If (LRet <> 0) Then
CopyStdPicture = LRet '-- returns 87 if win98 memory problem.
Exit Function
End If
DC1 = CreateCompatibleDC(0&)
If (DC1 = 0) Then
CopyStdPicture = 2
Exit Function
End If
LBMPOld = SelectObject(DC1, StdPicHandle)
BitBlt CurPicDC, 0, 0, BMPInfo.bmiHeader.biWidth,
BMPInfo.bmiHeader.biHeight, DC1, 0, 0, vbSrcCopy
SelectObject DC1, LBMPOld
DeleteObject DC1
CopyStdPicture = 0
End Function
Public Function WriteBMP(sPath As String) As Boolean
Dim hdc As Long, LRet As Long, LRet2 As Long, BytesPerScanLine As Long
Dim BBits() As Byte
Dim BFH As BITMAPFILEHEADER
Dim FF2 As Integer
On Error Resume Next
BytesPerScanLine = (BMPInfo.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
ReDim BBits(BMPInfo.bmiHeader.biHeight * BytesPerScanLine) As Byte
hdc = CreateCompatibleDC(0&)
LRet = GetDIBits(hdc, CurPic, 0, Abs(BMPInfo.bmiHeader.biHeight),
BBits(0), BMPInfo, 0)
LRet2 = DeleteDC(hdc)
If (LRet = 0) Then
WriteBMP = False
Exit Function
End If
With BFH '14
.bfType = &H4D42
.bfSize = BMPInfo.bmiHeader.biSizeImage
.bfOffBits = 54
End With
FF2 = FreeFile()
Open sPath For Binary As #FF2
Put #FF2, , BFH ' 14
Put #FF2, , BMPInfo.bmiHeader ' 40
Put #FF2, , BBits()
Close
WriteBMP = True
End Function
Public Function CreateDIB(LWidth As Long, LHeight As Long) As Long
Dim BytesPerScanLine As Long
On Error Resume Next
Clear 'Set Dimensions in this cImage
CurPicDC = CreateCompatibleDC(0&)
If CurPicDC = 0 Then
CreateDIB = 1 '--failed.
Exit Function
End If
BytesPerScanLine = (LWidth * 3 + 3) And &HFFFFFFFC
With BMPInfo.bmiHeader
.biSize = Len(BMPInfo.bmiHeader)
.biWidth = LWidth
.biHeight = LHeight
.biPlanes = 1
.biBitCount = 24
.biCompression = 0
.biSizeImage = BytesPerScanLine * .biHeight
End With
CurPic = CreateDIBSection(CurPicDC, BMPInfo, 0, CurPicBytes, 0, 0)
If CurPic = 0 Then
CurPic = GetLastError() '-- returns 87 with win98 memory limit.
If (CurPic = 0) Then CurPic = 1
CreateDIB = CurPic
DeleteObject CurPicDC '-- quit
Else
hBMPOld = SelectObject(CurPicDC, CurPic)
CreateDIB = 0
End If
End Function
Private Sub Clear()
On Error Resume Next
If (CurPicDC <> 0) Then
If (CurPic <> 0) Then
SelectObject CurPicDC, hBMPOld
DeleteObject CurPic
End If
DeleteObject CurPicDC
End If
CurPicDC = 0
CurPic = 0
hBMPOld = 0
CurPicBytes = 0
End Sub