Re: Data Report: Do it the hard way :-)

Tech Tip: Click here to run a free scan for Windows Errors and optimize PC performance


"Mike Williams" <mikea@xxxxxxxxxxxxxxxxx> schrieb im Newsbeitrag
news:eesEdvx5HHA.5980@xxxxxxxxxxxxxxxxxxxxxxx

To do it properly so that the preview looks exactly the same
as the actual printout you need to print your stuff in a different
way that takes this stuff into account. There are of course ways
of solving the problem (I can think of about three different methods
offhand) ...
Don't know of your other two methods ;-) ... but the probably
easiest one is, to draw all your printing stuff to only *one* DC.
Under Windows this layer of indirection can be achieved using
(enhanced) MetaFiles.

@ the OP:
You can draw your stuff against a MetaFile-DC (wich is some sort
of "virtual Storage for GDI-Commands") - and this will produce
a (very small File) on Disk (or a Buffer in Memory).

This file can be loaded later on - and you can playback your
stored GDI-commands against "real" DCs ... resolution-
independent; and also (depending on some settings) free
scalable regarding the aspect-ratio.

Here comes an example (WYSIWYG-Preview).

'***Into a Form (create Picture1 on it)
Option Explicit


Private Type DOCINFO
cbSize As Long
sDocName As String
sOutput As String
sDatatype As String
fwType As Long
End Type


Private Type RECT: L As Long: T As Long: R As Long: B As Long: End Type


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 As String * 32
End Type


Const TA_BASELINE& = 24, TA_BOTTOM& = 8
Const TA_LEFT& = 0, TA_CENTER& = 6, TA_RIGHT& = 2


Private Declare Function GetEnhMetaFile& Lib "gdi32" Alias _
"GetEnhMetaFileA" (ByVal lpszMetaFile$)
Private Declare Function CreateEnhMetaFile& Lib "gdi32" Alias _
"CreateEnhMetaFileA" (ByVal hdcRef&, ByVal FName$, Rct As RECT, ByVal
D$)
Private Declare Function CloseEnhMetaFile& Lib "gdi32" (ByVal hdc&)
Private Declare Function DeleteEnhMetaFile& Lib "gdi32" (ByVal Hdl&)
Private Declare Function PlayEnhMetaFile& Lib "gdi32" (ByVal hdc&, _
ByVal hemf&, lpRect As RECT)


Private Declare Function Rectangle& Lib "gdi32" (ByVal hdc&, ByVal x1&,
_
ByVal y1&, ByVal x2&, ByVal y2&)
Private Declare Function Ellipse& Lib "gdi32" (ByVal hdc&, ByVal x1&, _
ByVal y1&, ByVal x2&, ByVal y2&)
Private Declare Function SetStretchBltMode& Lib "gdi32" _
(ByVal hdc&, ByVal nStretchMode&)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc&, _
ByVal hObject&)
Private Declare Function SetTextAlign& Lib "gdi32" (ByVal hdc&, _
ByVal wFlags&)
Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" _
(ByVal hdc&, ByVal x&, ByVal y&, ByVal lpString$, ByVal nCount&)
Private Declare Function SetBkMode& Lib "gdi32" (ByVal hdc&, _
ByVal nBkMode&)
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias _
"CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject&)
Private Declare Function GetDeviceCaps& Lib "gdi32" (ByVal hdc&, _
ByVal nIndex&)


Private Declare Function StartDoc& Lib "gdi32" Alias "StartDocA" _
(ByVal hdc&, lpdi As DOCINFO)
Private Declare Function StartPage& Lib "gdi32" (ByVal hdc&)
Private Declare Function EndDoc& Lib "gdi32" (ByVal hdc&)
Private Declare Function EndPage& Lib "gdi32" (ByVal hdc&)


Private dpMMX!, dpMMY!


Private Sub Picture1_Click()
Dim MFDC&, MFHdl&, Rct As RECT, PixToHimetricX!, PixToHimetricY!
'define Metafile-Size (Himetric = 1/100 mm)
Rct.R = 20000: Rct.B = 28200 'A4 with some Border


'generate Metafile-DC (compatible to the Printer-DC) directly on a
File
'(for drawing in Screen-Resolution use 0 instead of Printer.hdc)
MFDC = CreateEnhMetaFile(Printer.hdc, "c:\test.emf", Rct,
vbNullString)


'here we draw against the Metafile-DC
DrawPrintOut MFDC


'closing the MF-DC generates an MF-Handle
MFHdl = CloseEnhMetaFile(MFDC)
'delete Handle (File is not deleted)
DeleteEnhMetaFile MFHdl


MsgBox FileLen("c:\test.emf"), , "FileSize in Bytes"


'And now Read-Direction
'get the Handle ...
MFHdl = GetEnhMetaFile("c:\test.emf")


'Play against the Picture-DC...
Picture1.ScaleMode = vbPixels: Picture1.AutoRedraw = True
Rct.R = Picture1.ScaleWidth: Rct.B = Picture1.ScaleHeight
SetStretchBltMode hdc, 4 'HalfTone
PlayEnhMetaFile Picture1.hdc, MFHdl, Rct
Picture1.Refresh


'and here (possibly) against the printer
If MsgBox("Should we print?", vbYesNo) = vbYes Then
PrintDoc "TestDocument", MFHdl
End If


DeleteEnhMetaFile MFHdl
End Sub


Private Sub DrawPrintOut(ByVal DC&)
Dim hFont1&, hFont2&, OldFont&
'calculate mm-scale
dpMMX = GetDeviceCaps(DC, 88) / 25.40003
dpMMY = GetDeviceCaps(DC, 90) / 25.40003


SetBkMode DC, 1
SetTextAlign DC, TA_BASELINE


hFont1 = GethFont(DC, "Arial", 12, True)
hFont2 = GethFont(DC, "Times", 17)


DrawEllipseMM DC, 25, 25, 150, 150
DrawRectangleMM DC, 10, 10, 90, 90
DrawRectangleMM DC, 100, 100, 90, 90


OldFont = SelectObject(DC, hFont1)
DrawTextMM DC, 20, 20, "Test hFont1"


'Destroy hFont1 and select hFont2
DeleteObject SelectObject(DC, hFont2)
DrawTextMM DC, 110, 110, "Test hFont2"


'Destroy hFont2 and reselect OldFont-Handle
DeleteObject SelectObject(DC, OldFont)
End Sub


Function GethFont&(DC&, Name$, Size!, Optional Bold&)
Dim LF As LOGFONT
'DC-independent "Point-To-Pixel-Mapping"
LF.lfHeight = -(CLng(Size * GetDeviceCaps(DC, 90)) / 72)
LF.lfWeight = IIf(Bold, 700, 400)
LF.lfCharSet = 1
LF.lfFaceName = Name & Chr$(0)
GethFont = CreateFontIndirect(LF)
End Function


Function DrawTextMM(DC&, ByVal x!, ByVal y!, S$)
TextOut DC, x * dpMMX, y * dpMMY, S, Len(S)
End Function


Function DrawRectangleMM(DC&, ByVal x!, ByVal y!, ByVal dx!, ByVal dy!)
Dim x1&, x2&, y1&, y2&
x1 = x * dpMMX: y1 = y * dpMMY
x2 = x1 + (dx * dpMMX): y2 = y1 + (dy * dpMMY)
Rectangle DC, x1, y1, x2, y2
End Function


Function DrawEllipseMM(DC&, ByVal x!, ByVal y!, ByVal dx!, ByVal dy!)
Dim x1&, x2&, y1&, y2&
x1 = x * dpMMX: y1 = y * dpMMY
x2 = x1 + (dx * dpMMX): y2 = y1 + (dy * dpMMY)
Ellipse DC, x1, y1, x2, y2
End Function


Private Sub Form_Resize() 'Aspect-Ratio A4
On Error Resume Next
Picture1.BorderStyle = 0: Picture1.BackColor = vbWhite
ScaleMode = vbPixels: BackColor = &HDFDFDF
Move Left, Top, Width, Width * 1.4142
Picture1.Move 10, 10, ScaleWidth - 20, ScaleHeight - 20
Err.Clear
End Sub


Private Sub PrintDoc(ByVal DocName$, ByVal MFHdl&)
Dim DI As DOCINFO, Rct As RECT
DI.cbSize = 20: DI.sDocName = DocName: DI.sDatatype = "emf" & Chr(0)
Printer.ScaleMode = vbPixels


'Print two pages (portrait and landscape)
StartDoc Printer.hdc, DI


Printer.Orientation = vbPRORPortrait
StartPage Printer.hdc
Rct.R = Printer.ScaleWidth: Rct.B = Printer.ScaleHeight
PlayEnhMetaFile Printer.hdc, MFHdl, Rct
EndPage Printer.hdc


Printer.Orientation = vbPRORLandscape
StartPage Printer.hdc
Rct.R = Printer.ScaleHeight: Rct.B = Printer.ScaleWidth
PlayEnhMetaFile Printer.hdc, MFHdl, Rct
EndPage Printer.hdc


EndDoc Printer.hdc
End Sub




.

Relevant Pages

  • Re: Playing AVI and MPEG using MCI
    ... "mciSendStringA" (ByVal lpstrCommand As String, ... Dim mlRet As Long ... Private Sub CenterObject ... If mlRet 0 Then ...
    (microsoft.public.vb.controls)
  • RE: Adding Bound Pictures to an Access Database
    ... when the student's picture is missing it is leaving the ... Private Sub Form_Current ... Dim strPath As String ... Private Function pfValidFile(aFile As String) As Boolean ...
    (microsoft.public.access.modulesdaovba)
  • RE: jpgs not showing on forms
    ... Rather than embed the pictures in the database store the paths to the JPEG ... Private Sub cmdAddImage_Click ... Dim strAdditionalTypes As String, strFileList As String ... Private Sub cmdDeleteImage_Click ...
    (microsoft.public.access.gettingstarted)
  • Re: how to digitally sign XML documents step by step
    ... Add an XML node. ... >Private strPath As String ... >'The ControlID for the first control you add will be 1. ... >Private Sub ISmartDocument_PopulateActiveXProps(ByVal ControlID As Long, ...
    (microsoft.public.word.vba.general)
  • Re: how to digitally sign XML documents step by step
    ... Private strPath As String ... 'The ControlID for the first control you add will be 1. ... Private Sub ISmartDocument_PopulateActiveXProps(ByVal ControlID As Long, ... Dim strImage As String ...
    (microsoft.public.word.vba.general)