Option Explicit
Private Sub Form_Load()
CommonDialog1.CancelError = True
Command1.Caption = "Load Picture"
Command2.Caption = "Print Preview"
Command3.Caption = "Print"
End Sub
Private Sub Command1_Click()
Dim sFileFilter As String
On Error GoTo ErrHandler
sFileFilter = "Bitmap Files (*.bmp)|*.bmp|"
sFileFilter = sFileFilter & "GIF Files (*.gif)|*.gif|"
sFileFilter = sFileFilter & "Icon Files (*.ico)|*.ico|"
sFileFilter = sFileFilter & "JPEG Files (*.jpg)|*.jpg|"
sFileFilter = sFileFilter & "Windows MetaFiles (*.wmf)|.wmf"
With CommonDialog1
.Filter = sFileFilter
.ShowOpen
If .FileName <> " " Then
Picture2.Picture = LoadPicture(.FileName)
End If
End With
ErrHandler:
Exit Sub
End Sub
Private Sub Command2_Click()
Dim dRatio As Double
dRatio = ScalePicPreviewToPrinterInches(Picture1)
PrintRoutine Picture1, dRatio
End Sub
Private Sub Command3_Click()
Printer.ScaleMode = vbInches
PrintRoutine Printer
Printer.EndDoc
End Sub
Private Function ScalePicPreviewToPrinterInches _
(picPreview As PictureBox) As Double
Dim Ratio As Double ' Ratio between Printer and Picture
Dim LRGap As Double, TBGap As Double
Dim HeightRatio As Double, WidthRatio As Double
Dim PgWidth As Double, PgHeight As Double
Dim smtemp As Long
' Get the physical page size in Inches:
PgWidth = Printer.Width / 1440
PgHeight = Printer.Height / 1440
' Find the size of the non-printable area on the printer to
' use to offset coordinates. These formulas assume the
' printable area is centered on the page:
smtemp = Printer.ScaleMode
Printer.ScaleMode = vbInches
LRGap = (PgWidth - Printer.ScaleWidth) / 2
TBGap = (PgHeight - Printer.ScaleHeight) / 2
Printer.ScaleMode = smtemp
' Scale PictureBox to Printer's printable area in Inches:
picPreview.ScaleMode = vbInches
' Compare the height and with ratios to determine the
' Ratio to use and how to size the picture box:
HeightRatio = picPreview.ScaleHeight / PgHeight
WidthRatio = picPreview.ScaleWidth / PgWidth
If HeightRatio < WidthRatio Then
Ratio = HeightRatio
smtemp = picPreview.Container.ScaleMode
picPreview.Container.ScaleMode = vbInches
picPreview.Width = PgWidth * Ratio
picPreview.Container.ScaleMode = smtemp
Else
Ratio = WidthRatio
smtemp = picPreview.Container.ScaleMode
picPreview.Container.ScaleMode = vbInches
picPreview.Height = PgHeight * Ratio
picPreview.Container.ScaleMode = smtemp
End If
' Set default properties of picture box to match printer
' There are many that you could add here:
picPreview.Scale (0, 0)-(PgWidth, PgHeight)
picPreview.Font.Name = Printer.Font.Name
picPreview.FontSize = Printer.FontSize * Ratio
picPreview.ForeColor = Printer.ForeColor
picPreview.Cls
ScalePicPreviewToPrinterInches = Ratio
End Function
Private Sub PrintRoutine(objPrint As Object, _
Optional Ratio As Double = 1)
' All dimensions in inches:
' Print some graphics to the control object
objPrint.Line (1, 1)-(1 + 6.5, 1 + 9), , B
objPrint.Line (1.1, 2)-(1.1, 2)
objPrint.PaintPicture Picture2, 1.1, 1.1, 0.8, 0.8
objPrint.Line (2.1, 1.2)-(2.1 + 5.2, 1.2 + 0.7), _
RGB(200, 200, 200), BF
' Print a title
With objPrint
.Font.Name = "Arial"
.CurrentX = 2.3
.CurrentY = 1.3
.FontSize = 35 * Ratio
objPrint.Print "Visual Basic Printing"
End With
' Print some circles
Dim x As Single
For x = 3 To 5.5 Step 0.2
objPrint.Circle (x, 3.5), 0.75
Next
' Print some text
With objPrint
.Font.Name = "Courier New"
.FontSize = 30 * Ratio
.CurrentX = 1.5
.CurrentY = 5
objPrint.Print "It is possible to do"
.FontSize = 24 * Ratio
.CurrentX = 1.5
.CurrentY = 6.5
objPrint.Print "It is possible to do print"
.FontSize = 18 * Ratio
.CurrentX = 1.5
.CurrentY = 8
objPrint.Print "It is possible to do print preview"
End With
End Sub
