We help IT Professionals succeed at work.

get BMP from class

Last Modified: 2013-11-19
How can i get a BMP from Class?

need to write a class in VB that return a BMP/Image to C++ application.
Watch Question

Top Expert 2005

What do you mean?


Edited text of question.

Man your wacked

Right.... a tall order, but not impossible. Here's an extract from a question I answered before. The function you're looking for is the CreateBitmapPicture function (which I initially got from waty - thanks!).

There also is some neat stuff in there to allow you scribble text over a picture and so on. Like I said in the previous question, this is not a complete answer, but hopefully it will allow you to achieve what you want.

Hope this helps!



What I will post here is a "graphics" module that I used in a viewer for our own COLD documents.

For reasons of copyright I will not be able to post all the code. You won't be able to use the code as it is.

But hopefully it will allow you to work out a way of displaying text on a background image, after which you can adapt this to suit your own COLD documents.

Hope this helps.

Code in next comment

From: caraf_g
 Date: Wednesday, January 26 2000 - 08:27AM GMT    
Option Explicit

Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104

Private Const DRIVERVERSION = 0
Private Const TECHNOLOGY = 2
Private Const HORZSIZE = 4
Private Const VERTSIZE = 6
Private Const HORZRES = 8
Private Const VERTRES = 10
Private Const BITSPIXEL = 12
Private Const PLANES = 14
Private Const NUMBRUSHES = 16
Private Const NUMPENS = 18
Private Const NUMMARKERS = 20
Private Const NUMFONTS = 22
Private Const NUMCOLORS = 24
Private Const PDEVICESIZE = 26
Private Const CURVECAPS = 28
Private Const LINECAPS = 30
Private Const POLYGONALCAPS = 32
Private Const TEXTCAPS = 34
Private Const CLIPCAPS = 36
Private Const ASPECTX = 40
Private Const ASPECTY = 42
Private Const ASPECTXY = 44
Public Const LOGPIXELSX = 88
Public Const LOGPIXELSY = 90
Private Const NUMRESERVED = 106
Private Const COLORRES = 108
Private Const DT_PLOTTER = 0
Private Const DT_RASDISPLAY = 1
Private Const DT_RASPRINTER = 2
Private Const DT_RASCAMERA = 3
Private Const DT_CHARSTREAM = 4
Private Const DT_METAFILE = 5
Private Const DT_DISPFILE = 6
Private Const CP_NONE = 0
Private Const CP_RECTANGLE = 1
Private Const RC_BITBLT = 1
Private Const RC_BANDING = 2
Private Const RC_SCALING = 4
Private Const RC_BITMAP64 = 8
Private Const RC_GDI20_OUTPUT = &H10
Private Const RC_DI_BITMAP = &H80
Private Const RC_DIBTODEV = &H200
Private Const RC_BIGFONT = &H400
Private Const RC_STRETCHBLT = &H800
Private Const RC_FLOODFILL = &H1000
Private Const RC_STRETCHDIB = &H2000

Private lngOverrideDPI As Long

        tmHeight As Long
        tmAscent As Long
        tmDescent As Long
        tmInternalLeading As Long
        tmExternalLeading As Long
        tmAveCharWidth As Long
        tmMaxCharWidth As Long
        tmWeight As Long
        tmOverhang As Long
        tmDigitizedAspectX As Long
        tmDigitizedAspectY As Long
        tmFirstChar As Byte
        tmLastChar As Byte
        tmDefaultChar As Byte
        tmBreakChar As Byte
        tmItalic As Byte
        tmUnderlined As Byte
        tmStruckOut As Byte
        tmPitchAndFamily As Byte
        tmCharSet As Byte
End Type

Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long

        mtType As Integer
        mtHeaderSize As Integer
        mtVersion As Integer
        mtSize As Long
        mtNoObjects As Integer
        mtMaxRecord As Long
        mtNoParameters As Integer
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type SMALL_RECT
        Left As Integer
        Top As Integer
        Right As Integer
        Bottom As Integer
End Type
Private Type APMHeader
    dwkey As Long '4
    hMF As Integer '+2 = 6
    bbox As SMALL_RECT '+8=14
    wInch As Integer ' +2 = 16
    dwReserved As Long ' +4 = 20
    wCheckSum As Integer ' +2 = 22
End Type

Private Const MM_TEXT = 1
Private Const MM_MIN = MM_TEXT
Private Const MM_LOMETRIC = 2
Private Const MM_HIMETRIC = 3
Private Const MM_LOENGLISH = 4
Private Const MM_HIENGLISH = 5
Private Const MM_TWIPS = 6
Private Const MM_ISOTROPIC = 7
Private Const MM_ANISOTROPIC = 8
        mm As Long
        xExt As Long
        yExt As Long
        hMF As Long
End Type

Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY  ' Enough for 256 colors.
End Type

Private Declare Function GetDesktopWindow Lib "USER32" () As Long
Private Declare Function DeleteDC Lib "gdi32" ( _
    ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "USER32" ( _
    ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "USER32" ( _
    ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
    ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" ( _
    ByVal hdc As Long, ByVal nWidth As Long, _
    ByVal nHeight As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" ( _
    ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" ( _
    ByVal hdc As Long, ByVal wStartIndex As Long, _
    ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) _
    As Long
Private Declare Function CreatePalette Lib "gdi32" ( _
    lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "gdi32" ( _
    ByVal hdc As Long, ByVal hPalette As Long, _
    ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette 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 SetMapMode Lib "gdi32" (ByVal hdc As Long, ByVal nMapMode As Long) As Long

'dwRop constants for BitBlt
Private Const BLACKNESS = &H42 ' (DWORD) dest = BLACK
Private Const DSTINVERT = &H550009       ' (DWORD) dest = (NOT dest)
Private Const MERGECOPY = &HC000CA       ' (DWORD) dest = (source AND pattern)
Private Const MERGEPAINT = &HBB0226      ' (DWORD) dest = (NOT source) OR dest
Private Const NOTSRCCOPY = &H330008      ' (DWORD) dest = (NOT source)
Private Const NOTSRCERASE = &H1100A6     ' (DWORD) dest = (NOT src) AND (NOT dest)
Private Const PATCOPY = &HF00021 ' (DWORD) dest = pattern
Private Const PATINVERT = &H5A0049       ' (DWORD) dest = pattern XOR dest
Private Const PATPAINT = &HFB0A09        ' (DWORD) dest = DPSnoo
Private Const SRCAND = &H8800C6  ' (DWORD) dest = source AND dest
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Const SRCERASE = &H440328        ' (DWORD) dest = source AND (NOT dest )
Private Const SRCINVERT = &H660046       ' (DWORD) dest = source XOR dest
Private Const SRCPAINT = &HEE0086        ' (DWORD) dest = source OR dest
Private Const WHITENESS = &HFF0062       ' (DWORD) dest = WHITE
Private Declare Function BitBlt Lib "gdi32" ( _
    ByVal hDCDest As Long, ByVal XDest As Long, _
    ByVal YDest As Long, ByVal nWidth As Long, _
    ByVal nHeight As Long, ByVal hDCSrc As Long, _
    ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) _
    As Long
Private Const TRANSPARENT = 1
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long

Private Declare Function GetMetaFile Lib "gdi32" Alias "GetMetaFileA" (ByVal lpFileName As String) As Long
Private Declare Function GetEnhMetaFile Lib "gdi32" Alias "GetEnhMetaFileA" (ByVal lpszMetaFile As String) As Long
Private Declare Function PlayEnhMetaFile Lib "gdi32" (ByVal hdc As Long, ByVal hemf As Long, lpRect As RECT) As Long
Private Declare Function PlayMetaFile Lib "gdi32" (ByVal hdc As Long, ByVal hMF As Long) As Long
Private Declare Function SetMetaFileBitsEx Lib "gdi32" (ByVal nSize As Long, lpData As Byte) As Long
Private Declare Function SetWinMetaFileBits Lib "gdi32" (ByVal cbBuffer As Long, lpbBuffer As Byte, ByVal hdcRef As Long, lpmfp As METAFILEPICT) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hemf As Long) As Long
Private Declare Function DeleteMetaFile Lib "gdi32" (ByVal hMF As Long) As Long
'This function can be used to save an ordinary metafile as an enhanced one!
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long

Private Declare Function OleCreatePictureIndirect _
    Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long

Private Const FW_DONTCARE = 0
Private Const FW_THIN = 100
Private Const FW_EXTRALIGHT = 200
Private Const FW_ULTRALIGHT = 200
Private Const FW_LIGHT = 300
Private Const FW_NORMAL = 400
Private Const FW_REGULAR = 400
Private Const FW_MEDIUM = 500
Private Const FW_SEMIBOLD = 600
Private Const FW_DEMIBOLD = 600
Private Const FW_BOLD = 700
Private Const FW_EXTRABOLD = 800
Private Const FW_ULTRABOLD = 800
Private Const FW_HEAVY = 900
Private Const FW_BLACK = 900

'Font enumeration types
Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64

Private Type LogFont
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(1 To LF_FACESIZE) As Byte
End Type

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LogFont) As Long

Private Const PROOF_QUALITY = 2
Private Const OUT_DEFAULT_PRECIS = 0
Private Const ANSI_CHARSET = 0
Private Const FIXED_PITCH = 1
Private Const FF_MODERN = 48     '  Constant stroke width, serifed or sans-serifed.

   tmHeight As Long
   tmAscent As Long
   tmDescent As Long
   tmInternalLeading As Long
   tmExternalLeading As Long
   tmAveCharWidth As Long
   tmMaxCharWidth As Long
   tmWeight As Long
   tmOverhang As Long
   tmDigitizedAspectX As Long
   tmDigitizedAspectY As Long
   tmFirstChar As Byte
   tmLastChar As Byte
   tmDefaultChar As Byte
   tmBreakChar As Byte
   tmItalic As Byte
   tmUnderlined As Byte
   tmStruckOut As Byte
   tmPitchAndFamily As Byte
   tmCharSet As Byte
   ntmFlags As Long
   ntmSizeEM As Long
   ntmCellHeight As Long
   ntmAveWidth As Long
End Type

'ntmFlags field flags
Private Const NTM_REGULAR = &H40&
Private Const NTM_BOLD = &H20&
Private Const NTM_ITALIC = &H1&

'tmPitchAndFamily flags
Private Const TMPF_FIXED_PITCH = &H1
Private Const TMPF_VECTOR = &H2
Private Const TMPF_DEVICE = &H8
Private Const TMPF_TRUETYPE = &H4

Private Const ELF_VERSION = 0
Private Const ELF_CULTURE_LATIN = 0

'EnumFonts Masks
Private Const RASTER_FONTTYPE = &H1
Private Const DEVICE_FONTTYPE = &H2

Public Declare Function EnumFontFamilies Lib _
  "gdi32" Alias "EnumFontFamiliesA" _
  (ByVal hdc As Long, ByVal lpszFamily As String, _
   ByVal lpEnumFontFamProc As Long, LParam As Any) As Long

Public aryFonts() As LogFont

Private Function GetPlaceableMetafile(ByVal Filename As String) As Long

Dim hFile As Long
Dim mtSize As Long
Dim Buffer() As Byte
Dim hMF As Long
Dim APMH As APMHeader
Dim hDCDesktop As Long
Dim hWndDesktop As Long

' Best prepare for file access errors.
On Error GoTo FileErr

' Open the file for binary access
hFile = FreeFile
Open Filename For Binary Access Read As #hFile

'Grab APMHeader
Get #hFile, 1, APMH

' Scan past APMFILEHEADER (22 bytes), and
Get #hFile, 23, Hdr

' The size field contains number of WORDs in metafile,
' we need to double for number of bytes.
Hdr.mtSize = Hdr.mtSize * 2

' Grab actual metafile data. Need to back up to
' beginning of header.
ReDim Buffer(1 To Hdr.mtSize) As Byte
Get #hFile, 23, Buffer

' Done with file now.
Close hFile

' Create new memory-based metafile and return.
' Using SetWinMetaFileBits this time.
MFP.xExt = APMH.bbox.Right - APMH.bbox.Left
MFP.xExt = MFP.xExt * 2540
MFP.xExt = MFP.xExt / APMH.wInch
MFP.yExt = APMH.bbox.Bottom - APMH.bbox.Top
MFP.yExt = MFP.yExt * 2540
MFP.yExt = MFP.yExt / APMH.wInch
MFP.hMF = 0

hWndDesktop = GetDesktopWindow
hDCDesktop = GetDC(hWndDesktop)

Dim lngMF As Long
lngMF = SetWinMetaFileBits(UBound(Buffer), Buffer(1), hDCDesktop, MFP)
GetPlaceableMetafile = lngMF

ReleaseDC hWndDesktop, hDCDesktop

Exit Function

GetPlaceableMetafile = 0

End Function

' CreateBitmapPicture
'    - Creates a bitmap type Picture object from a bitmap and
'      palette.
' hBmp
'    - Handle to a bitmap.
' hPal
'    - Handle to a Palette.
'    - Can be null if the bitmap doesn't use a palette.
' Returns
'    - Returns a Picture object containing the bitmap.
Private Function CreateBitmapPicture(ByVal hBmp As Long, _
                                    ByVal hPal As Long) As Picture

Dim r As Long
Dim Pic As PicBmp
' IPicture requires a reference to "Standard OLE Types."
Dim IPic As IPicture
Dim IID_IDispatch As GUID

' Fill in with IDispatch Interface ID.
With IID_IDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
End With

' Fill Pic with necessary parts.
With Pic
    .Size = Len(Pic)          ' Length of structure.
    .Type = vbPicTypeBitmap   ' Type of Picture (bitmap).
    .hBmp = hBmp              ' Handle to bitmap.
    .hPal = hPal              ' Handle to palette (may be null).
End With

' Create Picture object.
r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

' Return the new Picture object.
Set CreateBitmapPicture = IPic

End Function

' CreateWMFPicture
'    - Captures a wmf, emf or placeable wmf, and allows text to be
'       scribbled over the contents, before rendering the result
'       as a Picture object
' Returns
'    - Returns a Picture object containing a bitmap of the specified
'      portion of the window that was captured.
Public Function CreateWMFPicture(ByVal strMetaFile As String, _
                                 ByVal lngLeft As Long, _
                                 ByVal lngTop As Long, _
                                 ByVal lngWidth As Long, _
                                 ByVal lngHeight As Long, _
                                       colTXT As Collection, _
                                 ByVal lngDPI As Long, _
                                       objFCH As clsFCH) As Picture

'See LoadFCHTXT for more explanation
'Variables passed between PrepareTextAndPicture and CombineTextAnd Picture
Dim hDCPicture As Long
Dim hBmpOldPicture As Long
Dim hDCSrc As Long
Dim hPalOldPicture As Long
Dim HasPaletteScrn As Long
Dim PaletteSizeScrn As Long
Dim hMF As Long
Dim hDCText As Long
Dim hBmpOldText As Long
Dim hPalOldText As Long
Dim blnEnhanced As Boolean

hMF = GetMetaFile(strMetaFile)
If hMF = 0 Then
    blnEnhanced = True
    hMF = GetEnhMetaFile(strMetaFile)
    If hMF = 0 Then
        hMF = GetPlaceableMetafile(strMetaFile)
    End If
End If

PrepareTextAndPicture hDCPicture, _
                      hDCText, _
                      hBmpOldPicture, _
                      hBmpOldText, _
                      HasPaletteScrn, _
                      PaletteSizeScrn, _
                      hPalOldPicture, _
                      hPalOldText, _
                      hMF, _
                      lngLeft, _
                      lngTop, _
                      lngWidth, _

SetMapMode hDCText, MM_TEXT

Dim dblWMFLeft As Double
Dim dblWMFTop As Double
dblWMFLeft = lngLeft
dblWMFTop = lngTop
   LoadFCHTXT 0, _
              0, _
              colTXT, _
              lngDPI, _
              hDCText, _
              hDCPicture, _
              objFCH, _
              0, _

Set CreateWMFPicture = CombineTextAndPicture(hDCPicture, _
                                             hDCText, _
                                             hBmpOldPicture, _
                                             hBmpOldText, _
                                             HasPaletteScrn, _
                                             PaletteSizeScrn, _
                                             hPalOldPicture, _
                                             hPalOldText, _
                                             lngLeft, _
                                             lngTop, _
                                             lngWidth, _
If blnEnhanced Then
    DeleteEnhMetaFile hMF
    DeleteMetaFile hMF
End If

End Function
Private Sub PrepareTextAndPicture(hDCPicture As Long, _
                                 hDCText As Long, _
                                 hBmpOldPicture As Long, _
                                 hBmpOldText As Long, _
                                 HasPaletteScrn As Long, _
                                 PaletteSizeScrn As Long, _
                                 hPalOldPicture As Long, _
                                 hPalOldText As Long, _
                                 hMF As Long, _
                                 ByVal lngLeft As Long, _
                                 ByVal lngTop As Long, _
                                 ByVal lngWidth As Long, _
                                 ByVal lngHeight As Long)

Dim hBmp As Long
Dim hBmpText As Long
Dim RasterCapsScrn As Long
Dim lngReturnCode As Long
Dim hPal As Long
Dim hPalText As Long
Dim hWndDesktop As Long
Dim hDCDesktop As Long

'Get device context for client area.
hWndDesktop = GetDesktopWindow
hDCDesktop = GetDC(hWndDesktop)

'Create a memory device context for the image.
hDCPicture = CreateCompatibleDC(hDCDesktop)
' Create a bitmap and place it in the memory DC.
hBmp = CreateCompatibleBitmap(hDCDesktop, lngLeft + lngWidth, lngTop + lngHeight)

'I don't know why this is done...
hBmpOldPicture = SelectObject(hDCPicture, hBmp)

' Get screen properties.
RasterCapsScrn = GetDeviceCaps(hDCDesktop, RASTERCAPS) ' Raster
                                                   ' capabilities.
HasPaletteScrn = RasterCapsScrn And RC_PALETTE       ' Palette
                                                     ' support.
PaletteSizeScrn = GetDeviceCaps(hDCDesktop, SIZEPALETTE) ' Size of
                                                     ' palette.

' If the screen has a palette make a copy and realize it.
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
    ' Create a copy of the system palette.
    LogPal.palVersion = &H300
    LogPal.palNumEntries = 256
    lngReturnCode = GetSystemPaletteEntries(hDCDesktop, _
                                            0, _
                                            256, _
    hPal = CreatePalette(LogPal)
    ' Select the new palette into the memory DC and realize it.
    hPalOldPicture = SelectPalette(hDCPicture, hPal, 0)
    lngReturnCode = RealizePalette(hDCPicture)
End If

'Blank out the background before playing the metafile to avoid noise.
lngReturnCode = BitBlt(hDCPicture, _
                       0, _
                       0, _
                       lngLeft + lngWidth, _
                       lngLeft + lngHeight, _
                       hDCPicture, _
                       0, _
                       0, _

Dim udtX As RECT
udtX.Left = lngLeft
udtX.Top = lngTop
udtX.Bottom = lngTop + lngHeight
udtX.Right = lngLeft + lngWidth
PlayEnhMetaFile hDCPicture, hMF, udtX

'Create a memory device context for the text.
hDCText = CreateCompatibleDC(hDCDesktop)
hBmpText = CreateCompatibleBitmap(hDCText, lngLeft + lngWidth, lngTop + lngHeight)
hBmpOldText = SelectObject(hDCText, hBmpText)
'If the screen has a palette make a copy and realize it.
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
    hPalText = CreatePalette(LogPal)
    hPalOldText = SelectPalette(hDCText, hPalText, 0)
    lngReturnCode = RealizePalette(hDCText)
End If

ReleaseDC GetDesktopWindow, hDCDesktop

'Blank out the background for the text
lngReturnCode = BitBlt(hDCText, _
                       0, _
                       0, _
                       lngLeft + lngWidth, _
                       lngTop + lngHeight, _
                       hDCText, _
                       0, _
                       0, _

End Sub
Private Function CombineTextAndPicture(hDCPicture As Long, _
                                       hDCText As Long, _
                                       hBmpOldPicture As Long, _
                                       hBmpOldText As Long, _
                                       HasPaletteScrn As Long, _
                                       PaletteSizeScrn As Long, _
                                       hPalOldPicture As Long, _
                                       hPalOldText As Long, _
                                       ByVal lngLeft As Long, _
                                       ByVal lngTop As Long, _
                                       ByVal lngWidth As Long, _
                                       ByVal lngHeight As Long) As Picture

Dim lngReturnCode As Long
Dim hBMPPicture As Long
Dim hBmpText As Long
Dim hPal As Long
Dim hPalText As Long

' Copy the text over the wmf image into the memory DC.
lngReturnCode = BitBlt(hDCPicture, _
                       0, _
                       0, _
                       lngLeft + lngWidth, _
                       lngTop + lngHeight, _
                       hDCText, _
                       0, _
                       0, _

' Remove the new copies of the  on-screen image. <-why is this done?
hBMPPicture = SelectObject(hDCPicture, hBmpOldPicture)
hBmpText = SelectObject(hDCText, hBmpOldText)

' If the screen has a palette get back the palette that was
' selected in previously.
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
    hPal = SelectPalette(hDCPicture, hPalOldPicture, 0)
    hPalText = SelectPalette(hDCText, hPalOldText, 0)
End If

' Release the device context resources back to the system.
lngReturnCode = DeleteDC(hDCText)
lngReturnCode = DeleteDC(hDCPicture)

' Call CreateBitmapPicture to create a picture object from the
' bitmap and palette handles. Then return the resulting picture
' object.
Set CombineTextAndPicture = CreateBitmapPicture(hBMPPicture, hPal)
DeleteObject hBmpText

End Function
Public Sub LoadFCHTXT(ByVal dblXOffset As Double, _
                      ByVal dblYOffset As Double, _
                      colTXT As Collection, _
                      ByVal lngDPI As Long, _
                      hdc As Long, _
                      ByVal hDCPicture As Long, _
                      objFCH As clsFCH, _
                      dblWMFLeft As Double, _
                      dblWMFTop As Double)

'colTXT contains all the text you wish to display for the COLD document

'The objFCH object contains formatting information about the text. _
 Alas, this is copyrighted material so I had to comment it out. Suffice to say that the information in _
 the object would enable you to determine positioning, font, and size for the text in the colTXT collection.
Dim lngCount As Long
Dim strText As String
Dim strSection As String

Dim lngXCounter As Long
Dim lngTextLength As Long

Dim objLineInfo As clsLineInfo

Dim udtTextMetrics As TEXTMETRIC

'New variables
Dim lngFCHCount As Long
Dim objValue As clsValue
Dim dblCurrentLineSpacing As Double
Dim dblCurrentMargin As Double
Dim dblCurrentYPos As Double
Dim dblCurrentXPos As Double
Dim strCurrentFaceName As String
Dim lngCurrentSize As Long
Dim blnCurrentBold As Boolean
Dim blnCurrentUnderline As Boolean
Dim blnCurrentItalic As Boolean
Dim dblCurrentCharSpacing As Double

'The following are necessary to "tweak" the problems with the DHL file
'If a line does not set an absolute line spacing value, but one was
'specified in the Script section, the one from the Script section is used
'instead of the font metrics.
Dim blnYPosSet As Boolean
Dim blnAbsLineSpcSet As Boolean
Dim lngYPosSet As Long
Dim lngAbsLineSpcSet As Long
Dim lngLFCount As Long
Dim blnScriptAbsLineSpcSet As Boolean
Dim lngScriptAbsLineSpcSet As Long

If colTXT Is Nothing Then
    Exit Sub
End If

'Commented out code.
'But this is the sort of stuff you'd expect to happen here. Set the font information for the
'start of the document.
    strCurrentFaceName = "Courier New"
    lngCurrentSize = 12
    blnCurrentBold = False
    blnCurrentUnderline = False
    blnCurrentItalic = False
    GoSub FontHandling
    GoSub ProcessValues
    If blnAbsLineSpcSet Then
        blnScriptAbsLineSpcSet = True
        lngScriptAbsLineSpcSet = lngAbsLineSpcSet
    End If
    'There is no justification for this line, but without it the DHL file will
    'not display correctly
    If blnYPosSet Then
        objLineInfo.lngYPosSuggestion = dblCurrentYPos '- udtTextMetrics.tmAscent
    '    dblCurrentYPos = dblCurrentYPos - udtTextMetrics.tmAscent
    End If
    objLineInfo.lngAbsLineSpacingSuggestion = 0

For lngCount = 1 To colTXT.Count
    strText = colTXT(lngCount)
    'copyright. Some of the line might contain privileged information. In your case, let's assume it doesn't
    lngTextLength = Len(strText)
        'Copyright... Somehow you must use the privileged information in the line to obtain line information
        'from the formatting object, for example, let's say it does this by passing in the text to
        'a procedure in the FCH class.
        Set objLineInfo = objFCH.GetThePrivilegedInformationFrom(strText)
        GoSub ProcessValues
        'Anyway, this is the important bit: output the text to the text device context:
        lngXCounter = 1
        Do While lngXCounter <= lngTextLength
            TextOut hdc, _
                    (((dblCurrentXPos - dblWMFLeft) * lngDPI) / 300) _
                                    + dblXOffset, _
                    (((dblCurrentYPos - dblWMFTop - udtTextMetrics.tmAscent) * lngDPI) / 300) _
                                    + dblYOffset, _
                    Mid(strText, lngXCounter, 1), 1
            lngXCounter = lngXCounter + 1
            dblCurrentXPos = dblCurrentXPos + dblCurrentCharSpacing
    End Select

Exit Sub

'Copyright, sorry...
'Suffice to say: process all settings for the current line of text, such as font, spacing, etc.
'for each setting found:
    'GoSub ProcessValue

    'Copyright, sorry
    'Determine things such as Line Spacing, Vertical and Horizontal position.
        blnAbsLineSpcSet = True
        lngAbsLineSpcSet = CLng(somevalue)
        dblCurrentCharSpacing = CDbl(somevalue)
        dblCurrentXPos = CDbl(somevalue)
        blnYPosSet = True
        dblCurrentYPos = CDbl(somevalue)
        dblCurrentMargin = CDbl(somevalue)
        lngCurrentSize = CLng(somevalue)
        GoSub FontHandling
        blnCurrentBold = (either.True Or False)
        GoSub FontHandling
        'GoSub FontHandling
        'GoSub FontHandling
        'strCurrentFaceName = "For example: Courier New"
        'GoSub FontHandling
    'End Select

SetPictureFont strCurrentFaceName, _
lngCurrentSize, _
blnCurrentBold, _
blnCurrentUnderline, _
blnCurrentItalic, _
udtTextMetrics, _
hdc, _
dblCurrentLineSpacing = (udtTextMetrics.tmHeight + udtTextMetrics.tmExternalLeading) * lngDPI / 300
dblCurrentCharSpacing = udtTextMetrics.tmAveCharWidth

End Sub

Private Sub SetPictureFont(strFaceName As String, _
                           lngSize As Long, _
                           blnBold As Boolean, _
                           blnUnderline As Boolean, _
                           blnItalic As Boolean, _
                           udtTextMetrics As TEXTMETRIC, _
                           hdc As Long, _
                           ByVal lngDPI As Long)

Static lngOldFont As Long
Static lngCurrentFont As Long
Dim dblDisplaySize As Double

If lngCurrentFont Then
    SelectObject hdc, lngOldFont
    DeleteObject lngCurrentFont
End If

dblDisplaySize = (lngSize * lngDPI) / GetDeviceCaps(hdc, LOGPIXELSY)

Dim udtFont As LogFont
udtFont = GetLogFont(strFaceName)
udtFont.lfHeight = -1 * ((96 * (dblDisplaySize * 300 / lngDPI)) / 72)
udtFont.lfWidth = 0
If blnBold Then
    udtFont.lfWeight = FW_BOLD
    udtFont.lfWeight = FW_NORMAL
End If
udtFont.lfItalic = blnItalic
udtFont.lfUnderline = blnUnderline

lngCurrentFont = CreateFontIndirect(udtFont)
lngOldFont = SelectObject(hdc, lngCurrentFont)

GetTextMetrics hdc, udtTextMetrics

udtFont.lfHeight = -1 * ((96 * dblDisplaySize) / 72)
udtFont.lfWidth = 0
SelectObject hdc, lngOldFont
DeleteObject lngCurrentFont

lngCurrentFont = CreateFontIndirect(udtFont)
lngOldFont = SelectObject(hdc, lngCurrentFont)

End Sub

Public Function EnumFontFamProc2(lpNLF As LogFont, _
                                 lpNTM As NEWTEXTMETRIC, _
                                 ByVal FontType As Long, _
                                 objColl As Collection) As Long

    On Error Resume Next
    ReDim Preserve aryFonts(UBound(aryFonts) + 1)
    If Err.Number <> 0 Then
        ReDim aryFonts(0)
    End If
    On Error GoTo 0
    aryFonts(UBound(aryFonts)) = lpNLF
    'return success to the call
    EnumFontFamProc2 = 1

End Function
'--end block--
Private Function GetLogFont(strAnsiFont As String) As LogFont

Dim lngCount As Long
Dim strWork As String

If strAnsiFont = "" Then
    strAnsiFont = "Courier New"
End If

For lngCount = 0 To UBound(aryFonts)
    strWork = StrConv(aryFonts(lngCount).lfFaceName, vbUnicode)
    If InStr(strWork, strAnsiFont) = 1 Then
        GetLogFont = aryFonts(lngCount)
        Exit Function
    End If

End Function

Accepted Answer  
From: caraf_g
 Date: Wednesday, January 26 2000 - 08:49AM GMT    
Some further explanation. I'm assuming your COLD documents consist of three parts.

1 - a text file containing the text to be displayed and formatting codes. E.g. a spool file.

This text file is read in line by line and placed in the colTXT collection. Each line would contain formatting information and text to be displayed. The formatting information is very specific to the COLD product you're using so I've assumed nothing.

2 - a format control file. This file will describe how to interpret the formatting information in the text file. I've defined a class (which I can't include for reasons of copyright) that reads in this file and sets up an object (objFCH in the code) that will be used to interpret the lines of text.

3 - a background image. If I remember correctly, the code above allows you to use metafiles.

After you've read in colTXT and set up objFCH you can call CreateWMFPicture which will return an object of type Picture. You can use this very easily in, e.g. a picture box:

Set YourPictureBox.Picture = CreateWMFPicture(etc..)

Good luck


Why not simply return stdPicture.Handle?

"Why not simply return stdPicture.Handle? "

That requires that you have a stdPicture in the first place. What danyb wants to do, I guess, is exactly the reverse: given the handle to a bitmap or device context or something, create a stdPicture that you can return to a calling app. My code sample gives an idea on how to achieve this.

danyb, don't hesitate to ask if you need more information. Otherwise I would appreciate it if you would grade this question.

caraf_g: IMHO, danyb meens passing handle of picture to c++ program. Your code (BTW, exelent code) is much more easy to realize in c++. I guess, dayb want to use easy VB interface to load or manipulate with picture and then pass it's handle to c++ programm. Anyway. this is just a comment and danyb have to define his question - what he need - picture or handle.


all I need is handle.
This one is on us!
(Get your first solution completely free - no credit card required)

For anyone who wants to create a StdPicture object from an bitmap handle....

Public Declare Function oleCreatePictureIndirect Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long

Public Type PictDesc
  cbSizeofStruct As Long
  picType As Long
  hImage As Long
  xExt As Long
  yExt As Long
End Type

Public Type Guid
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

Public Function BitmapToPicture(ByVal hBmp As Long) As IPicture
  If (hBmp = 0) Then Exit Function
  Dim oNewPic As Picture, tPicConv As PictDesc, IGuid As Guid
  'Fill PictDesc structure with necessary parts:
  With tPicConv
    .cbSizeofStruct = Len(tPicConv)
    .picType = vbPicTypeBitmap
    .hImage = hBmp
  End With
  'Fill in IDispatch Interface ID
  With IGuid
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
  End With
  'Create a picture object:
  oleCreatePictureIndirect tPicConv, IGuid, True, oNewPic
  'Return it:
  Set BitmapToPicture = oNewPic
End Function

Gain unlimited access to on-demand training courses with an Experts Exchange subscription.

Get Access
Why Experts Exchange?

Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.

Jim Murphy
Programmer at Smart IT Solutions

When asked, what has been your best career decision?

Deciding to stick with EE.

Mohamed Asif
Technical Department Head

Being involved with EE helped me to grow personally and professionally.

Carl Webster
CTP, Sr Infrastructure Consultant
Empower Your Career
Did You Know?

We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE

Ask ANY Question

Connect with Certified Experts to gain insight and support on specific technology challenges including:

  • Troubleshooting
  • Research
  • Professional Opinions
Unlock the solution to this question.
Join our community and discover your potential

Experts Exchange is the only place where you can interact directly with leading experts in the technology field. Become a member today and access the collective knowledge of thousands of technology experts.

*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.


Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.