Segue a programação:
Option Explicit
Dim db As Database
Dim var_sql As Recordset
Dim intPage As Integer
Dim intMaxPages As Integer
Dim intPaginaAtual As Integer
Dim intTamanho As Integer
Dim dblScaleHeight As Double
Dim dblScaleWidth As Double
Dim lngHorizontal As Long
Dim lngVertical As Long
Dim ynPosition As Boolean
Dim intRetorno As Integer
Sub DimensionaScrolls()
ynPosition = False
Me.HScroll1.Max = (Me.Height - Me.Picture1.Left) * 0.5
Me.HScroll1.Min = (Me.Height - Me.Picture1.Left) * -0.5
Me.HScroll1.Value = 0
lngHorizontal = Me.HScroll1.Value
Me.HScroll1.Visible = True
Me.VScroll1.Max = (Me.Width - Me.Picture1.Top) * 0.5
Me.VScroll1.Min = (Me.Width - Me.Picture1.Top) * -0.5
Me.VScroll1.Value = 0
lngVertical = Me.HScroll1.Value
Me.VScroll1.Visible = True
ynPosition = True
End Sub
Sub HabilitaBotoes()
Select Case intRetorno
Case 1
Toolbar1.Buttons(3).Enabled = True
Toolbar1.Buttons(4).Enabled = False
Case 2
Toolbar1.Buttons(3).Enabled = True
Toolbar1.Buttons(4).Enabled = True
Case 3
Toolbar1.Buttons(3).Enabled = False
Toolbar1.Buttons(4).Enabled = True
Case 4
Toolbar1.Buttons(3).Enabled = False
Toolbar1.Buttons(4).Enabled = False
End Select
End Sub
Private Sub cmbTamanho_Click()
Me.Picture1.Visible = False
Me.HScroll1.Visible = False
Me.VScroll1.Visible = False
Me.Toolbar1.Buttons(3).Enabled = False
Me.Toolbar1.Buttons(4).Enabled = False
Select Case cmbTamanho.ListIndex
Case 0
intTamanho = 3
Case 1
intTamanho = 4.5
Case 2
intTamanho = 6
Case 3
intTamanho = 12
End Select
End Sub
Private Function PrintRoutine(ynPrev As Boolean, objPrint As Object, _
Optional Ratio As Double = 1, Optional intpg As Integer) As Integer
Dim intRecCount As Integer
Dim dblrow As Double
On Error Resume Next:
If openClient = False Then
Exit Function
End If
If var_sql.EOF = False Then
var_sql.MoveMax
var_sql.MoveMin
intRecCount = var_sql.RecordCount
Else
MsgBox "Não existem dados a serem impressos!", vbInformation
PrintRoutine = 4
Exit Function
End If
If TypeOf objPrint Is PictureBox Then
objPrint.Visible = True
objPrint.Left = Me.ScaleWidth / 2 - objPrint.Width / 2
objPrint.Top = Me.ScaleHeight / 2 - objPrint.Height / 2
Else
objPrint.PaperSize = vbPRPSA4
objPrint.ScaleMode = vbCentimeters
End If
intPage = 0
intMaxPages = Int(intRecCount / 46) + 1
Do While Not var_sql.EOF
Call Cabecalho(objPrint, Ratio)
If ynPrev = True Then
intPage = intpg
Else
intPage = intPage + 1
End If
With objPrint
.FontName = "Arial"
.FontSize = 8 * Ratio
.FontBold = False
End With
If ynPrev = True Then
var_sql.AbsolutePosition = (intpg * 46) - 46
End If
For dblrow = 4 To 26.5 Step 0.5
With objPrint
.CurrentY = 2.7
.CurrentX = 3.2
objPrint.Print var_sql("razao")
.CurrentY = dblrow
.CurrentX = 1.6
objPrint.Print var_sql("codigo")
.CurrentY = 3.2
.CurrentX = 3.5
objPrint.Print var_sql("endereco")
.CurrentY = 3.7
.CurrentX = 3
objPrint.Print var_sql("bairro")
.CurrentY = 4.2
.CurrentX = 3
objPrint.Print var_sql("cidade")
.CurrentY = 4.2
.CurrentX = 10
objPrint.Print var_sql("estado")
.CurrentY = 4.2
.CurrentX = 12.9
objPrint.Print var_sql("fone")
.CurrentY = 4.2
.CurrentX = 17.5
objPrint.Print var_sql("cep")
.CurrentY = 1.5
.CurrentX = 16.7
objPrint.Print var_sql("numero")
.CurrentY = 5.2
.CurrentX = 3.9
objPrint.Print var_sql("empresa")
.CurrentY = 5.8
.CurrentX = 3.1
objPrint.Print var_sql("contato")
.CurrentY = 6.4
.CurrentX = 7.1
objPrint.Print var_sql("nfax")
.CurrentY = 6.4
.CurrentX = 2.9
objPrint.Print var_sql("telefone")
.CurrentY = 11
.CurrentX = 1.6
objPrint.Print var_sql("material1")
.CurrentY = 12
.CurrentX = 1.6
objPrint.Print var_sql("material2")
.CurrentY = 13
.CurrentX = 1.6
objPrint.Print var_sql("material3")
.CurrentY = 14
.CurrentX = 1.6
objPrint.Print var_sql("material4")
.CurrentY = 15
.CurrentX = 1.6
objPrint.Print var_sql("material5")
.CurrentY = 16
.CurrentX = 1.6
objPrint.Print var_sql("material6")
.CurrentY = 11
.CurrentX = 5.2
objPrint.Print var_sql("especificacao1")
.CurrentY = 12
.CurrentX = 5.2
objPrint.Print var_sql("especificacao2")
.CurrentY = 13
.CurrentX = 5.2
objPrint.Print var_sql("especificacao3")
.CurrentY = 14
.CurrentX = 5.2
objPrint.Print var_sql("especificacao4")
.CurrentY = 15
.CurrentX = 5.2
objPrint.Print var_sql("especificacao5")
.CurrentY = 16
.CurrentX = 5.2
objPrint.Print var_sql("especificacao6")
.CurrentY = 11
.CurrentX = 9.2
objPrint.Print var_sql("entrega1")
.CurrentY = 12
.CurrentX = 9.2
objPrint.Print var_sql("entrega2")
.CurrentY = 13
.CurrentX = 9.2
objPrint.Print var_sql("entrega3")
.CurrentY = 14
.CurrentX = 9.2
objPrint.Print var_sql("entrega4")
.CurrentY = 15
.CurrentX = 9.2
objPrint.Print var_sql("entrega5")
.CurrentY = 16
.CurrentX = 9.2
objPrint.Print var_sql("entrega6")
.CurrentY = 11
.CurrentX = 12.2
objPrint.Print var_sql("quantidade1")
.CurrentY = 12
.CurrentX = 12.2
objPrint.Print var_sql("quantidade2")
.CurrentY = 13
.CurrentX = 12.2
objPrint.Print var_sql("quantidade3")
.CurrentY = 14
.CurrentX = 12.2
objPrint.Print var_sql("quantidade4")
.CurrentY = 15
.CurrentX = 12.2
objPrint.Print var_sql("quantidade5")
.CurrentY = 16
.CurrentX = 12.2
objPrint.Print var_sql("quantidade6")
.CurrentY = 11
.CurrentX = 13.9
objPrint.Print Format(var_sql("preco1"), "R$ #,##0.00")
.CurrentY = 12
.CurrentX = 13.9
objPrint.Print Format(var_sql("preco2"), "R$ #,##0.00")
.CurrentY = 13
.CurrentX = 13.9
objPrint.Print Format(var_sql("preco3"), "R$ #,##0.00")
.CurrentY = 14
.CurrentX = 13.9
objPrint.Print Format(var_sql("preco4"), "R$ #,##0.00")
.CurrentY = 15
.CurrentX = 13.9
objPrint.Print Format(var_sql("preco5"), "R$ #,##0.00")
.CurrentY = 16
.CurrentX = 13.9
objPrint.Print Format(var_sql("preco6"), "R$ #,##0.00")
.CurrentY = 11
.CurrentX = 15.9
objPrint.Print Format(var_sql("valor1"), "R$ #,##0.00")
.CurrentY = 12
.CurrentX = 15.9
objPrint.Print Format(var_sql("valor2"), "R$ #,##0.00")
.CurrentY = 13
.CurrentX = 15.9
objPrint.Print Format(var_sql("valor3"), "R$ #,##0.00")
.CurrentY = 14
.CurrentX = 15.9
objPrint.Print Format(var_sql("valor4"), "R$ #,##0.00")
.CurrentY = 15
.CurrentX = 15.9
objPrint.Print Format(var_sql("valor5"), "R$ #,##0.00")
.CurrentY = 16
.CurrentX = 15.9
objPrint.Print Format(var_sql("valor6"), "R$ #,##0.00")
.CurrentY = 11
.CurrentX = 18.1
objPrint.Print var_sql("ipi1")
.CurrentY = 12
.CurrentX = 18.1
objPrint.Print var_sql("ipi2")
.CurrentY = 13
.CurrentX = 18.1
objPrint.Print var_sql("ipi3")
.CurrentY = 14
.CurrentX = 18.1
objPrint.Print var_sql("ipi4")
.CurrentY = 15
.CurrentX = 18.1
objPrint.Print var_sql("ipi5")
.CurrentY = 16
.CurrentX = 18.1
objPrint.Print var_sql("ipi6")
.CurrentY = 18
.CurrentX = 4.6
objPrint.Print var_sql("prazo")
.CurrentY = 19
.CurrentX = 4.3
objPrint.Print Format(var_sql("total"), "R$ #,##0.00")
.CurrentY = 20
.CurrentX = 3.8
objPrint.Print var_sql("obs")
var_sql.MoveNext
If var_sql.EOF = True Then
Call Rodape(objPrint, Ratio, intPage, intMaxPages)
Exit Do
End If
End With
Next dblrow
Call Rodape(objPrint, Ratio, intPage, intMaxPages)
If ynPrev = True Then
Exit Do
End If
Loop
'1 Botão 1 habilitado 2 não habilitado _
2 Botão 1 habilitado 2 habilitado _
3 Botão 1 não habilitado 2 habilitado _
4 Botão 1 não habilitado 2 não habilitado
If var_sql.EOF = True And intMaxPages = 1 Then
PrintRoutine = 4
Exit Function
End If
If var_sql.EOF = True And intMaxPages = intpg Then
PrintRoutine = 1
Exit Function
End If
If intpg * 46 = 46 And intMaxPages <> intpg Then
PrintRoutine = 3
Exit Function
End If
If var_sql.EOF = False And intMaxPages <> intpg Then
PrintRoutine = 2
Exit Function
End If
End Function
Function openClient() As Boolean
On Error GoTo erroOpenClient:
Set db = OpenDatabase(App.Path & "cadastro.mdb")
'Dim var_sql As Recordset
' Dim sSQL As String
' sSQL = "Select * From pedidocompra2 Where numero=" & Text1
'Set area = DBEngine.Workspaces(0)
'Set bancodedados = area.OpenDatabase(App.Path & "Doc.mdb", False)
Set var_sql = bancodedados.OpenRecordset("SELECT * FROM pedidocompra2, Empresa ")
openClient = True
Exit Function
erroOpenClient:
MsgBox Err.Number & ": " & vbCr & Err.Description, vbCritical
openClient = False
End Function
Private Sub Cabecalho(objPrint As Object, Ratio As Double)
On Error Resume Next
With objPrint
.PaperSize = vbPRPSA4
.Font = "Arial"
.FontSize = 16 * Ratio
.FontBold = True
.CurrentY = 1.5
.CurrentX = 1.6
objPrint.Print "PEDIDO DE COMPRA"
.FontSize = 9 * Ratio
.CurrentY = 2.7
.CurrentX = 1.6
objPrint.Print "Empresa:"
.CurrentY = 3.2
.CurrentX = 1.6
objPrint.Print "Endereço:"
.CurrentY = 3.7
.CurrentX = 1.6
objPrint.Print "Bairro:"
.CurrentY = 1.5
.CurrentX = 15.9
objPrint.Print "Nº:"
.CurrentY = 4.2
.CurrentX = 1.6
objPrint.Print "Cidade:"
.CurrentY = 4.2
.CurrentX = 8.6
objPrint.Print "Estado:"
.CurrentY = 4.2
.CurrentX = 11.6
objPrint.Print "Fone:"
.CurrentY = 4.2
.CurrentX = 16.4
objPrint.Print "Cep:"
.CurrentY = 5.2
.CurrentX = 1.6
objPrint.Print "Fornecedor:"
.CurrentY = 5.8
.CurrentX = 1.6
objPrint.Print "Contato:"
.CurrentY = 6.4
.CurrentX = 1.6
objPrint.Print "Fone:"
.CurrentY = 6.4
.CurrentX = 6
objPrint.Print "Fax:"
.CurrentY = 9
.CurrentX = 1.6
objPrint.Print "ITENS DO PEDIDO:"
.CurrentY = 10
.CurrentX = 1.6
objPrint.Print "Materiais"
.CurrentY = 10
.CurrentX = 5.2
objPrint.Print "Especificação"
.CurrentY = 10
.CurrentX = 9.2
objPrint.Print "Entrega"
.CurrentY = 10
.CurrentX = 12.2
objPrint.Print "Qtd"
.CurrentY = 10
.CurrentX = 13.9
objPrint.Print "Preço"
.CurrentY = 10
.CurrentX = 15.9
objPrint.Print "Total"
.CurrentY = 10
.CurrentX = 18.1
objPrint.Print "IPI"
.CurrentY = 18
.CurrentX = 1.6
objPrint.Print "Prazo de Entrega:"
.CurrentY = 19
.CurrentX = 1.6
objPrint.Print "Total do Pedido:"
.CurrentY = 20
.CurrentX = 1.6
objPrint.Print "Observações:"
.CurrentY = 23
.CurrentX = 1.6
objPrint.Print "Vistos:"
.CurrentY = 23.6
.CurrentX = 1.6
objPrint.Print "Comprador:________________________"
.CurrentY = 23.6
.CurrentX = 9.9
objPrint.Print "Responsável:________________________"
End With
objPrint.Line (1.5, 2.3)-(19, 2.4), 0, BF
objPrint.Line (1.5, 4.8)-(19, 4.85), 0, BF
objPrint.Line (1.5, 7.1)-(19, 7.2), 0, BF
objPrint.Line (1.5, 9.6)-(19, 9.7), 0, BF
objPrint.Line (1.5, 16.7)-(19, 16.8), 0, BF
End Sub
Private Sub Rodape(objPrint As Object, Ratio As Double, Pag As Integer, Pags As Integer)
On Error Resume Next
objPrint.PaperSize = vbPRPSA4
objPrint.Line (1.5, 27.5)-(19, 27.55), 0, BF
With objPrint
.Font = "Arial"
.FontSize = 10 * Ratio
.CurrentY = 27.7
.CurrentX = 1.8
objPrint.Print "Relatório impresso em: " & Format(Now, "dd/mm/yyyy")
.CurrentY = 27.7
.CurrentX = 17.5
objPrint.Print Pag & " de " & Pags
.EndDoc
End With
End Sub
Private Function ScalePicPreviewToPrinterCentimeter(picPreview As PictureBox, Tamanho As Integer) As Double
Dim Ratio As Double ' Ratio between Printer and Picture
Dim HeightRatio As Double, WidthRatio As Double
Dim PgWidth As Double, PgHeight As Double
Dim smtemp As Long
Printer.PaperSize = vbPRPSA4
' Get the physical page size in Centimeters:
PgWidth = Printer.Width / 567
PgHeight = Printer.Height / 567
' Scale PictureBox to Printer's printable area in Inches:
picPreview.ScaleMode = vbCentimeters
' Compare the height and with ratios to determine the
' Ratio to use and how to size the picture box:
HeightRatio = dblScaleHeight / PgHeight
WidthRatio = dblScaleWidth / PgWidth
If HeightRatio < WidthRatio Then
Ratio = HeightRatio * Tamanho
smtemp = picPreview.Container.ScaleMode
picPreview.Container.ScaleMode = vbCentimeters
picPreview.Width = PgWidth * Ratio
picPreview.Height = picPreview.Width * 1.41428571
picPreview.Container.ScaleMode = smtemp
Else
Ratio = WidthRatio * Tamanho
smtemp = picPreview.Container.ScaleMode
picPreview.Container.ScaleMode = vbCentimeters
picPreview.Height = PgHeight * Ratio * Tamanho
picPreview.Width = picPreview.Height * 0.7070707
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
ScalePicPreviewToPrinterCentimeter = Ratio
End Function
Private Sub Form_Activate()
Me.HScroll1.Top = Me.Height - 685
Me.VScroll1.Left = Me.VScroll1.Left + 85
Me.HScroll1.Width = 11725
Me.VScroll1.Height = 7825
End Sub
Private Sub Form_Load()
Picture1.Cls
Picture1.ScaleMode = vbCentimeters
dblScaleHeight = Picture1.ScaleHeight
dblScaleWidth = Picture1.ScaleWidth
cmbTamanho.ListIndex = 1
Toolbar1.Buttons(3).Enabled = False
Toolbar1.Buttons(4).Enabled = False
End Sub
Private Sub HScroll1_Change()
If ynPosition = True Then
lngHorizontal = lngHorizontal - HScroll1.Value
Me.Picture1.Left = Me.Picture1.Left + lngHorizontal
lngHorizontal = HScroll1.Value
End If
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As ComctlLib.Button)
Me.MousePointer = 11
Select Case Button.Key
Case "Imprime"
Me.HScroll1.Visible = False
Me.VScroll1.Visible = False
Me.Picture1.Visible = False
intRetorno = PrintRoutine(False, Printer)
Toolbar1.Buttons(3).Enabled = False
Toolbar1.Buttons(4).Enabled = False
Case "Visualiza"
intPaginaAtual = 1
intRetorno = PrintRoutine(True, Picture1, ScalePicPreviewToPrinterCentimeter(Picture1, intTamanho), 1)
If intTamanho = 6 Or intTamanho = 12 Then
DimensionaScrolls
Else
Me.HScroll1.Visible = False
Me.VScroll1.Visible = False
End If
Call HabilitaBotoes
Case "Anterior"
intRetorno = PrintRoutine(True, Picture1, ScalePicPreviewToPrinterCentimeter(Picture1, intTamanho), intPaginaAtual - 1)
If intTamanho = 6 Or intTamanho = 12 Then
Call DimensionaScrolls
End If
intPaginaAtual = intPaginaAtual - 1
Call HabilitaBotoes
Case "Proximo"
intRetorno = PrintRoutine(True, Picture1, ScalePicPreviewToPrinterCentimeter(Picture1, intTamanho), intPaginaAtual + 1)
If intTamanho = 6 Or intTamanho = 12 Then
Call DimensionaScrolls
End If
intPaginaAtual = intPaginaAtual + 1
Call HabilitaBotoes
End Select
Me.MousePointer = 0
End Sub
Private Sub VScroll1_Change()
If ynPosition = True Then
lngVertical = lngVertical - VScroll1.Value
Me.Picture1.Top = Me.Picture1.Top + lngVertical
lngVertical = VScroll1.Value
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set Preview8 = Nothing
End Sub