Results 1 to 23 of 23

Thread: [VB6] UPrinter - Unicode Printer Class

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    Post [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.


    Name:  sshot.jpg
Views: 4200
Size:  51.2 KB


    Updates:

    New version replaces the earlier attachment here. A few small bug fixes, added properties TopMargin and BottomMargin and method KillDoc.
    Attached Files Attached Files
    Last edited by dilettante; Apr 23rd, 2014 at 08:52 PM. Reason: updates

  2. #2

    Thread Starter
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    Re: [VB6] UPrinter - Unicode Printer Class

    I should have mentioned: the archive has the sample data file in it.

  3. #3
    Frenzied Member
    Join Date
    Jan 2010
    Posts
    1,103

    Re: [VB6] UPrinter - Unicode Printer Class

    Quote Originally Posted by dilettante View Post
    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
    Last edited by Jonney; Apr 23rd, 2014 at 10:38 PM.

  4. #4

    Thread Starter
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    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.

  5. #5
    Frenzied Member
    Join Date
    Jan 2010
    Posts
    1,103

    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?
    Last edited by Jonney; Apr 13th, 2015 at 06:55 AM.

  6. #6

    Thread Starter
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    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.

  7. #7
    Frenzied Member
    Join Date
    Jan 2010
    Posts
    1,103

    Re: [VB6] UPrinter - Unicode Printer Class

    Quote Originally Posted by dilettante View Post
    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.
    Last edited by Jonney; Apr 14th, 2015 at 03:53 AM.

  8. #8
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    673

    Re: [VB6] UPrinter - Unicode Printer Class

    Quote Originally Posted by dilettante View Post
    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.


    Name:  sshot.jpg
Views: 4200
Size:  51.2 KB


    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.


    Name:  1.JPG
Views: 2465
Size:  35.8 KB


    Name:  2.JPG
Views: 2391
Size:  22.7 KB

    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
    Name:  96.JPG
Views: 2294
Size:  56.7 KBName:  2400.JPG
Views: 2332
Size:  58.5 KB
    'sets the unit of measure for this Graphics object from UnitDisplay to UnitPixel
    GdipSetPageUnit hGraphics, UnitPixel
    GdipSetSmoothingMode hGraphics, SmoothingModeAntiAlias
    Last edited by xxdoc123; Mar 5th, 2018 at 11:20 PM. Reason: load pic

  9. #9
    Addicted Member
    Join Date
    May 2016
    Location
    China
    Posts
    197

    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.

  10. #10
    Addicted Member
    Join Date
    May 2016
    Location
    China
    Posts
    197

    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

  11. #11

    Thread Starter
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    Re: [VB6] UPrinter - Unicode Printer Class

    Quote Originally Posted by xxdoc123 View Post
    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.

  12. #12
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    673

    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

  13. #13
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    673

    Re: [VB6] UPrinter - Unicode Printer Class

    why.you use 2.5?呵呵。

  14. #14
    Addicted Member
    Join Date
    May 2016
    Location
    China
    Posts
    197

    Re: [VB6] UPrinter - Unicode Printer Class

    ucImage1.Width / ucImage1.PictureWidth - (Screen.TwipsPerPixelX / Printer.TwipsPerPixelX * 2)
    我的QQ 289778005

  15. #15

    Thread Starter
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    Re: [VB6] UPrinter - Unicode Printer Class

    New version.
    Attached Files Attached Files

  16. #16
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    673

    Re: [VB6] UPrinter - Unicode Printer Class

    Quote Originally Posted by dilettante View Post
    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?
    Last edited by xxdoc123; Feb 8th, 2018 at 07:25 PM.

  17. #17
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    673

    Re: [VB6] UPrinter - Unicode Printer Class

    Quote Originally Posted by dilettante View Post
    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.
    Attached Files Attached Files
    Last edited by xxdoc123; Mar 5th, 2018 at 11:24 PM.

  18. #18
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    673

    Re: [VB6] UPrinter - Unicode Printer Class

    Quote Originally Posted by xxdoc123 View Post
    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)

    UPrinter3.6.zip

  19. #19
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    673

    Re: [VB6] UPrinter - Unicode Printer Class

    Quote Originally Posted by dilettante View Post
    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.


    Name:  sshot.jpg
Views: 4200
Size:  51.2 KB


    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

  20. #20
    New Member
    Join Date
    Mar 2024
    Posts
    5

    Re: [VB6] UPrinter - Unicode Printer Class

    Quote Originally Posted by xxdoc123 View Post
    hi dilettante ,thank you post your uprinter cls ,is very useful for me

    now i print one png picture to the printreDC.


    Name:  1.JPG
Views: 2465
Size:  35.8 KB


    Name:  2.JPG
Views: 2391
Size:  22.7 KB

    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
    Name:  96.JPG
Views: 2294
Size:  56.7 KBName:  2400.JPG
Views: 2332
Size:  58.5 KB
    '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?

  21. #21
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    673

    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

  22. #22
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    673

    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

  23. #23
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    673

    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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width