Merge Picture

Posted on 2000-03-15
Last Modified: 2008-02-01
I have 3 picturebox ... I want merge 2 picture in on... I want put picture1 first after picture2 in picture3, how can I do that easly?

and how can I write text in picture?
Question by:Yard072999
  • 3
  • 2
LVL 10

Expert Comment

ID: 2619004
Can you please rephrase this question? I don't understand what you're asking.
LVL 10

Expert Comment

ID: 2619028
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


Author Comment

ID: 2619121
Hmm Okay that is for put text on picture.. hmm forget that

What I want do with Picture is...

(This is a example)

I have 3 picturebox

in First one I have a Horse in second a cow
I want in Picture3 Horse and cow... so Horse on top and under the cow... in the same picture...
Master Your Team's Linux and Cloud Stack!

The average business loses $13.5M per year to ineffective training (per 1,000 employees). Keep ahead of the competition and combine in-person quality with online cost and flexibility by training with Linux Academy.

LVL 27

Accepted Solution

Ark earned 200 total points
ID: 2619179
If you have w98/2000, you can use this

Private Declare Function TransparentBlt Lib "msimg32.dll" (ByVal hdcDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hdcSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal crTransparent As Long) As Long

Private Sub Command1_Click()
  Dim clr As Long, w As Long, h As Long
  Picture3.Picture = Picture1.Image
  Picture3.ScaleMode = vbPixels
  Picture2.ScaleMode = vbPixels
  Picture3.AutoRedraw = True
  Picture2.AutoRedraw = True
  w = Picture2.ScaleWidth
  h = Picture2.ScaleHeight
  clr = Picture2.Point(0, 0)
  Call TransparentBlt(Picture3.hDC, 40, 0, w, h, Picture2.hDC, 0, 0, w, h, clr)
'To print text at PictureBox use Print Metod
  Picture3.Font.Size = 20
  Picture3.CurrentX = 20
  Picture3.CurrentY = 20
  Picture3.Print "Hello Word"
  Picture3.Picture = Picture1.Image
'If you need, you can save new picture
'  SavePicture Picture3.Picture, "test.bmp"
End Sub

LVL 10

Expert Comment

ID: 2619213
OK, here's some information from memory. I don't quite remember so it's a bit vague. Apologies...

If you don't have w98/2000, you'll have to perform 3 steps. Even if you do have it, the ideas below are better, as TransparentBlt would give undesired results if some of the picture you want to put on top of the other picture happens to contain the transparent colour.

What you need is a couple of bitmaps

1 - A bitmap of the background image. A nice landscape for example.

For every thing you wish to put into this, you'll need *two* images. Let's say you've got a cow and you wish to put it into the landscape...

2 - A bitmap that is white for everything that is not "the cow", and black for everything that is "the cow". This will look like the shadow of the cow on a white background.

3 - A bitmap that contains the actual picture of the cow, but is completely black everywhere else.

Now, use bitblt.

First "blt" bitmap 2) on top of bitmap 1). Use SRCAND as a parameter. As a result, you'll get a cutout of the cow on the landscape. Basically, White AND another colour gives the other colour, Black AND another colour gives black...

Second "blt" bitmap 3) on top of the newly created combination bitmap. This time use SRCPAINT. (which is an OR operation. Black OR another colour gives the other colour. This works two ways. For the background, everything outside the cow will be black in bitmap 3), so the background remains untouched. For the cow, the cow has been cut out of the background and a black shadow was left, so the cow will remain untouched.

Et voila, a cow has appeared in your landscape.

Hope this helps.


Author Comment

ID: 2620806
Thx that work

Featured Post

Back Up Your Microsoft Windows Server®

Back up all your Microsoft Windows Server – on-premises, in remote locations, in private and hybrid clouds. Your entire Windows Server will be backed up in one easy step with patented, block-level disk imaging. We achieve RTOs (recovery time objectives) as low as 15 seconds.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction While answering a recent question ( in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…

832 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question