danyb
asked on
get BMP from class
How can i get a BMP from Class?
need to write a class in VB that return a BMP/Image to C++ application.
need to write a class in VB that return a BMP/Image to C++ application.
Erick37
What do you mean?
ASKER
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!
Pino
OK,
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
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
Private Type TEXTMETRIC
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
Private Type METAHEADER
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_MAX_FIXEDSCALE = MM_TWIPS
Private Const MM_ISOTROPIC = 7
Private Const MM_ANISOTROPIC = 8
Private Const MM_MAX = MM_ANISOTROPIC
Private Type METAFILEPICT
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
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
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 CLIP_DEFAULT_PRECIS = 0
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.
Private Type NEWTEXTMETRIC
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
Private Const TRUETYPE_FONTTYPE = &H4
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
Dim hFile As Long
Dim Hdr As METAHEADER
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
' grab METAHEADER.
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.
Dim MFP As METAFILEPICT
MFP.mm = MM_ANISOTROPIC
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(
GetPlaceableMetafile = lngMF
ReleaseDC hWndDesktop, hDCDesktop
Exit Function
FileErr:
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(P
' 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(strMe
End If
End If
PrepareTextAndPicture hDCPicture, _
hDCText, _
hBmpOldPicture, _
hBmpOldText, _
HasPaletteScrn, _
PaletteSizeScrn, _
hPalOldPicture, _
hPalOldText, _
hMF, _
lngLeft, _
lngTop, _
lngWidth, _
lngHeight
SetMapMode hDCText, MM_TEXT
SetBkMode hDCText, TRANSPARENT
Dim dblWMFLeft As Double
Dim dblWMFTop As Double
dblWMFLeft = lngLeft
dblWMFTop = lngTop
LoadFCHTXT 0, _
0, _
colTXT, _
lngDPI, _
hDCText, _
hDCPicture, _
objFCH, _
0, _
0
Set CreateWMFPicture = CombineTextAndPicture(hDCP
hDCText, _
hBmpOldPicture, _
hBmpOldText, _
HasPaletteScrn, _
PaletteSizeScrn, _
hPalOldPicture, _
hPalOldText, _
lngLeft, _
lngTop, _
lngWidth, _
lngHeight)
'Cleanup
If blnEnhanced Then
DeleteEnhMetaFile hMF
Else
DeleteMetaFile hMF
End If
End Function
Private Sub PrepareTextAndPicture(hDCP
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 LogPal As LOGPALETTE
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(hDCDesk
' Create a bitmap and place it in the memory DC.
hBmp = CreateCompatibleBitmap(hDC
'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(hD
0, _
256, _
LogPal.palPalEntry(0))
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, _
WHITENESS)
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(hDCDesk
hBmpText = CreateCompatibleBitmap(hDC
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, _
WHITENESS)
End Sub
Private Function CombineTextAndPicture(hDCP
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, _
SRCAND)
' 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(hBMPPi
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.lngYPosSuggest
' dblCurrentYPos = dblCurrentYPos - udtTextMetrics.tmAscent
End If
objLineInfo.lngAbsLineSpac
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.GetThePrivilegedInf
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
Loop
End Select
Next
Exit Sub
ProcessValues:
'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
Return
ProcessValue:
'Copyright, sorry
'Determine things such as Line Spacing, Vertical and Horizontal position.
'e.g.
blnAbsLineSpcSet = True
lngAbsLineSpcSet = CLng(somevalue)
'or
dblCurrentCharSpacing = CDbl(somevalue)
'or
dblCurrentXPos = CDbl(somevalue)
'or
blnYPosSet = True
dblCurrentYPos = CDbl(somevalue)
'or
dblCurrentMargin = CDbl(somevalue)
'or
lngCurrentSize = CLng(somevalue)
GoSub FontHandling
'or
blnCurrentBold = (either.True Or False)
GoSub FontHandling
'also:
'blnCurrentUnderline
'GoSub FontHandling
'or
'blnCurrentItalic
'GoSub FontHandling
'or
'strCurrentFaceName = "For example: Courier New"
'GoSub FontHandling
'End Select
Return
FontHandling:
SetPictureFont strCurrentFaceName, _
lngCurrentSize, _
blnCurrentBold, _
blnCurrentUnderline, _
blnCurrentItalic, _
udtTextMetrics, _
hdc, _
lngDPI
dblCurrentLineSpacing = (udtTextMetrics.tmHeight + udtTextMetrics.tmExternalL
dblCurrentCharSpacing = udtTextMetrics.tmAveCharWi
Return
End Sub
Private Sub SetPictureFont(strFaceName
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
Else
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))
'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)
If InStr(strWork, strAnsiFont) = 1 Then
GetLogFont = aryFonts(lngCount)
Exit Function
End If
Next
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
Pino
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!
Pino
OK,
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
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
Private Type TEXTMETRIC
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
Private Type METAHEADER
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_MAX_FIXEDSCALE = MM_TWIPS
Private Const MM_ISOTROPIC = 7
Private Const MM_ANISOTROPIC = 8
Private Const MM_MAX = MM_ANISOTROPIC
Private Type METAFILEPICT
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
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
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 CLIP_DEFAULT_PRECIS = 0
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.
Private Type NEWTEXTMETRIC
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
Private Const TRUETYPE_FONTTYPE = &H4
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
Dim hFile As Long
Dim Hdr As METAHEADER
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
' grab METAHEADER.
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.
Dim MFP As METAFILEPICT
MFP.mm = MM_ANISOTROPIC
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(
GetPlaceableMetafile = lngMF
ReleaseDC hWndDesktop, hDCDesktop
Exit Function
FileErr:
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(P
' 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(strMe
End If
End If
PrepareTextAndPicture hDCPicture, _
hDCText, _
hBmpOldPicture, _
hBmpOldText, _
HasPaletteScrn, _
PaletteSizeScrn, _
hPalOldPicture, _
hPalOldText, _
hMF, _
lngLeft, _
lngTop, _
lngWidth, _
lngHeight
SetMapMode hDCText, MM_TEXT
SetBkMode hDCText, TRANSPARENT
Dim dblWMFLeft As Double
Dim dblWMFTop As Double
dblWMFLeft = lngLeft
dblWMFTop = lngTop
LoadFCHTXT 0, _
0, _
colTXT, _
lngDPI, _
hDCText, _
hDCPicture, _
objFCH, _
0, _
0
Set CreateWMFPicture = CombineTextAndPicture(hDCP
hDCText, _
hBmpOldPicture, _
hBmpOldText, _
HasPaletteScrn, _
PaletteSizeScrn, _
hPalOldPicture, _
hPalOldText, _
lngLeft, _
lngTop, _
lngWidth, _
lngHeight)
'Cleanup
If blnEnhanced Then
DeleteEnhMetaFile hMF
Else
DeleteMetaFile hMF
End If
End Function
Private Sub PrepareTextAndPicture(hDCP
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 LogPal As LOGPALETTE
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(hDCDesk
' Create a bitmap and place it in the memory DC.
hBmp = CreateCompatibleBitmap(hDC
'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(hD
0, _
256, _
LogPal.palPalEntry(0))
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, _
WHITENESS)
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(hDCDesk
hBmpText = CreateCompatibleBitmap(hDC
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, _
WHITENESS)
End Sub
Private Function CombineTextAndPicture(hDCP
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, _
SRCAND)
' 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(hBMPPi
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.lngYPosSuggest
' dblCurrentYPos = dblCurrentYPos - udtTextMetrics.tmAscent
End If
objLineInfo.lngAbsLineSpac
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.GetThePrivilegedInf
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
Loop
End Select
Next
Exit Sub
ProcessValues:
'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
Return
ProcessValue:
'Copyright, sorry
'Determine things such as Line Spacing, Vertical and Horizontal position.
'e.g.
blnAbsLineSpcSet = True
lngAbsLineSpcSet = CLng(somevalue)
'or
dblCurrentCharSpacing = CDbl(somevalue)
'or
dblCurrentXPos = CDbl(somevalue)
'or
blnYPosSet = True
dblCurrentYPos = CDbl(somevalue)
'or
dblCurrentMargin = CDbl(somevalue)
'or
lngCurrentSize = CLng(somevalue)
GoSub FontHandling
'or
blnCurrentBold = (either.True Or False)
GoSub FontHandling
'also:
'blnCurrentUnderline
'GoSub FontHandling
'or
'blnCurrentItalic
'GoSub FontHandling
'or
'strCurrentFaceName = "For example: Courier New"
'GoSub FontHandling
'End Select
Return
FontHandling:
SetPictureFont strCurrentFaceName, _
lngCurrentSize, _
blnCurrentBold, _
blnCurrentUnderline, _
blnCurrentItalic, _
udtTextMetrics, _
hdc, _
lngDPI
dblCurrentLineSpacing = (udtTextMetrics.tmHeight + udtTextMetrics.tmExternalL
dblCurrentCharSpacing = udtTextMetrics.tmAveCharWi
Return
End Sub
Private Sub SetPictureFont(strFaceName
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
Else
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))
'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)
If InStr(strWork, strAnsiFont) = 1 Then
GetLogFont = aryFonts(lngCount)
Exit Function
End If
Next
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
Pino
Hi
Why not simply return stdPicture.Handle?
Cheers
Why not simply return stdPicture.Handle?
Cheers
"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.
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.
Hi
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.
Cheers
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.
Cheers
ASKER
all I need is handle.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
For anyone who wants to create a StdPicture object from an bitmap handle....
Public Declare Function oleCreatePictureIndirect Lib "olepro32.dll" Alias "OleCreatePictureIndirect"
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
Public Declare Function oleCreatePictureIndirect Lib "olepro32.dll" Alias "OleCreatePictureIndirect"
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