-
2 Attachment(s)
[VB6] UPrinter - Unicode Printer Class
I looked around and didn't find many working samples of this... actually none at all but lots of questions about non-working code snippets. There may be some out there, and better than this basic one. I just didn't find any.
This version does not deal with top/bottom margins, colors, images, drawing, paper tray or size selection, orientation, etc. It only prints in whole lines (or multiples if you have embedded newlines), long lines should wrap.
I have attached an archive here containing a small demo Project that uses UPrinter.
Utf8Reader is is class for reading UTF-8 encoded text files. It in turn makes use of the Utf8Codec class. For this demo a UTF-8 CSV file is read as a source of sample Unicode text to print.
ParseCSV is here because the sample data is a CSV file and I want to split the data into fields and then print them with Tabs in between.
Each line of text after the first (heading) line is printed twice in this demo. The only purpose of that was to test page boundary overflow detection.
This hasn't been fully tested so it may fail with some printer drivers. As already stated it is an incomplete and minimal example but it should serve as a starting point if you want to implement more functionality.
Updates:
New version replaces the earlier attachment here. A few small bug fixes, added properties TopMargin and BottomMargin and method KillDoc.
-
Re: [VB6] UPrinter - Unicode Printer Class
I should have mentioned: the archive has the sample data file in it.
-
Re: [VB6] UPrinter - Unicode Printer Class
Quote:
Originally Posted by
dilettante
I should have mentioned: the archive has the sample data file in it.
I have printed A4 page on my Sharp printer. Only two lines (Korean) are auto wrapped to next line.
Democratic People's Rep. of Korea LEE Sol-Hee 조선 민주주의 인민 공화국 이
설희
Democratic People's Rep. of Korea LEE Sol-Hee 조선 민주주의 인민 공화국 이
설희
I used a textbox to record ParseCSV for comparison,other line looks OK,only two korean line's space between segments on printed page is bigger than actual ParseCSV in textbox, thus the print line is wrapped.
I also printed into pdf creator, it's OK. the two korean lines are ok.
Thanks for sharing.
Code:
Private Sub cmdPrint_Click()
Dim I As Long
Dim prtItem As Printer
Dim UPrinter As UPrinter
Dim Utf8Reader As Utf8Reader
Dim TextLine As String
lstPrinters.Enabled = False
cmdPrint.Enabled = False
lblStatus.Caption = "Opening..."
lblStatus.Refresh
Set UPrinter = New UPrinter
'Printers collection is not directly addressable so find the selected one:
For Each prtItem In Printers
If I = lstPrinters.ListIndex Then Exit For
I = I + 1
Next
'Use this Printer object to get the required parameters for OpenPrinter:
With prtItem
If Not UPrinter.OpenPrinter(.DeviceName, .DriverName) Then
lblStatus.Caption = "Canceled!"
Exit Sub
End If
End With
lblStatus.Caption = "Printing..."
DoEvents
utf8CSV.Text = ""
Set Utf8Reader = New Utf8Reader
With UPrinter
.LeftMargin = 360
.RightMargin = 180
.TabLength = 16
'CAUTION!
'
'Some printer drivers that print to a disk file may alter the current
'directory of the process before you get here.
'Get some Unicode data from a UTF-8 encoded file:
Utf8Reader.OpenFile App.Path & "\Utf8_Uniprint.txt", vbLf
'Print heading line.
With .Font
.Name = "Arial Unicode MS"
.Size = 11
.Underline = True
End With
TextLine = Utf8Reader.ReadLine()
.PrintLine Join$(ParseCSV(TextLine), vbTab)
utf8CSV.Text = utf8CSV.Text & Join$(ParseCSV(TextLine), vbTab) & vbCrLf
.PrintLine
utf8CSV.Text = utf8CSV.Text & vbCrLf
'Print data.
.Font.Underline = False
Do Until Utf8Reader.EOF
TextLine = Utf8Reader.ReadLine()
'Print each line twice, we want to test page overflows:
.PrintLine Join$(ParseCSV(TextLine), vbTab)
utf8CSV.Text = utf8CSV.Text & Join$(ParseCSV(TextLine), vbTab) & vbCrLf
.PrintLine Join$(ParseCSV(TextLine), vbTab)
utf8CSV.Text = utf8CSV.Text & Join$(ParseCSV(TextLine), vbTab) & vbCrLf
Loop
Utf8Reader.CloseFile
.ClosePrinter
End With
lblStatus.Caption = "Done"
End Sub
-
Re: [VB6] UPrinter - Unicode Printer Class
Thanks for trying it out.
As written it doesn't have support for right-to-left (Hebrew, Arabic) or vertical (East Asian) text directions either. All of that can probably be done with a little work, but those little things do add up.
I might be off slightly in "measuring" (setting RECTangle structures) or printer drivers and printers might have slight differences in default paper size settings or printable area of different paper sizes. Perhaps that might account for differences in line wrapping.
-
Re: [VB6] UPrinter - Unicode Printer Class
Is it possible to call any API to assign the Paper size of hDcPrinter which created by CreateDC API?
-
Re: [VB6] UPrinter - Unicode Printer Class
You can define a DEVMODE structure UDT and pass a pointer to that as the lpInitData argument to CreateDC.
That's a messy structure to map to a UDT because it has unions in it, but this one might work:
Code:
Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
This and the two constants it uses should be available in the API Text Viewer that comes with VB6.
-
Re: [VB6] UPrinter - Unicode Printer Class
Quote:
Originally Posted by
dilettante
You can define a
DEVMODE structure UDT and pass a pointer to that as the lpInitData argument to CreateDC.
That's a messy structure to map to a UDT because it has unions in it, but this one might work:
Code:
Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
This and the two constants it uses should be available in the API Text Viewer that comes with VB6.
I used your class as a printing controller (OpenPrinter/NewPage/ClosePrinter). Paint is done by outside function.
Code:
Dim oPrintController As PrintController
Set oPrintController = New PrintController
If Not oPrintController.OpenPrinter(Printer.DeviceName, Printer.DriverName) Then
Exit Sub
End If
Dim i As Long
For i = FromPage To ToPage
PageNo = i - 1
PrintPage oPrintController.PrinterDC '-->My Paint function
If i < ToPage Then oPrintController.NewPage
Next
oPrintController.ClosePrinter
Set oPrintController = Nothing
For A4 paper, the printing is OK But the printing is out of boundary for A3 paper. Since the DC created by CreateDC is 0 size. I suspect this is cause,but I am not sure, so i want to try to create the printerDC with A3 size for verification.
Is it possible to pass the lpDevMode and hDevMode after Printer Dialog (called by PrintDialogEx API) is close if <OK> button or <Apply> Button is pressed? But I am afraid of memory leak (Cross Classes),though we will unlock it after CreateDC used.
In ShowPrinterDialog function, I will pass lpDevMode and hDevMode to PrintController class:
Code:
Public Function ShowPrinterEx(ByRef lpDevMode As Long, ByRef hDevMode As Long) As CdlPDResultConstants
'...
hDevMode = PDLGEX.hDevMode
lpDevMode = GlobalLock(PDLGEX.hDevMode)
CopyMemory DMODE, ByVal lpDevMode, LenB(DMODE)
'GlobalUnlock PDLGEX.hDevMode 'Don't Release at this moment
'GlobalFree PDLGEX.hDevMode
'...
In PrintController OpenPrinter:
Code:
Public Function OpenPrinter(ByVal lpDevMode As Long, ByVal hDevMode As Long, _
ByVal DeviceName As String, _
ByVal DriverName As String, _
Optional ByVal DocName As String) As Boolean
'...
hDcPrinter = CreateDC(StrPtr(DriverName), StrPtr(DeviceName), 0, lpDevMode)
'...
Code:
'Free it after call PrintController.OpenPrinter
GlobalUnlock hDevMode
GlobalFree hDevMode
Code:
Public Property Get PrinterDC() As Long
PrinterDC = hDcPrinter
End Property
Edited: Seemed it solves my problem. Now A3 paper printing is right now. Thanks for your excellent UPrinter Class.
The ShowPrinterEX Function is here.
-
4 Attachment(s)
Re: [VB6] UPrinter - Unicode Printer Class
Quote:
Originally Posted by
dilettante
I looked around and didn't find many working samples of this... actually none at all but lots of questions about non-working code snippets. There may be some out there, and better than this basic one. I just didn't find any.
This version does not deal with top/bottom margins, colors, images, drawing, paper tray or siz
I have attached an archive here containing a small demo Project that uses UPrinter.
Utf8Reader is is class for reading UTF-8 encoded text files. It in turn makes use of the Utf8Codec class. For this demo a UTF-8 CSV filee selection, orientation, etc. It only prints in whole lines (or multiples if you have embedded newlines), long lines should wrap.
is read as a source of sample Unicode text to print.
ParseCSV is here because the sample data is a CSV file and I want to split the data into fields and then print them with Tabs in between.
Each line of text after the first (heading) line is printed twice in this demo. The only purpose of that was to test page boundary overflow detection.
This hasn't been fully tested so it may fail with some printer drivers. As already stated it is an incomplete and minimal example but it should serve as a starting point if you want to implement more functionality.
Updates:
New version replaces the earlier attachment here. A few small bug fixes, added properties TopMargin and BottomMargin and method KillDoc.
hi dilettante ,thank you post your uprinter cls ,is very useful for me
now i print one png picture to the printreDC.
Attachment 145769
Attachment 145771
I have a question .in the form ,the picture is big ,but print to pdf,the picture is small.
can you give me some Suggest ? how can do print text and png to pdf and printer preview WYSIWYG?
i have find how to do
Code:
Dim x As Long, y As Long
ratio=screendpi/printerDPI
x = ucImage1.Parent.ScaleX(ucImage1.PictureWidth, vbPixels, vbTwips)
y = ucImage1.Parent.ScaleY(ucImage1.PictureHeight, vbPixels, vbTwips)
'ucImage1.PaintPicture .PrinterDC, .LeftMargin / ratio, -.TopMargin / ratio - ucImage1.PictureHeight * ratio, ucImage1.PictureWidth * ratio, ucImage1.PictureHeight * ratio, 0, 0, ucImage1.PictureWidth, ucImage1.PictureHeight
ucImage1.PaintPicture .PrinterDC, .LeftMargin / ratio, -.TopMargin / ratio - y / ratio, x / ratio, y / ratio, 0, 0, ucImage1.PictureWidth, ucImage1.PictureHeight
Attachment 145817Attachment 145819
'sets the unit of measure for this Graphics object from UnitDisplay to UnitPixel
GdipSetPageUnit hGraphics, UnitPixel
GdipSetSmoothingMode hGraphics, SmoothingModeAntiAlias
-
Re: [VB6] UPrinter - Unicode Printer Class
ucImage1.PaintPicture .PrinterDC, .LeftMargin / ratio, -.TopMargin / ratio - ucImage1.PictureHeight * ratio, ucImage1.PictureWidth * 2.5, ucImage1.PictureHeight * 2.5, 0, 0, ucImage1.PictureWidth, ucImage1.PictureHeight
You try this.
-
Re: [VB6] UPrinter - Unicode Printer Class
ucImage1.PaintPicture .PrinterDC, .LeftMargin / ratio, -.TopMargin / ratio - ucImage1.PictureHeight * ratio, ucImage1.PictureWidth * ratio / 2.5, ucImage1.PictureHeight * ratio / 2.5, 0, 0, ucImage1.PictureWidth, ucImage1.PictureHeight
-
Re: [VB6] UPrinter - Unicode Printer Class
Quote:
Originally Posted by
xxdoc123
I have a question .in the form ,the picture is big ,but print to pdf,the picture is small.
can you give me some Suggest ? how can do print text and png to pdf and printer preview WYSIWYG?
You might want to start a new thread in the VB6 and Earlier questions and answers forum.
-
Re: [VB6] UPrinter - Unicode Printer Class
I searched the forum, I think you are a printer expert, would like to use your uprinter cls better , so i want to ask you.thank you very much
-
Re: [VB6] UPrinter - Unicode Printer Class
-
Re: [VB6] UPrinter - Unicode Printer Class
ucImage1.Width / ucImage1.PictureWidth - (Screen.TwipsPerPixelX / Printer.TwipsPerPixelX * 2)
我的QQ 289778005 :)
-
1 Attachment(s)
Re: [VB6] UPrinter - Unicode Printer Class
-
Re: [VB6] UPrinter - Unicode Printer Class
Quote:
Originally Posted by
dilettante
New version.
Your code is very good. Can be added to modify the paper size ,orientation,print quality(DPI) and so on!
Note:
when used api changing the Printer dpi, it must be before StartDoc
my priner and Virtual printer (PDF-XChange 5.0) both can not support AlphaBlend
but both support GdipDrawImageRectRectI to Render
it's wired !
can add this GdipDrawImageRectRectI function to your cls?
-
1 Attachment(s)
Re: [VB6] UPrinter - Unicode Printer Class
Quote:
Originally Posted by
dilettante
New version.
Code:
'add by xxdoc'
Private Declare Function GdipGetImageHeight Lib "gdiplus.dll" (ByVal Image As Long, Height As Long) As Long
Private Declare Function GdipGetImageWidth Lib "gdiplus.dll" (ByVal Image As Long, Width As Long) As Long
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type RECTF
nLeft As Single
nTop As Single
nWidth As Single
nHeight As Single
End Type
Private Type COLORMATRIX
m(0 To 4, 0 To 4) As Single
End Type
Private Enum ColorAdjustType
ColorAdjustTypeDefault = 0
ColorAdjustTypeBitmap = 1
ColorAdjustTypeBrush = 2
ColorAdjustTypePen = 3
ColorAdjustTypeText = 4
ColorAdjustTypeCount = 5
ColorAdjustTypeAny = 6
End Enum
Private Enum ColorMatrixFlags
ColorMatrixFlagsDefault = 0
ColorMatrixFlagsSkipGrays = 1
ColorMatrixFlagsAltGray = 2
End Enum
Private Const UnitPixel As Long = &H2&
Private Declare Function GdipGetImageBounds _
Lib "gdiplus.dll" (ByVal nImage As Long, _
srcRect As RECTF, _
srcUnit As Long) As Long
Private Declare Function GdipCreateFromHDC _
Lib "Gdiplus" (ByVal hdc As Long, _
hGraphics As Long) As Long
Private Declare Function GdipCreateImageAttributes _
Lib "Gdiplus" (ByRef imageattr As Long) As Long
Private Declare Function GdipSetImageAttributesColorMatrix _
Lib "Gdiplus" (ByVal imageattr As Long, _
ByVal ColorAdjust As ColorAdjustType, _
ByVal EnableFlag As Boolean, _
ByRef MatrixColor As COLORMATRIX, _
ByRef MatrixGray As COLORMATRIX, _
ByVal flags As ColorMatrixFlags) As Long
Private Declare Function GdipDrawImageRectRectI _
Lib "Gdiplus" (ByVal hGraphics As Long, _
ByVal hImage As Long, _
ByVal dstx As Long, _
ByVal dsty As Long, _
ByVal dstwidth As Long, _
ByVal dstheight As Long, _
ByVal srcx As Long, _
ByVal srcy As Long, _
ByVal srcwidth As Long, _
ByVal srcheight As Long, _
ByVal srcUnit As Long, _
Optional ByVal imageAttributes As Long = 0, _
Optional ByVal callback As Long = 0, _
Optional ByVal callbackData As Long = 0) As Long
Private Declare Function GdipDisposeImageAttributes _
Lib "Gdiplus" (ByVal imageattr As Long) As Long
Private Declare Function GdipDeleteGraphics _
Lib "Gdiplus" (ByVal hGraphics As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus.dll" (Token As Long, gdipInput As GdiplusStartupInput, GdiplusStartupOutput As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus.dll" (ByVal Token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" (ByVal hbm As Long, ByVal hpal As Long, ByRef pbitmap As Long) As Long
'Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus.dll" (ByVal hbm As Long, ByVal hpal As Long, ByRef pbitmap As Long) As Long
Private Declare Function GdipCreateBitmapFromGraphics Lib "Gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal Graphics As Long, bitmap As Long) As Long
'add by xxdoc
Code:
Public Function RenderTo2(ByVal lhDC As Long, _
ByVal dstx As Long, _
ByVal dsty As Long, _
Optional ByVal dstwidth As Long, _
Optional ByVal dstheight As Long, _
Optional ByVal Alpha As Byte = 100) As Boolean
Dim PrevMM As Long
Dim hGraphics As Long
Dim hAttributes As Long
Dim dBrightness As Double
Dim dContrast As Double
Dim dAlpha As Double
Dim tMatrixColor As COLORMATRIX
Dim tMatrixGray As COLORMATRIX
Dim TR As RECTF
Dim c_lWidth As Long
Dim c_lHeight As Long
Dim printer2screenDPI As Single
If hBmp = WIN32_NULL Then Exit Function
printer2screenDPI = (GetDeviceCaps(lhDC, LOGPIXELSX) / GetDeviceCaps(GetDC(0), LOGPIXELSX))
' Call GdipGetImageBounds(hBmp, TR, UnitPixel)
' c_lWidth = TR.nWidth
' c_lHeight = TR.nHeight
' If dstWidth = 0 Then dstWidth = c_lWidth
' If dstHeight = 0 Then dstHeight = c_lHeight
' If srcWidth = 0 Then srcWidth = c_lWidth
' If srcHeight = 0 Then srcHeight = c_lHeight
If dstwidth = 0 Then dstwidth = Me.Width
If dstheight = 0 Then dstheight = Me.Height
dAlpha = ValidateValue(Alpha)
Dim bitmap As Long, bmW As Long, bmH As Long
'
GdipCreateBitmapFromHBITMAP hBmp, 0, bitmap
GdipGetImageWidth bitmap, bmW
GdipGetImageHeight bitmap, bmH
PrevMM = SetMapMode(lhDC, MM_TEXT)
If GdipCreateFromHDC(lhDC, hGraphics) = 0 Then
'sets the unit of measure for this Graphics object from UnitDisplay to UnitPixel
GdipSetPageUnit hGraphics, UnitPixel
GdipSetSmoothingMode hGraphics, SmoothingModeAntiAlias
With tMatrixColor
.m(0, 0) = 1
.m(1, 1) = 1
.m(2, 2) = 1
.m(4, 4) = 1
If Not dAlpha = 100 Then
.m(3, 3) = dAlpha
End If
End With
If GdipCreateImageAttributes(hAttributes) = 0 Then
If GdipSetImageAttributesColorMatrix(hAttributes, ColorAdjustTypeDefault, True, tMatrixColor, tMatrixGray, ColorMatrixFlagsDefault) = 0 Then
If GdipDrawImageRectRectI(hGraphics, bitmap, dstx / printer2screenDPI, dsty / printer2screenDPI, dstwidth / printer2screenDPI + 6, dstheight / printer2screenDPI + 6, 0, 0, bmW, bmH, UnitPixel, hAttributes) = 0 Then
RenderTo2 = True
End If
End If
Call GdipDisposeImageAttributes(hAttributes)
End If
Call GdipDeleteGraphics(hGraphics)
End If
SetMapMode lhDC, PrevMM
End Function
Not perfect,but can used in my printer and pdf printer well.
-
1 Attachment(s)
Re: [VB6] UPrinter - Unicode Printer Class
Quote:
Originally Posted by
xxdoc123
Code:
'add by xxdoc'
Private Declare Function GdipGetImageHeight Lib "gdiplus.dll" (ByVal Image As Long, Height As Long) As Long
Private Declare Function GdipGetImageWidth Lib "gdiplus.dll" (ByVal Image As Long, Width As Long) As Long
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type RECTF
nLeft As Single
nTop As Single
nWidth As Single
nHeight As Single
End Type
Private Type COLORMATRIX
m(0 To 4, 0 To 4) As Single
End Type
Private Enum ColorAdjustType
ColorAdjustTypeDefault = 0
ColorAdjustTypeBitmap = 1
ColorAdjustTypeBrush = 2
ColorAdjustTypePen = 3
ColorAdjustTypeText = 4
ColorAdjustTypeCount = 5
ColorAdjustTypeAny = 6
End Enum
Private Enum ColorMatrixFlags
ColorMatrixFlagsDefault = 0
ColorMatrixFlagsSkipGrays = 1
ColorMatrixFlagsAltGray = 2
End Enum
Private Const UnitPixel As Long = &H2&
Private Declare Function GdipGetImageBounds _
Lib "gdiplus.dll" (ByVal nImage As Long, _
srcRect As RECTF, _
srcUnit As Long) As Long
Private Declare Function GdipCreateFromHDC _
Lib "Gdiplus" (ByVal hdc As Long, _
hGraphics As Long) As Long
Private Declare Function GdipCreateImageAttributes _
Lib "Gdiplus" (ByRef imageattr As Long) As Long
Private Declare Function GdipSetImageAttributesColorMatrix _
Lib "Gdiplus" (ByVal imageattr As Long, _
ByVal ColorAdjust As ColorAdjustType, _
ByVal EnableFlag As Boolean, _
ByRef MatrixColor As COLORMATRIX, _
ByRef MatrixGray As COLORMATRIX, _
ByVal flags As ColorMatrixFlags) As Long
Private Declare Function GdipDrawImageRectRectI _
Lib "Gdiplus" (ByVal hGraphics As Long, _
ByVal hImage As Long, _
ByVal dstx As Long, _
ByVal dsty As Long, _
ByVal dstwidth As Long, _
ByVal dstheight As Long, _
ByVal srcx As Long, _
ByVal srcy As Long, _
ByVal srcwidth As Long, _
ByVal srcheight As Long, _
ByVal srcUnit As Long, _
Optional ByVal imageAttributes As Long = 0, _
Optional ByVal callback As Long = 0, _
Optional ByVal callbackData As Long = 0) As Long
Private Declare Function GdipDisposeImageAttributes _
Lib "Gdiplus" (ByVal imageattr As Long) As Long
Private Declare Function GdipDeleteGraphics _
Lib "Gdiplus" (ByVal hGraphics As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus.dll" (Token As Long, gdipInput As GdiplusStartupInput, GdiplusStartupOutput As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus.dll" (ByVal Token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" (ByVal hbm As Long, ByVal hpal As Long, ByRef pbitmap As Long) As Long
'Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus.dll" (ByVal hbm As Long, ByVal hpal As Long, ByRef pbitmap As Long) As Long
Private Declare Function GdipCreateBitmapFromGraphics Lib "Gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal Graphics As Long, bitmap As Long) As Long
'add by xxdoc
Code:
Public Function RenderTo2(ByVal lhDC As Long, _
ByVal dstx As Long, _
ByVal dsty As Long, _
Optional ByVal dstwidth As Long, _
Optional ByVal dstheight As Long, _
Optional ByVal Alpha As Byte = 100) As Boolean
Dim PrevMM As Long
Dim hGraphics As Long
Dim hAttributes As Long
Dim dBrightness As Double
Dim dContrast As Double
Dim dAlpha As Double
Dim tMatrixColor As COLORMATRIX
Dim tMatrixGray As COLORMATRIX
Dim TR As RECTF
Dim c_lWidth As Long
Dim c_lHeight As Long
Dim printer2screenDPI As Single
If hBmp = WIN32_NULL Then Exit Function
printer2screenDPI = (GetDeviceCaps(lhDC, LOGPIXELSX) / GetDeviceCaps(GetDC(0), LOGPIXELSX))
' Call GdipGetImageBounds(hBmp, TR, UnitPixel)
' c_lWidth = TR.nWidth
' c_lHeight = TR.nHeight
' If dstWidth = 0 Then dstWidth = c_lWidth
' If dstHeight = 0 Then dstHeight = c_lHeight
' If srcWidth = 0 Then srcWidth = c_lWidth
' If srcHeight = 0 Then srcHeight = c_lHeight
If dstwidth = 0 Then dstwidth = Me.Width
If dstheight = 0 Then dstheight = Me.Height
dAlpha = ValidateValue(Alpha)
Dim bitmap As Long, bmW As Long, bmH As Long
'
GdipCreateBitmapFromHBITMAP hBmp, 0, bitmap
GdipGetImageWidth bitmap, bmW
GdipGetImageHeight bitmap, bmH
PrevMM = SetMapMode(lhDC, MM_TEXT)
If GdipCreateFromHDC(lhDC, hGraphics) = 0 Then
'sets the unit of measure for this Graphics object from UnitDisplay to UnitPixel
GdipSetPageUnit hGraphics, UnitPixel
GdipSetSmoothingMode hGraphics, SmoothingModeAntiAlias
With tMatrixColor
.m(0, 0) = 1
.m(1, 1) = 1
.m(2, 2) = 1
.m(4, 4) = 1
If Not dAlpha = 100 Then
.m(3, 3) = dAlpha
End If
End With
If GdipCreateImageAttributes(hAttributes) = 0 Then
If GdipSetImageAttributesColorMatrix(hAttributes, ColorAdjustTypeDefault, True, tMatrixColor, tMatrixGray, ColorMatrixFlagsDefault) = 0 Then
If GdipDrawImageRectRectI(hGraphics, bitmap, dstx / printer2screenDPI, dsty / printer2screenDPI, dstwidth / printer2screenDPI + 6, dstheight / printer2screenDPI + 6, 0, 0, bmW, bmH, UnitPixel, hAttributes) = 0 Then
RenderTo2 = True
End If
End If
Call GdipDisposeImageAttributes(hAttributes)
End If
Call GdipDeleteGraphics(hGraphics)
End If
SetMapMode lhDC, PrevMM
End Function
Not perfect,but can used in my printer and pdf printer well.
Private Declare Function GdipSetPageUnit Lib "gdiplus" _
(ByVal Graphics As Long, ByVal Unit As Long) As Long
GdipSetPageUnit hGraphics, UnitPixel
http://www.vbforums.com/showthread.p...Print-Preview)
Attachment 157023
-
Re: [VB6] UPrinter - Unicode Printer Class
Quote:
Originally Posted by
dilettante
I looked around and didn't find many working samples of this... actually none at all but lots of questions about non-working code snippets. There may be some out there, and better than this basic one. I just didn't find any.
This version does not deal with top/bottom margins, colors, images, drawing, paper tray or size selection, orientation, etc. It only prints in whole lines (or multiples if you have embedded newlines), long lines should wrap.
I have attached an archive here containing a small demo Project that uses UPrinter.
Utf8Reader is is class for reading UTF-8 encoded text files. It in turn makes use of the Utf8Codec class. For this demo a UTF-8 CSV file is read as a source of sample Unicode text to print.
ParseCSV is here because the sample data is a CSV file and I want to split the data into fields and then print them with Tabs in between.
Each line of text after the first (heading) line is printed twice in this demo. The only purpose of that was to test page boundary overflow detection.
This hasn't been fully tested so it may fail with some printer drivers. As already stated it is an incomplete and minimal example but it should serve as a starting point if you want to implement more functionality.
Updates:
New version replaces the earlier attachment here. A few small bug fixes, added properties TopMargin and BottomMargin and method KillDoc.
I have a question. If I know that the blank height below the paper is less than the height of the string I actually printed. It involves the problem of partial string page printing. So used drawtext API how do can get the maximum number of strings that can be accommodated in this blank rectangle? used your cls 。if long string used drawtext return the height > page blank height 。may change new page 。so Paper wasted
-
Re: [VB6] UPrinter - Unicode Printer Class
Quote:
Originally Posted by
xxdoc123
hi dilettante ,thank you post your uprinter cls ,is very useful for me
now i print one png picture to the printreDC.
Attachment 145769
Attachment 145771
I have a question .in the form ,the picture is big ,but print to pdf,the picture is small.
can you give me some Suggest ? how can do print text and png to pdf and printer preview WYSIWYG?
i have find how to do
Code:
Dim x As Long, y As Long
ratio=screendpi/printerDPI
x = ucImage1.Parent.ScaleX(ucImage1.PictureWidth, vbPixels, vbTwips)
y = ucImage1.Parent.ScaleY(ucImage1.PictureHeight, vbPixels, vbTwips)
'ucImage1.PaintPicture .PrinterDC, .LeftMargin / ratio, -.TopMargin / ratio - ucImage1.PictureHeight * ratio, ucImage1.PictureWidth * ratio, ucImage1.PictureHeight * ratio, 0, 0, ucImage1.PictureWidth, ucImage1.PictureHeight
ucImage1.PaintPicture .PrinterDC, .LeftMargin / ratio, -.TopMargin / ratio - y / ratio, x / ratio, y / ratio, 0, 0, ucImage1.PictureWidth, ucImage1.PictureHeight
Attachment 145817Attachment 145819
'sets the unit of measure for this Graphics object from UnitDisplay to UnitPixel
GdipSetPageUnit hGraphics, UnitPixel
GdipSetSmoothingMode hGraphics, SmoothingModeAntiAlias
I would like to print image like you did but the uprinter does not have the print image method. Can you share with me the method you achieved with the image print?
-
Re: [VB6] UPrinter - Unicode Printer Class
Code:
'--------------------------------------------------------------------------------
' ?? : PrinterHelpX
'
'
' ?? : [????win32?????,??]
'
' ?? : ?XxDoC?
'--------------------------------------------------------------------------------
'<????:>????:???????????
'1. ?? .PriviewPictureObj = Picture1 ??????????????????????
'2.??.CreatPrinter(prtItem, "??") ???????
'3.TopMargin = ScaleY(1, vbInches, vbPixels) ???????.
' .BottomMargin = ScaleY(0.5, vbInches, vbPixels)
' .LeftMargin = ScaleX(0.25, vbInches, vbPixels)
' .RightMargin = ScaleX(0.125, vbInches, vbPixels)
' .TabLength = 16
'4 ?? .PriviewPictureObj.FontName = "Arial Unicode MS" 'Unicode?? "??" ????
' .PriviewPictureObj.FontSize = 16 ??
' .UPrinter.PriviewPictureObj.FontUnderline = True ???
' UPrinter.SetPrinterFont ????.
' .SetPapleSize A4, ?? ????,??
'??????????????
'5. ????.PrintTxt
Option Explicit
'<?????????>
Private Const PS_SOLID = 0
Private Const CLR_INVALID = &HFFFF
'Private Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
Private Const LF_FACESIZE = 32
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 * LF_FACESIZE
End Type
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextAlign Lib "gdi32" (ByVal hdc As Long, ByVal wFlags As Long) As Long
'Private Declare Function TextOutA Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount 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 CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
'Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
'Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
'</?????????>
Private Type DOCINFO
cbSize As Long
lpszDocName As Long
lpszOutput As Long
lpszDatatype As Long
fwType As Long
End Type
Enum PageDirection
?? = 1
?? = 2
End Enum
Enum PageSize
A4 = 9 '2100-2970mm
' A3 = 8 '
A5 = 11 '1480-2100mm
'B4 = 12
' B5 = 13
End Enum
Private Const API_NULL As Long = 0
Private Const INVALID_HANDLE_VALUE As Long = -1
Private StartedDoc As Boolean
Private StartedPage As Boolean
Private TypeNameOfMe As String
Private Const ERROR_CANCELLED As Long = 1223
Private Const SP_ERROR As Long = -1
Private Declare Function CreateFont _
Lib "gdi32" _
Alias "CreateFontA" (ByVal H As Long, _
ByVal W As Long, _
ByVal E As Long, _
ByVal O As Long, _
ByVal W As Long, _
ByVal i As Long, _
ByVal u As Long, _
ByVal S As Long, _
ByVal C As Long, _
ByVal OP As Long, _
ByVal CP As Long, _
ByVal Q As Long, _
ByVal PAF As Long, _
ByVal f As String) As Long
Private Const DEFAULT_CHARSET = 1
Private Const OUT_DEFAULT_PRECIS = 0
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const PROOF_QUALITY = 2
Private Const DEFAULT_PITCH = 0
Private Declare Function MulDiv _
Lib "kernel32" (ByVal nNumber As Long, _
ByVal nNumerator As Long, _
ByVal nDenominator 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 SelectObject _
Lib "gdi32.dll" (ByVal hdc As Long, _
ByVal hObject As Long) 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 Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function AbortDoc Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDC _
Lib "gdi32.dll" _
Alias "CreateDCA" (ByVal lpszDriver As String, _
ByVal lpszDevice As String, _
ByVal lpszOutput As Long, _
lpInitData As Any) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function StartPage Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function StartDoc _
Lib "gdi32.dll" _
Alias "StartDocW" (ByVal hdc As Long, _
lpdi As DOCINFO) As Long
Private Declare Function EndPage Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function EndDoc Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetProfileString _
Lib "kernel32" _
Alias "GetProfileStringA" (ByVal lpAppName As String, _
ByVal lpKeyName As Any, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long) As Long
Private Declare Function RegOpenKey _
Lib "advapi32.dll" _
Alias "RegOpenKeyA" (ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Const HKEY_CURRENT_USER = &H80000001
Private Declare Function RegQueryValueEx _
Lib "advapi32.dll" _
Alias "RegQueryValueExA" (ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Any, _
lpcbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Private Const REG_SZ = 1 ' Unicode nul terminated string
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Const ERROR_SUCCESS = 0&
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 ' Maintenance string for PSS usage
End Type
Private Declare Function GetVersion Lib "kernel32" () As Long
Private Declare Function GetVersionEx _
Lib "kernel32" _
Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Declare Function SetMapMode _
Lib "gdi32" (ByVal hdc As Long, _
ByVal nMapMode As Long) As Long
Private Const MM_ANISOTROPIC = 8
Private Declare Function SetWindowExtEx _
Lib "gdi32" (ByVal hdc As Long, _
ByVal nX As Long, _
ByVal nY As Long, _
ByVal lpSize As Long) As Long
Private Declare Function GetDeviceCaps _
Lib "gdi32" (ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Private Const LOGPIXELSX = 88 ' Logical pixels/inch in X
Private Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
Private Declare Function SetViewportExtEx _
Lib "gdi32" (ByVal hdc As Long, _
ByVal nX As Long, _
ByVal nY As Long, _
ByVal lpSize As Long) As Long
Private CurrentBottom As Long '?? ????????????????,??????????
' ????????DC,?????????
Private mPrinterHDC As Long
Private IsOpen As Boolean
Private IsSetPapleSize As Boolean
' ?????????????????.
Private mScreenPrinterRatio As Double
' ?????????
Private mFontHeight As Single
Private mSetPrinterFont As Boolean
' ?????????.????????????
Private mPriviewPictureObj As PictureBox
Dim hFont As Long, hOldFont As Long
' ?????????????,?????
Private mPrinterWidthPix As Long
' ?????????????,?????
Private mPrinterheightPix As Long
' ??????????y
Private mprinterCurrentY As Long
' ??????????x
Private mprinterCurrentX As Long
Private mBottomMargin As Integer '??????,??
Private mTopMargin As Long '??????.??
Private TopMarginChanged As Boolean
Public LeftMargin As Integer '???? LeftMargin RightMargin
Public RightMargin As Integer '??????
Public TabLength As Byte 'Tabstop settings in "average char width" and 0 means default every 8.
Public Device2LogicRatioX As Double '???????????
Public Device2LogicRatioY As Double
Public Event PrinterPriview(x As Long, y As Long, Txt As String, PrintOrPriview As Boolean, txtcolor As OLE_COLOR, ???? As AlignmentConstants) '???? ???????? ????????
Public Property Get BottomMargin() As Integer
BottomMargin = mBottomMargin
End Property
Public Property Get TopMargin() As Integer
TopMargin = mTopMargin
End Property
Public Property Let TopMargin(ByVal RHS As Integer)
If IsSetPapleSize Then
If (RHS + mBottomMargin) * mScreenPrinterRatio >= mPrinterheightPix Then
ClosePrinter
Err.Raise 380, TypeNameOfMe 'Invalid property value.
End If
TopMarginChanged = True
End If
mTopMargin = RHS
End Property
Public Property Let BottomMargin(ByVal RHS As Integer)
If IsSetPapleSize Then
If (mTopMargin + RHS) * mScreenPrinterRatio >= mPrinterheightPix Then
ClosePrinter
Err.Raise 380, TypeNameOfMe 'Invalid property value.
End If
End If
mBottomMargin = RHS
End Property
Public Property Get PrinterCurrentX() As Single
PrinterCurrentX = mprinterCurrentX
End Property
Public Property Let PrinterCurrentX(ByVal LonValue As Single)
mprinterCurrentX = LonValue
End Property
Public Property Get PrinterCurrentY() As Single
PrinterCurrentY = mprinterCurrentY
End Property
Public Property Let PrinterCurrentY(ByVal LonValue As Single)
mprinterCurrentY = LonValue
End Property
Public Property Get PrinterheightPix() As Long
PrinterheightPix = mPrinterheightPix
End Property
Public Property Get PrinterWidthPix() As Long
PrinterWidthPix = mPrinterWidthPix
End Property
Public Property Get PriviewPictureObj() As PictureBox
Set PriviewPictureObj = mPriviewPictureObj
End Property
Public Property Set PriviewPictureObj(ByVal PicValue As PictureBox)
PicValue.ScaleMode = vbPixels
PicValue.AutoRedraw = True
Set mPriviewPictureObj = PicValue
End Property
Public Property Get FontHeight() As Single
If mSetPrinterFont = True Then
FontHeight = mFontHeight
Else
MsgBox "???????,?????SetPrinterFont?????????"
End If
End Property
Public Property Let FontHeight(ByVal LonValue As Single)
If mSetPrinterFont = True Then
mFontHeight = LonValue
Else
MsgBox "???????,?????SetPrinterFont?????????"
End If
End Property
Public Property Get ScreenPrinterRatio() As Long
ScreenPrinterRatio = mScreenPrinterRatio
End Property
Public Property Get PrinterHDC() As Long
PrinterHDC = mPrinterHDC
End Property
'GDI ???? ? SetViewportExtEx ? SetWindowExtEx ??
'http://blog.csdn.net/typecool/article/details/5887367
'????????????????????????
'???windows???5?6????????GDI????windows???????????5?6????????????5?6??????GDI??????????????
'?????????????????????
'????:
'??????5?6?????
'?????5?6???????????????
'
'SetViewportOrgEx?SetWindowOrgEx????????????????X?Y???(SetMapMode)?
'
'<< GDI ???? ? SetViewportOrgEx ? SetWindowOrgEx ??>>
'http://blog.csdn.net/typecool/article/details/5898110
'SetViewportExtEx?SetWindowExtEx????????? ?????
'
'????????????5?6??????????????????????????X?Y??????????
'SetViewportExtEx?SetWindowExtEx?????????? (???????????????????????????)
'
'SetWindowExtEx???????????
'
'SetViewportExtEx???????????
'
'?????SetViewportExtEx????SetWindowExtEx??????????????????
'
'????:
'SetMapMode(hdc,MM_ANISOTROPIC);
'SetWindowExtEx(hdc,1,1,NULL);
'SetViewportExtEx(hdc,cxChar,cyChar,NULL);
'TextOut(hdc,3,2,TEXT( "Hello "),5);
'
'??TextOut?????3?2??Windows98?????32767???????????? "Hello "????
'???????????(??????)???1???????(??????)???cxChar?cyChar(????????????)?
'???????Windows??(3*(cxChar/1),2*(cyChar/1))??????????????????????? "Hello "?
'
'windows?????????????????????:
'
'?????X = (???????X - ?????????x) * (??????????x / ?????????x) + ??????????x
'
'?????X = (???????x - ??????????x) * (?????????x / ??????????x) + ?????????x
'
'??????????????:
'SetMapMode(hdc,MM_ANISOTROPIC);
'SetWindowExtEx(hdc,4,4,NULL); //?????(??????)?4?????
'SetViewportExtEx(hdc,8,8,NULL); //?????(??????)?8?????(???8???)
'TextOut(hdc,1,1,TEXT( "Hello "),5); //?????(1,1)??? "Hello "
'
'??????????X??????????2,Y???????????2?1*(8/4)=2,???Windows??????????????2??????2???????? "Hello "?
'
'???????TextOut???????:
'TextOut(hdc,10,10,TEXT( "Hello "),5);
'
'10??????????????4?????????????????32767????10*(8/4)=20?Windows?????????????20??????20???????? "Hello "?
'SetWindowExtEx? ???????????
'SetViewPortExtEx, ???????????
'???1????????????????????MM_ANISOTROPIC ?MM_ISOROPIC??????????????????
Public Function CreatPrinter(Optional ByVal mPrinter As Printer, _
Optional ByVal docName As String) As Boolean '???????????????
'?????????
Dim ovi As OSVERSIONINFO
GetVersionEx ovi
'???????
Dim dwSize As Long
Dim strBuffer As String, PrinterName As String, DriverName As String, PortName As String
If mPrinter Is Nothing Then
dwSize = 255
strBuffer = String(dwSize, vbNullChar)
If ovi.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then 'WIN16
GetProfileString "windows", "device", "", strBuffer, dwSize
Else 'WIN32
Dim hKey As Long, dwType As Long
RegOpenKey HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Windows", hKey
dwType = REG_SZ
RegQueryValueEx hKey, "Device", 0, dwType, ByVal strBuffer, dwSize
RegCloseKey hKey
End If
Dim strArray() As String
strArray = Split(Left(strBuffer, InStr(strBuffer, vbNullChar) - 1), ",")
PrinterName = strArray(0)
DriverName = strArray(1)
PortName = strArray(2)
Else
PrinterName = mPrinter.DeviceName '?????
DriverName = mPrinter.DriverName '???????
End If
'?????DC
If IsOpen Then
ClosePrinter
Err.Raise &H80049902, TypeNameOfMe, "????????"
End If
mPrinterHDC = CreateDC(DriverName, PrinterName, 0, ByVal 0&)
If mPrinterHDC <> API_NULL Then 'API_NULL=0??????
IsOpen = True
mScreenPrinterRatio = Screen.TwipsPerPixelX / Printer.TwipsPerPixelX '???/?? dpi??,???,????.
Dim di As DOCINFO, mdocname As String '?????????
If docName = vbNullString Then docName = App.EXEName
di.cbSize = Len(di)
mdocname = docName
di.lpszDocName = StrPtr(mdocname)
If StartDoc(mPrinterHDC, di) <= 0 Then '??????
If Err.LastDllError = ERROR_CANCELLED Then
ClosePrinter
IsOpen = False
Exit Function
Else
ClosePrinter
Err.Raise &H80049912, TypeNameOfMe, "???? error " & CStr(Err.LastDllError)
End If
End If
StartedDoc = True
StartPage mPrinterHDC '??
StartedPage = True
Else
Err.Raise &H80049912, TypeNameOfMe, "CreateDC error " & CStr(Err.LastDllError)
IsOpen = False
End If
CreatPrinter = IsOpen
End Function
Public Function SetPrinterFont() As Boolean '???????
Dim hDesktopDC As Long
Dim fot As SIZE
If IsOpen = False Then '??????????.?????????
MsgBox "????creatprinter??.??????,??????"
Exit Function
End If
If TypeName(mPriviewPictureObj) = "PictureBox" Then
If mSetPrinterFont = True Then
hOldFont = SelectObject(mPrinterHDC, hOldFont) '????????,???????
mSetPrinterFont = False
End If
'hDesktopDC = GetDC(0) '????DC
'hFont = CreateFont(-MulDiv(mPicuture.font.SIZE, GetDeviceCaps(hDesktopDC, LOGPIXELSY), 72), 0, 0, 0, 0, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, mPriviewPictureObj.font.Name)
'ReleaseDC 0, hDesktopDC
'Debug.Print "mPicuture???????????=" & MulDiv(mPicuture.font.SIZE, GetDeviceCaps(hDesktopDC, LOGPIXELSY), 72) '????.????????????????
' ?????????
fot = GetTextSize("a", mPriviewPictureObj.font) '??mPicture???font ????.????
Debug.Print "???????::" & mPriviewPictureObj.font.Name & "???" & mPriviewPictureObj.font.SIZE & " ?????????? = " & fot.cy '?????????"
Debug.Print "??????:" & mPriviewPictureObj.TextHeight("?")
'fot.cy = mPriviewPictureObj.TextHeight("a")
If mPriviewPictureObj.font.Underline = True Then
hFont = CreateFont(-fot.cy, 0, 0, 0, 0, 0, 1, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, mPriviewPictureObj.font.Name)
Else
hFont = CreateFont(-fot.cy, 0, 0, 0, 0, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, mPriviewPictureObj.font.Name)
End If
mFontHeight = fot.cy ' MulDiv(mPicuture.font.SIZE, GetDeviceCaps(hDesktopDC, LOGPIXELSY), 72) '??????DPI?????? ?????
'???????????,????????.???? mFontHeight??????.???????????
'????????DC
hOldFont = SelectObject(mPrinterHDC, hFont)
mSetPrinterFont = True
Else
MsgBox "????????,????????????????."
mSetPrinterFont = False
End If
SetPrinterFont = mSetPrinterFont
End Function
Public Sub SetPapleSize(mPapleSize As PageSize, _
mPageDirection As PageDirection) '????????
'??: mPageDirection (PageDirection) ?????1=?????2=????
'???????????
Dim x As Long, y As Long
Dim PrinterWeith As Single, PrinterHeight As Single '?????????
Dim xLogPixperInch As Long, yLogPixPerInch As Long
Dim PixperInch As Long '????DPI
Dim hdc0 As Long
If mSetPrinterFont = False Then
MsgBox "?????,????SetPrinterFont??,??????."
Exit Sub
End If
hdc0 = GetDC(0) '???????DC
PixperInch = GetDeviceCaps(hdc0, LOGPIXELSX) '?????DPI 96
x = GetSystemMetrics(SM_CXSCREEN) '????????x????
y = GetSystemMetrics(SM_CYSCREEN) '????????y????
SetMapMode mPrinterHDC, MM_ANISOTROPIC '????????
SetWindowExtEx mPrinterHDC, x, y, ByVal 0& '?????? ???????????????????????? .??????
xLogPixperInch = GetDeviceCaps(mPrinterHDC, LOGPIXELSX) '????DPI ????????????
yLogPixPerInch = GetDeviceCaps(mPrinterHDC, LOGPIXELSY)
If mPageDirection = 1 Then
Select Case mPapleSize
Case A4
PrinterWeith = CSng(21#) '?cm
PrinterHeight = CSng(29.7) '??cm
Case A5
PrinterWeith = CSng(14.8) '?cm
PrinterHeight = CSng(21#) '??cm
End Select
Else '??
Select Case mPapleSize
Case A4
PrinterWeith = CSng("29.7") '?cm
PrinterHeight = CSng("21.0") '??cm
Case A5
PrinterWeith = CSng("21. 0") '?cm
PrinterHeight = CSng("14.8") '??cm
End Select
End If
mPrinterWidthPix = xLogPixperInch * PrinterWeith \ 2.54 '(x / PixperInch) '???????? 1??=1440?,1??=2.54cm
mPrinterheightPix = yLogPixPerInch * PrinterHeight \ 2.54 '(y / PixperInch)
SetViewportExtEx mPrinterHDC, mPrinterWidthPix, mPrinterheightPix, 0 '??????() ?????????X??Y???,???????.
'SetViewportExtEx?SetWindowExtEx? ?????
'??????????????
'??????????
'????
Device2LogicRatioX = mPrinterWidthPix / x '????/????
Device2LogicRatioY = mPrinterheightPix / y
CurrentBottom = (mPrinterheightPix / yLogPixPerInch * PixperInch - mBottomMargin)
mprinterCurrentY = mTopMargin '???????
IsSetPapleSize = True
End Sub
-
Re: [VB6] UPrinter - Unicode Printer Class
Code:
Public Sub PrintTxt(x As Long, y As Long, Txt As String, Optional ByVal PrintOrPriview As Boolean = True, Optional ByVal txtcolor As OLE_COLOR = vbBlack, Optional ByVal ???? As AlignmentConstants = vbLeftJustify) '???? ???????? ????????
Const TA_BASELINE = 24
Const TA_BOTTOM = 8
Const TA_CENTER = 6
Const TA_LEFT = 0
Const TA_NOUPDATECP = 0
Const TA_RIGHT = 2
Const TA_TOP = 0
Const TA_UPDATECP = 1
Const TA_MASK = (TA_BASELINE + TA_CENTER + TA_UPDATECP)
If Not IsOpen Then Err.Raise &H80049900, TypeNameOfMe, "UPrinter not open"
'TextOut ???dc?x,y???????? ,??????????.x *????/????
'x?????.x*screen.Screen.TwipsPerPixelX/Printer.TwipsPerPixelX??????????????,???????DPI???,????????????,???????.
Static n As Long
n = n + 1
If PrintOrPriview = True Then '??????
If (mprinterCurrentY + mFontHeight) / Device2LogicRatioY * mScreenPrinterRatio >= CurrentBottom Then
Debug.Print n
NewPage
y = mprinterCurrentY
End If
'???????
If Txt <> "" Then '??txt??????
Dim tmpX As Long
tmpX = GetTextSize(Txt, mPriviewPictureObj.font).cx
' x = x + tmpX 'GetTextSize(Txt, mPriviewPictureObj.font).cx '?????????
' x = x + mPriviewPictureObj.TextWidth(Txt) '?????????
'??????
Dim oldColor As OLE_COLOR
oldColor = SetTextColor(mPrinterHDC, txtcolor)
If oldColor = CLR_INVALID Then MsgBox "??????"
'????????:
SetTextAlign mPrinterHDC, TA_LEFT Or TA_TOP
Select Case ????
Case vbLeftJustify
x = x + LeftMargin
Case vbCenter
x = (mPrinterWidthPix / mScreenPrinterRatio - tmpX - LeftMargin - RightMargin) / 2
Case vbRightJustify
x = mPrinterWidthPix / mScreenPrinterRatio - tmpX - RightMargin
End Select
TextOut mPrinterHDC, x / Device2LogicRatioX * mScreenPrinterRatio, y / Device2LogicRatioY * mScreenPrinterRatio, Txt, LenB(StrConv(Txt, vbFromUnicode)) 'TextOut ???dc?x,y???????? ,??????????.20 *????/????
SetTextColor mPrinterHDC, oldColor
'Restore the original font and delete the newly created font
mprinterCurrentX = x + tmpX
mprinterCurrentY = (y + mFontHeight)
Else
mprinterCurrentX = x
mprinterCurrentY = (y + mFontHeight)
End If
Else
'??????
RaiseEvent PrinterPriview(x, y, Txt, PrintOrPriview, txtcolor, ????)
End If
End Sub
Private Function pDrawBarText(hdc As Long, _
sX As Long, _
sY As Long, _
mFont As StdFont, _
crColor As OLE_COLOR, _
Direction As Integer, _
OutText As String) As Long
Dim lf As LOGFONT
Dim hPrevFont As Long
Dim hNewFont As Long
Dim oldColor As OLE_COLOR
Dim rtn As Long
Const TA_BASELINE = 24
Const TA_BOTTOM = 8
Const TA_CENTER = 6
Const TA_LEFT = 0
Const TA_NOUPDATECP = 0
Const TA_RIGHT = 2
Const TA_TOP = 0
Const TA_UPDATECP = 1
Const TA_MASK = (TA_BASELINE + TA_CENTER + TA_UPDATECP)
'Create the new font with selected font attributes
With lf
.lfFaceName = mFont.Name & vbNullChar
.lfHeight = -MulDiv((mFont.SIZE), GetDeviceCaps(hdc, LOGPIXELSY), 72)
.lfItalic = IIf(mFont.Italic, 1, 0)
.lfWeight = IIf(mFont.Bold, 700, 400)
.lfUnderline = IIf(mFont.Underline, 1, 0)
.lfEscapement = Direction * 10
End With
'Create the new font
hNewFont = CreateFontIndirect(lf)
If hNewFont = 0 Then GoTo Err_Handler
'Select the new font
hPrevFont = SelectObject(hdc, hNewFont)
If hPrevFont = 0 Then GoTo Err_Handler
'Set the font Color and save the original Color
oldColor = SetTextColor(hdc, crColor)
If oldColor = CLR_INVALID Then GoTo Err_Handler
SetTextAlign hdc, TA_LEFT Or TA_TOP
'Output the text
rtn = TextOutA(hdc, sX, sY, OutText, Len(OutText))
If rtn = 0 Then GoTo Err_Handler
'Restore the old text Color
rtn = SetTextColor(hdc, oldColor)
'Restore the original font and delete the newly created font
rtn = DeleteObject(SelectObject(hdc, hPrevFont))
pDrawBarText = rtn
Exit Function
Err_Handler:
pDrawBarText = 0
End Function
Public Sub NewPage() '??????
If Not IsOpen Then
Err.Raise &H80049900, TypeNameOfMe, "???????"
End If
'We're open, so StartedPage is known to be True here:
EndPage mPrinterHDC ''??
StartPage mPrinterHDC
mprinterCurrentY = mTopMargin
End Sub
Public Sub ClosePrinter()
Dim hFontPrev As Long
If IsOpen Then
hFontPrev = SelectObject(mPrinterHDC, hOldFont) ''?????DC????
DeleteObject hFontPrev ''???????
If StartedPage Then
EndPage mPrinterHDC
StartedPage = False
End If
If StartedDoc Then
EndDoc mPrinterHDC
StartedDoc = False
End If
DeleteDC mPrinterHDC ''?????DC
IsOpen = False
End If
End Sub
Public Function KillDoc() As Boolean '??????
'Returns False on failure.
If Not IsOpen Then
Err.Raise &H80049900, TypeNameOfMe, "???????"
End If
KillDoc = AbortDoc(mPrinterHDC) <> SP_ERROR
ClosePrinter
End Function
Private Sub Class_Initialize()
TypeNameOfMe = TypeName(Me)
End Sub
Code:
Option Explicit
Private Declare Function CreateDC _
Lib "gdi32.dll" _
Alias "CreateDCA" (ByVal lpDriverName As String, _
ByVal lpDeviceName As String, _
ByVal lpOutput As String, _
lpInitData As Long) As Long
Private Declare Function CreateCompatibleBitmap _
Lib "gdi32.dll" (ByVal hdc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
Private Declare Function CreateFontIndirect _
Lib "gdi32.dll" _
Alias "CreateFontIndirectW" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject _
Lib "gdi32.dll" (ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetTextExtentPoint32 _
Lib "gdi32.dll" _
Alias "GetTextExtentPoint32W" (ByVal hdc As Long, _
ByVal lpsz As String, _
ByVal cbString As Long, _
lpSize As SIZE) As Long
Private Declare Function MulDiv _
Lib "kernel32.dll" (ByVal nNumber As Long, _
ByVal nNumerator As Long, _
ByVal nDenominator As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps _
Lib "gdi32.dll" (ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Const LOGPIXELSY As Long = 90
Public Type SIZE
cx As Long '????
cy 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
'
' Measures the size in pixels of a string, given a particular font. This uses
' the GetTextExtentPoint32 API to measure the string. The API is defined as
' follows:
'
' GetTextExtendPoint(ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE)
'
' hdc: The device context which is attached to the font to be used
' lpsz: The string to measure, based on the font contained in the hdc specified
' cbString: The length of the string which was passed in 'lpsz'
' lpSize: The SIZE structure which the measurements will be returned to
'
Public Function GetTextSize(text As String, font As StdFont) As SIZE
Dim tempDC As Long
Dim tempBMP As Long
Dim f As Long
Dim lf As LOGFONT
Dim textSize As SIZE
'
' Create a device context and a bitmap that can be used to store a
' temporary font object
'
tempDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0)
tempBMP = CreateCompatibleBitmap(tempDC, 1, 1)
'
' Assign the bitmap to the device context
'
DeleteObject SelectObject(tempDC, tempBMP)
'
' Set up the LOGFONT structure and create the font
'
lf.lfFaceName = font.Name & Chr$(0)
lf.lfHeight = -MulDiv(font.SIZE, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72)
lf.lfItalic = font.Italic
lf.lfStrikeOut = font.Strikethrough
lf.lfUnderline = font.Underline
If font.Bold Then lf.lfWeight = 800 Else lf.lfWeight = 400
f = CreateFontIndirect(lf)
'
' Assign the font to the device context
'
DeleteObject SelectObject(tempDC, f)
'
' Measure the text, and return it into the textSize SIZE structure
'
GetTextExtentPoint32 tempDC, text, Len(text), textSize
'
' Clean up (very important to avoid memory leaks!)
'
DeleteObject f
DeleteObject tempBMP
DeleteDC tempDC
'
' Return the measurements
'
GetTextSize = textSize
End Function
-
Re: [VB6] UPrinter - Unicode Printer Class
Code:
Private Sub cmdPrint_Click()
Dim i As Long
Dim prtItem As Printer
Dim UPrinter As PrinterHelpX
Dim Utf8Reader As Utf8Reader
Dim TextLine As String
Dim ratio As Long
lstPrinters.Enabled = False
cmdPrint.Enabled = False
lblStatus.Caption = "Opening..."
lblStatus.Refresh
Set UPrinter = New PrinterHelpX
'Printers collection is not directly addressable so find the selected one:
For Each prtItem In Printers
If i = lstPrinters.ListIndex Then Exit For
i = i + 1
Next
' ratio = Screen.TwipsPerPixelX / prtItem.TwipsPerPixelX
Set UPrinter.PriviewPictureObj = Picture1
'Use this Printer object to get the required parameters for OpenPrinter:
With prtItem
If Not UPrinter.CreatPrinter(prtItem, "??") Then
lblStatus.Caption = "Canceled!"
Exit Sub
End If
End With
lblStatus.Caption = "Printing..."
DoEvents
Set Utf8Reader = New Utf8Reader
With UPrinter
.TopMargin = ScaleY(1, vbInches, vbPixels)
.BottomMargin = ScaleY(0.5, vbInches, vbPixels)
.LeftMargin = ScaleX(0.25, vbInches, vbPixels)
.RightMargin = ScaleX(0.125, vbInches, vbPixels)
.TabLength = 16
'CAUTION!
'
'Some printer drivers that print to a disk file may alter the current
'directory of the process before you get here (i.e. when you call
'OpenPrinter() as above).
'Get some Unicode data from a UTF-8 encoded file:
Utf8Reader.OpenFile App.Path & "\Utf8.txt", vbLf
'Print heading line.
UPrinter.PriviewPictureObj.FontName = "??" 'Unicode?? "??"
UPrinter.PriviewPictureObj.FontSize = 16
' UPrinter.PriviewPictureObj.FontUnderline = True
UPrinter.SetPrinterFont
.SetPapleSize A4, ??
TextLine = Utf8Reader.ReadLine()
UPrinter.FontHeight = UPrinter.FontHeight + 10 '????1o
UPrinter.PrintTxt .LeftMargin, .TopMargin, "???????", True, vbRed, vbCenter
UPrinter.PrintTxt .LeftMargin, .PrinterCurrentY, "", True
'Print data.
' UPrinter.PriviewPictureObj.FontUnderline = False
' UPrinter.SetPrinterFont
Do Until Utf8Reader.EOF
TextLine = Utf8Reader.ReadLine()
'Print each line twice, we want to test page overflows:
.PrintTxt .LeftMargin, .PrinterCurrentY, Join$(ParseCSV(TextLine), vbTab), True
.PrintTxt .LeftMargin, .PrinterCurrentY, Join$(ParseCSV(TextLine), vbTab), True
Loop
Dim x As Long, y As Long
x = ucImage1.Parent.ScaleX(ucImage1.PictureWidth, vbPixels, vbTwips)
y = ucImage1.Parent.ScaleY(ucImage1.PictureHeight, vbPixels, vbTwips)
'ucImage1.PaintPicture .PrinterDC, .LeftMargin / ratio, -.TopMargin / ratio - ucImage1.PictureHeight * ratio, ucImage1.PictureWidth * ratio, ucImage1.PictureHeight * ratio, 0, 0, ucImage1.PictureWidth, ucImage1.PictureHeight
ucImage1.PaintPicture .PrinterHDC, .LeftMargin / .Device2LogicRatioX, .TopMargin / .Device2LogicRatioY, ucImage1.PictureWidth / .Device2LogicRatioX, ucImage1.PictureHeight / .Device2LogicRatioY
Utf8Reader.CloseFile
.ClosePrinter
End With
lblStatus.Caption = "Done"
End Sub
Module : ucImage if form leandroascierto you can find in forum
' DateTime : 04/03/2008 11:00
' Author : Cobein
