Printform

I have a form that is containing a image control and ý want to print this form as scaled to printer (fitted to page). How can i do this?

Thank you
itacanAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

caraf_gCommented:
You'll have to capture the image off the screen, and then scale the resulting picture before printing it. PrintForm won't do it for you.

PS - you posted this question twice; you can delete
http://oldlook.experts-exchange.com/Computers/Programming/Windows/Visual_Basic/Q_10229544.html

If you think your browser has crashed on you it is always worth checking before resubmitting. ;-)
0
caraf_gCommented:
with thanks to cip

Try this code:

Type BITMAPINFOHEADER
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
End Type

Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type

Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors As RGBQUAD
End Type

Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Type POINTAPI
        x As Long
        y As Long
End Type

Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Declare Function StretchDIBits Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal wSrcWidth As Long, ByVal wSrcHeight As Long, lpBits As Any, lpBitsInfo As BITMAPINFO, ByVal wUsage As Long, ByVal dwRop As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long

Const HORZRES = 8
Const VERTRES = 10

Const SRCCOPY = &HCC0020
Const NEWFRAME = 1
Const BITSPIXEL = 12
Const PLANES = 14

Const BI_RGB = 0
Const BI_RLE8 = 1
Const BI_RLE4 = 2

Const DIB_PAL_COLORS = 1
Const DIB_RGB_COLORS = 0

Const GMEM_MOVEABLE = 2


Function PrintClient(ByVal hDC_Dest, ByVal DestX, ByVal DestY, ByVal DestDevWidth, ByVal DestDevHeight, ByVal hWnd_SrcWindow)
   Dim Rec As RECT, RecClient As RECT
   Dim bmpinfo As BITMAPINFO
   Dim pWindow As POINTAPI, pClient As POINTAPI, pDiff As POINTAPI
   Dim r As Long, r1 As Long, r2 As Long

   hDC_Window = GetWindowDC(hWnd_SrcWindow)
   hDC_Mem = CreateCompatibleDC(hDC_Window)

   ScreenWidth = GetDeviceCaps(hDC_Window, HORZRES)
   ScreenHeight = GetDeviceCaps(hDC_Window, VERTRES)

   r = GetWindowRect(hWnd_SrcWindow, Rec)
   Window_Width = Abs(Rec.Right - Rec.Left)
   Window_Height = Abs(Rec.Bottom - Rec.Top)

   hBmp_Window = CreateCompatibleBitmap(hDC_Window, Window_Width, Window_Height)

   hPrevBmp = SelectObject(hDC_Mem, hBmp_Window)

   r1 = BitBlt(hDC_Mem, 0, 0, Window_Width, Window_Height, hDC_Window, 0, 0, SRCCOPY)

   r = GetClientRect(hWnd_SrcWindow, RecClient)
   Client_Width = Abs(RecClient.Right - RecClient.Left)
   Client_Height = Abs(RecClient.Bottom - RecClient.Top)

   pClient.x = RecClient.Left
   pClient.y = RecClient.Top
   r = ClientToScreen(hWnd_SrcWindow, pClient)

   xDiff = Abs(pClient.x - Rec.Left)
   yDiff = Abs(pClient.y - Rec.Top)

   hDC_MemClient = CreateCompatibleDC(hDC_Window)

   hBmp_Client = CreateCompatibleBitmap(hDC_Window, Client_Width, Client_Height)

   hBmpClientPrev = SelectObject(hDC_MemClient, hBmp_Client)

   r = BitBlt(hDC_MemClient, 0, 0, Client_Width, Client_Height, hDC_Mem, xDiff, yDiff, SRCCOPY)

   BitsPerPixel = GetDeviceCaps(hDC_MemClient, BITSPIXEL)
   ColorPlanes = GetDeviceCaps(hDC_MemClient, PLANES)

   bmpinfo.bmiHeader.biSize = 40
   bmpinfo.bmiHeader.biWidth = Client_Width
   bmpinfo.bmiHeader.biHeight = Client_Height
   bmpinfo.bmiHeader.biPlanes = 1
   bmpinfo.bmiHeader.biBitCount = BitsPerPixel * ColorPlanes
   bmpinfo.bmiHeader.biCompression = BI_RGB
   bmpinfo.bmiHeader.biSizeImage = 0
   bmpinfo.bmiHeader.biXPelsPerMeter = 0
   bmpinfo.bmiHeader.biYPelsPerMeter = 0
   bmpinfo.bmiHeader.biClrUsed = 0
   bmpinfo.bmiHeader.biClrImportant = 0

   WidthRatio! = Client_Width / ScreenWidth
   HeightAspectRatio! = Client_Height / Client_Width

   PrintWidth = WidthRatio! * DestDevWidth
   PrintHeight = HeightAspectRatio! * PrintWidth

   BytesNeeded& = (CLng(Window_Width + 3) \ 4) * 4 * Window_Height * (BitsPerPixel / 8)

   hMem = GlobalAlloc(GMEM_MOVEABLE, BytesNeeded&)

   If hDC_Window <> 0 And hBmp_Window <> 0 And hDC_Dest <> 0 And hMem <> 0 Then
      lpBits& = GlobalLock(hMem)
      r2 = GetDIBits(hDC_MemClient, hBmp_Client, 0, Client_Height, ByVal lpBits&, bmpinfo, DIB_RGB_COLORS)
      r3 = StretchDIBits(hDC_Dest, DestX, DestY, PrintWidth, PrintHeight, 0, 0, Client_Width, Client_Height, ByVal lpBits&, bmpinfo, DIB_RGB_COLORS, SRCCOPY)
   End If

   r = SelectObject(hDC_MemClient, hBmpClientPrev)
   r = DeleteObject(hBmp_Client)
   r = DeleteDC(hDC_MemClient)

   r = SelectObject(hDC_Mem, hPrevBmp)
   r = DeleteObject(hBmp_Window)
   r = DeleteDC(hDC_Mem)

   r = ReleaseDC(hWnd_SrcWindow, hDC_Window)

   r = GlobalUnlock(hMem)
   r = GlobalFree(hMem)

   If r2 <> 0 And r3 <> 0 Then
      PrintClient = True
   Else
      PrintClient = False
   End If

End Function


Private Sub Command1_Click()
    Dim r As Integer
     
    Screen.MousePointer = 11

    ' Init printer
    Printer.Print "" 
     
    ' The ScaleMode must be set to pixels for the PrintWindow
    ' routine to print correctly.
    Printer.ScaleMode = 3
     
    r = PrintClient2(Printer.hdc, 100, 100, Printer.ScaleWidth * 2, Printer.ScaleHeight * 2, me.hwnd)

    If Not r Then
       MsgBox "Unable to print the form"
   Else
       Printer.EndDoc
    End If

    Screen.MousePointer = 0
End Sub

PrintClient prints any window client area, if you want to print the button try passing
comman1.hwnd instead of me.hwnd.

You can change position on printer changing the DestX, DestY parameters, or stretch the form changing the DestDevWidth and DestDevHeight parameters.

0
caraf_gCommented:
Hm.... I checked out cip's code and it was a bit buggy. So I fixed it for you.


OK, second attempt. Simply start a new project and dump a command button on the form. Then paste in the following code:

Option Explicit
Private Type BITMAPINFOHEADER
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
End Type

Private Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type

Private Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors As RGBQUAD
End Type

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Type POINTAPI
        x As Long
        y As Long
End Type

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function StretchDIBits Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal wSrcWidth As Long, ByVal wSrcHeight As Long, lpBits As Any, lpBitsInfo As BITMAPINFO, ByVal wUsage As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long

Private Const HORZRES = 8
Private Const VERTRES = 10

Private Const SRCCOPY = &HCC0020
Private Const NEWFRAME = 1
Private Const BITSPIXEL = 12
Private Const PLANES = 14

Private Const BI_RGB = 0
Private Const BI_RLE8 = 1
Private Const BI_RLE4 = 2

Private Const DIB_PAL_COLORS = 1
Private Const DIB_RGB_COLORS = 0

Private Const GMEM_MOVEABLE = 2
Private Enum StretchMode
    Proportional = 0
    Full = 1
End Enum

Private Function PrintWindow(ByVal hDC_Dest, _
                             ByVal DestX, _
                             ByVal DestY, _
                             ByVal DestDevWidth, _
                             ByVal DestDevHeight, _
                             ByVal hWnd_SrcWindow, _
                             ByVal enuStretch As StretchMode)
   Dim Rec As RECT, RecClient As RECT
   Dim bmpinfo As BITMAPINFO
   Dim pWindow As POINTAPI, pClient As POINTAPI, pDiff As POINTAPI
   Dim r As Long, r1 As Long, r2 As Long, r3 As Long
   Dim hDc_Window As Long
   Dim hDc_Mem As Long
   Dim ScreenWidth As Long
   Dim ScreenHeight As Long
   Dim Window_Width As Long
   Dim Window_Height As Long
   Dim hBmp_Window As Long
   Dim hPrevBmp As Long
   Dim Client_Width As Long
   Dim Client_Height As Long
   Dim xDiff As Long
   Dim yDiff As Long
   Dim hDc_MemClient As Long
   Dim hBmp_Client As Long
   Dim hBmpClientPrev As Long
   Dim BitsPerPixel As Long
   Dim ColorPlanes As Long
   Dim WidthRatio As Single
   Dim HeightAspectRatio As Single
   Dim BytesNeeded As Long
   Dim PrintWidth As Long
   Dim PrintHeight As Long
   Dim hMem As Long
   Dim lpBits As Long

   hDc_Window = GetWindowDC(hWnd_SrcWindow)
   hDc_Mem = CreateCompatibleDC(hDc_Window)

   ScreenWidth = GetDeviceCaps(hDc_Window, HORZRES)
   ScreenHeight = GetDeviceCaps(hDc_Window, VERTRES)

   r = GetWindowRect(hWnd_SrcWindow, Rec)
   Window_Width = Abs(Rec.Right - Rec.Left)
   Window_Height = Abs(Rec.Bottom - Rec.Top)

   hBmp_Window = CreateCompatibleBitmap(hDc_Window, Window_Width, Window_Height)

   hPrevBmp = SelectObject(hDc_Mem, hBmp_Window)

   r1 = BitBlt(hDc_Mem, 0, 0, Window_Width, Window_Height, hDc_Window, 0, 0, SRCCOPY)

   r = GetClientRect(hWnd_SrcWindow, RecClient)
   Client_Width = Abs(RecClient.Right - RecClient.Left)
   Client_Height = Abs(RecClient.Bottom - RecClient.Top)

   pClient.x = RecClient.Left
   pClient.y = RecClient.Top
   r = ClientToScreen(hWnd_SrcWindow, pClient)

   xDiff = Abs(pClient.x - Rec.Left)
   yDiff = Abs(pClient.y - Rec.Top)

   hDc_MemClient = CreateCompatibleDC(hDc_Window)

   'hBmp_Client = CreateCompatibleBitmap(hDc_Window, Client_Width, Client_Height)
   hBmp_Client = CreateCompatibleBitmap(hDc_Window, Window_Width, Window_Height)
   
   hBmpClientPrev = SelectObject(hDc_MemClient, hBmp_Client)

   'r = BitBlt(hDc_MemClient, 0, 0, Client_Width, Client_Height, hDc_Mem, xDiff, yDiff, SRCCOPY)
   r = BitBlt(hDc_MemClient, 0, 0, Window_Width, Window_Height, hDc_Mem, 0, 0, SRCCOPY)
   
   BitsPerPixel = GetDeviceCaps(hDc_MemClient, BITSPIXEL)
   ColorPlanes = GetDeviceCaps(hDc_MemClient, PLANES)

   bmpinfo.bmiHeader.biSize = 40
   'bmpinfo.bmiHeader.biWidth = Client_Width
   bmpinfo.bmiHeader.biWidth = Window_Width
   'bmpinfo.bmiHeader.biHeight = Client_Height
   bmpinfo.bmiHeader.biHeight = Window_Height
   bmpinfo.bmiHeader.biPlanes = 1
   bmpinfo.bmiHeader.biBitCount = BitsPerPixel * ColorPlanes
   bmpinfo.bmiHeader.biCompression = BI_RGB
   bmpinfo.bmiHeader.biSizeImage = 0
   bmpinfo.bmiHeader.biXPelsPerMeter = 0
   bmpinfo.bmiHeader.biYPelsPerMeter = 0
   bmpinfo.bmiHeader.biClrUsed = 0
   bmpinfo.bmiHeader.biClrImportant = 0

    Select Case enuStretch
    Case StretchMode.Full
        WidthRatio = 1
    Case StretchMode.Proportional
        'WidthRatio = Client_Width / ScreenWidth
        WidthRatio = Window_Width / ScreenWidth
    End Select
   'HeightAspectRatio = Client_Height / Client_Width
   HeightAspectRatio = Window_Height / Window_Width

   PrintWidth = WidthRatio * DestDevWidth
   PrintHeight = HeightAspectRatio * PrintWidth

   BytesNeeded& = (CLng(Window_Width + 3) \ 4) * 4 * Window_Height * (BitsPerPixel / 8)

   hMem = GlobalAlloc(GMEM_MOVEABLE, BytesNeeded&)

   If hDc_Window <> 0 And hBmp_Window <> 0 And hDC_Dest <> 0 And hMem <> 0 Then
      lpBits& = GlobalLock(hMem)
      'r2 = GetDIBits(hDc_MemClient, hBmp_Client, 0, Client_Height, ByVal lpBits&, bmpinfo, DIB_RGB_COLORS)
      r2 = GetDIBits(hDc_MemClient, hBmp_Client, 0, Window_Height, ByVal lpBits&, bmpinfo, DIB_RGB_COLORS)
      'r3 = StretchDIBits(hDC_Dest, DestX, DestY, PrintWidth, PrintHeight, 0, 0, Client_Width, Client_Height, ByVal lpBits&, bmpinfo, DIB_RGB_COLORS, SRCCOPY)
      r3 = StretchDIBits(hDC_Dest, DestX, DestY, PrintWidth, PrintHeight, 0, 0, Window_Width, Window_Height, ByVal lpBits&, bmpinfo, DIB_RGB_COLORS, SRCCOPY)
   End If

   r = SelectObject(hDc_MemClient, hBmpClientPrev)
   r = DeleteObject(hBmp_Client)
   r = DeleteDC(hDc_MemClient)

   r = SelectObject(hDc_Mem, hPrevBmp)
   r = DeleteObject(hBmp_Window)
   r = DeleteDC(hDc_Mem)

   r = ReleaseDC(hWnd_SrcWindow, hDc_Window)

   r = GlobalUnlock(hMem)
   r = GlobalFree(hMem)

   If r2 <> 0 And r3 <> 0 Then
      PrintWindow = True
   Else
      PrintWindow = False
   End If

End Function


Private Sub Command1_Click()
    Dim r As Integer
     
    'Me.PrintForm
   
    Screen.MousePointer = vbHourglass

    'Full Page
    ' Init printer
    Printer.Print ""
     
    ' The ScaleMode must be set to pixels for the PrintWindow
    ' routine to print correctly.
    Printer.ScaleMode = 3
   
    r = PrintWindow(Printer.hdc, _
                   Printer.ScaleLeft, _
                   Printer.ScaleTop, _
                   Printer.ScaleWidth, _
                   Printer.ScaleHeight, _
                   Me.hwnd, _
                   StretchMode.Full)
   
    If Not r Then
       MsgBox "Unable to print the form"
    Else
       Printer.EndDoc
    End If

    Screen.MousePointer = vbDefault
End Sub


The PrintWindow Sub now expects a stretch parameter. If set to full, it stretches the picture to fill the whole page of your printer, if set to Proportional it stretches the picture so it occupies the same width on your printer page as the form on your screen.

Good luck!

Pino
0
The Ultimate Tool Kit for Technolgy Solution Provi

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy for valuable how-to assets including sample agreements, checklists, flowcharts, and more!

itacanAuthor Commented:
I tried this code but giving an error : unable to print the form.
Additionally, when this code work, can i print other objects on the for like a label or a button? Like printform command?

Thank you
0
AndySulzCommented:
printer.print form1
form1.print
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
caraf_gCommented:
Hi Andy,

Please stop providing "answers" in the hope that the auto-grading feature will kick in.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.