Groups | Search | Server Info | Keyboard shortcuts | Login | Register [http] [https] [nntp] [nntps]

Groups > microsoft.public.scripting.vbscript > #12019

Re: Anyway to use a picture object as an image source in HTA?

Show all headers | View raw

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

Back to microsoft.public.scripting.vbscript | Previous | Next — Previous in thread | Find similar | Unroll thread

Thread

Anyway to use a picture object as an image source in HTA? JJ <jj4public@vfemail.net> - 2018-10-18 02:40 +0700
  Re: Anyway to use a picture object as an image source in HTA? "Mayayana" <mayayana@invalid.nospam> - 2018-10-17 17:37 -0400
    Re: Anyway to use a picture object as an image source in HTA? JJ <jj4public@vfemail.net> - 2018-10-19 00:18 +0700
  Re: Anyway to use a picture object as an image source in HTA? "Mayayana" <mayayana@invalid.nospam> - 2018-10-17 17:56 -0400
    Re: Anyway to use a picture object as an image source in HTA? JJ <jj4public@vfemail.net> - 2018-10-19 00:18 +0700
      Re: Anyway to use a picture object as an image source in HTA? "Mayayana" <mayayana@invalid.nospam> - 2018-10-18 14:21 -0400
  Re: Anyway to use a picture object as an image source in HTA? "Mayayana" <mayayana@invalid.nospam> - 2018-10-18 10:48 -0400
    Re: Anyway to use a picture object as an image source in HTA? JJ <jj4public@vfemail.net> - 2018-10-19 00:18 +0700
  Re: Anyway to use a picture object as an image source in HTA? "Mayayana" <mayayana@invalid.nospam> - 2018-10-19 10:25 -0400
    Re: Anyway to use a picture object as an image source in HTA? JJ <jj4public@vfemail.net> - 2018-10-20 07:19 +0700
  Re: Anyway to use a picture object as an image source in HTA? "Mayayana" <mayayana@invalid.nospam> - 2018-10-19 22:44 -0400

csiph-web