Printing contents of a picture box

Good day!, im having a bit of a problem while printing controls that are inside a picture box. Im trying to print a Label, and an ocx, a barcode ocx to be exact. I've tried different methods already. One of them is trying to capture an image of the picture box but the result is unacceptable because the quality of the print is kinda rough. The other method is this one which was given to be by one of my friends

Code:

---

Printer.PaintPicture Picture1.Image, 0, 0
Printer.EndDoc

---

the problem is its not producing any print out.
my other workaround here is a pretty long method, its acceptable, but I know there's a way to it with less lines of code.

Thanks a lot for any suggestions! :)

I placed a picturebox on a form, along with a cmd btn
I added an image to my picturebox
I put your code in the cmd click event
And it printed just fine:

Printer.PaintPicture Picture1.Image, 0, 0
Printer.EndDoc

Ah, I see what you mean...I added a LABEL in lieu of an image...and it did not print the label. More research.......

Can you use this 'snapshot' routine to capture the portion of your form that has the picturebox on it, and then print it (instead of save as in this example)?

Code:

---

Option Explicit
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 GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "USER32" () As Long
Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC 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 CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicArray As Long, RefIID As Any, ByVal OwnsHandle As Long, IPic As Any) As Long
Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long

Private Declare Function GetSystemMetrics& Lib "USER32" (ByVal nIndex&)
Public imagefile As Image


Private Sub TakeSnapshot(imgLeft As Long, imgTop As Long, imgWidth As Long, imgHeight As Long, picFile As String)
    Dim hWndDesk As Long, hDCDesk As Long
    Dim myDC As Long, myBmp As Long, hOldBmp As Long
    'Get desktop window handle
    hWndDesk = GetDesktopWindow
    'Get desktop device context
    hDCDesk = GetDC(hWndDesk)
   
    'Create memory dc
    myDC = CreateCompatibleDC(hDCDesk)
    'Create memory bitmap
    myBmp = CreateCompatibleBitmap(hDCDesk, imgWidth, imgHeight)
   
    'Select the bitmap into dc replacing the old one.
    hOldBmp = SelectObject(myDC, myBmp)
   
    'Delete the original 1x1 monochrome bitmap
    'We dont need it
    DeleteObject hOldBmp
   
    'Copy the desired image from desktop dc to our mem dc
    BitBlt myDC, 0, 0, imgWidth, imgHeight, hDCDesk, imgLeft, imgTop, vbSrcCopy
   
    'Release the desktop dc
    ReleaseDC hWndDesk, hDCDesk
   
    'Convert the bitmap handle (myBmp)
    'into vb Picture object
    Dim pic As Object
    Dim P(0 To 4) As Long, G(0 To 15) As Byte
    G(1) = 4: G(2) = 2: G(8) = 192: G(15) = 70
    P(0) = 20: P(1) = vbPicTypeBitmap: P(2) = myBmp
    OleCreatePictureIndirect P(0), G(0), 1, pic
   
    'Save the picture to file
    SavePicture pic, picFile
    DoEvents
   
    'Deselect the memory bitmap from memory dc
    SelectObject myDC, 0
   
    'Delete memory bitmap
    DeleteObject myBmp
   
    'Delete memory dc
    DeleteDC myDC
End Sub

Private Sub Command1_Click()
    Dim hpx As Long
    Dim lpx As Long
    Dim tpx As Long
    Dim wpx As Long
    Dim MenuBarHeight As Long
    Dim BorderWidth As Long
   
    BorderWidth = GetSystemMetrics(45)
           
    wpx = (Me.Width / Screen.TwipsPerPixelX) - (BorderWidth * 2)
    tpx = (Me.Top / Screen.TwipsPerPixelY)
    hpx = Me.Height / Screen.TwipsPerPixelY - BorderWidth
    lpx = Me.Left / Screen.TwipsPerPixelX + BorderWidth
   
    MenuBarHeight = hpx - Me.ScaleHeight
   
   
    'TakeSnapshot 0, 0, 200, 200, "C:\snapshot.bmp"
    TakeSnapshot lpx, tpx + MenuBarHeight, wpx, hpx - MenuBarHeight, App.Path + "\snapshot.bmp"
   
    Me.Picture1 = LoadPicture(App.Path + "\snapshot.bmp")
    Me.Picture1.Top = 0
    Me.Picture1.Left = 0
    Me.Picture1.Width = Me.Width
    Me.Picture1.Height = Me.Height
    Me.Picture1.Visible = True
    Me.Picture1.ZOrder "0"
       
End Sub


Private Sub Form_Unload(Cancel As Integer)
    End
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Static ClickCount As Long
   
    ClickCount = ClickCount + 1
   
    Static FirstX As Long
    Static FirstY As Long
    Dim SecondX As Long
    Dim SecondY As Long
   
    Dim hpx As Long
    Dim lpx As Long
    Dim tpx As Long
    Dim wpx As Long
    Dim MenuBarHeight As Long
    Dim BorderWidth As Long
   
   
    If ClickCount = 1 Then
        FirstX = x / Screen.TwipsPerPixelX
        FirstY = y / Screen.TwipsPerPixelY
        Exit Sub
    End If
   
    If ClickCount = 2 Then
        SecondX = x / Screen.TwipsPerPixelX
        SecondY = y / Screen.TwipsPerPixelY
    End If

    BorderWidth = GetSystemMetrics(45)
   
           
    'Get the borders of the form
    tpx = (Me.Top / Screen.TwipsPerPixelY)
    hpx = Me.Height / Screen.TwipsPerPixelY - BorderWidth
    lpx = Me.Left / Screen.TwipsPerPixelX + BorderWidth
    MenuBarHeight = hpx - Me.ScaleHeight
   
    'now, go int a get inside of the form
    wpx = Abs(FirstX - SecondX)
    hpx = Abs(FirstY - SecondY)
   
    If FirstX < SecondX Then
        lpx = lpx + FirstX
    Else
        lpx = lpx + SecondX
    End If
   
    If FirstY < SecondY Then
        tpx = tpx + FirstY
    Else
        tpx = tpx + SecondY
    End If
   
    TakeSnapshot lpx, tpx + MenuBarHeight, wpx, hpx, App.Path + "\snapshot2.bmp"
    Me.Picture1.ZOrder "0"
    Me.Picture1.Visible = False
    ClickCount = 0
   
    MsgBox OCRImage(ConvertToTif(App.Path + "\snapshot2.bmp"))
   
End Sub

Private Function ConvertToTif(ImageName As String) As String
    Dim imgFile As New imagefile

    Dim IP As New ImageProcess

    Dim strFileName As String
   
    imgFile.LoadFile ImageName
   
    IP.filters.Add IP.FilterInfos("Convert").FilterID
    IP.filters(1).Properties("FormatID").Value = wiaFormatTIFF
    IP.filters(1).Properties("Quality").Value = 5
   
    Set imgFile = IP.Apply(imgFile)
   
    strFileName = Replace(ImageName, imgFile.FileExtension, ".tif")
   
    If Dir(strFileName) <> "" Then
        Kill strFileName
    End If
   
    imgFile.SaveFile strFileName
    Set imgFile = Nothing
   
    ConvertToTif = strFileName
End Function

Private Function OCRImage(strFileName As String) As String
    Dim objDoc As MODI.Document
    Dim objImg As MODI.Image
   
    Set objDoc = New MODI.Document
    objDoc.Create (strFileName)
    Set objImg = objDoc.images(0)
    objImg.OCR
   
    OCRImage = objImg.Layout.Text
   
End Function

---

Quote:

---

Originally Posted by JohnCloud

my other workaround here is a pretty long method, its acceptable, but I know there's a way to it with less lines of code.

---

Can you post it? Perhaps it can be condensed and/or improved.

@SamOscarBrown, I tried to use 'SnapShot' of the picturebox before but it is affecting the quality of the image and everything inside the picture box. Im printing a barcode, thats why i need the quality of the printout as clear as what is seen on the screen. When I tried using Snapshot, i can barely read texts that are below 12 font size


Here's the current code Im using for the printing

Code:

---

Private Declare Function SendMessage Lib "user32" Alias _
  "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
  ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const WM_PAINT = &HF
Private Const WM_PRINT = &H317
Private Const PRF_CLIENT = &H4&    ' Draw the window's client area
Private Const PRF_CHILDREN = &H10& ' Draw all visible child
Private Const PRF_OWNED = &H20&    ' Draw all owned windows

---

Code:

---

Dim rv1 As Long
  Me.AutoRedraw = True
  rv1 = SendMessage(frmPrint.Picture2.hWnd, WM_PAINT, Me.hdc, 0) 'Paint the PicBox background
  rv1 = SendMessage(frmPrint.Picture2.hWnd, WM_PRINT, Me.hdc, _
        PRF_CHILDREN + PRF_CLIENT + PRF_OWNED)      'Paint the PicBox Controls
  Set Me.Picture = Picture4.Picture 'Persist the Image in the Form into Picture
  Me.AutoRedraw = False
  ' Print:
  Printer.Scale
  Printer.PaintPicture Me.Picture, 0, 0
 '''''''''''''''''''''''''''' Left, Top, Width, Height, Unit, SizePerModule, CalcSizeOnly
  Barcode1.Draw Printer.hdc, 150, 250, 2300, 800, 1, False, False
  frmPrint.Shape1.Shape Printer.hdc, 150, 250, , , fals, False
  Printer.CurrentX = 450
  Printer.CurrentY = 1
  Printer.FontName = "Rockwell Condensed"
  Printer.FontSize = "10"
  Printer.Print Me.Label16.Caption
  Printer.Print frmPrint.Shape1
  Printer.EndDoc
  Me.Cls
  Set Me.Picture = Picture3.Picture

---

on the code above, I will have to hardcode the text i would like to be seen on the image im printing, and the location of the barcode (ocx) . If i can only just print what is seen on the picture box will be much easier. Later on my program it will require me to add lines on the image, that will be laborious if I will have to draw the lines by coordinates, Ive tried it ones but did not succeed with it.