Code:
Private Sub PDFCreate()
Dim clPDF As New clsPDFCreator
Dim strFile As String
Dim I As Single
On Error GoTo ErrHandler
With CommonDialog1
.CancelError = True
.Filter = "PDF Files (*.pdf|*.pdf"
.FileName = "Report.pdf"
.Flags = cdlOFNOverwritePrompt + cdlOFNPathMustExist
.ShowSave
If .FileName = "" Then Exit Sub
strFile = .FileName
End With
With clPDF
.Title = "Jackson County License Report" ' Title
.ScaleMode = pdfCentimeter ' Unità di misura
.PaperSize = pdfA4 ' Formato pagina
.Margin = 0 ' Margin
.Orientation = pdfPortrait ' Orientamento
.InitPDFFile strFile ' inizializza il file
' Definisce le risorse relative ai font
.LoadFont "Fnt1", "Times New Roman" ' Tipo TrueType
.LoadFont "Fnt2", "Arial", pdfItalic ' Tipo TrueType
.LoadFont "Fnt3", "Courier New" ' Tipo TrueType
.LoadFontStandard "Fnt4", "Courier New", pdfBoldItalic ' Tipo Type1
' Inizializza la prima pagina
.StartPage
.DrawText 19, 1.5, "page. " & Trim(CStr(.Pages)), "Fnt1", 12, pdfAlignRight
.DrawObject "Footers"
.DrawText 10.5, 28, "Jackson County License Report", "Fnt1", 32, pdfCenter
.Rectangle 1, 2, 19, 25.5, Stroked
' Definisce una risorsa comune da stampare solo sulle pagine pari
' .StartObject "Item1", pdfOddPages
' .SetColorFill -240
' .SetTextHorizontalScaling 120
' .DrawText 6, 4, "Bozza", "Fnt2", 200, , 60
' .SetColorFill 0
' .EndObject
.SetDash 0.5, 0.3
.MoveTo 9, 2
.LineTo 9, 10, Nil
.LineTo 1, 10, Stroked
.SetDash 0
If Label6.Caption = "By Dept" Then
If (Cn.State And adStateOpen) <> adStateOpen Then
Call DBConnect
End If
If ChkAll.Value = 1 Then
s = "Department like '%'"
area = "All Departments"
Else
s = "Department = '" & CmbDept.Text & "'"
area = CmbDept.Text
End If
If s <> "" Then
rs.Open ("SELECT Machine, UserID, [Software Title], Version, Department," & _
"[Assigned Date], Server FROM [MS Office Licenses] WHERE " & s & " and " & _
"UserID NOT LIKE '--%' ORDER BY [" & CmbOrderby1.Text & "]," & _
"[" & CmbOrderby2.Text & "]"), Cn, adOpenStatic, adLockOptimistic
.SetTextHorizontalScaling 70
.DrawText 5, 26, "DeptCount", "Fnt2", 12, pdfAlignLeft
.DrawText 10, 26, "Department:" & area, "Fnt2", 12, pdfCenter
.SetTextHorizontalScaling 100
.SetTextHorizontalScaling 70
.DrawText 3, 24, "Machine", "Fnt2", 12, pdfAlignRight
.DrawText 4, 24, "UserID", "Fnt2", 12, pdfAlignLeft
.DrawText 6, 24, "Software Title", "Fnt2", 12, pdfAlignLeft
.DrawText 9, 24, "Version", "Fnt2", 12, pdfAlignLeft
.DrawText 12, 24, "Department", "Fnt2", 12, pdfCenter
.DrawText 15, 24, "Server", "Fnt2", 12, pdfCenter
.DrawText 18, 24, "Assigned Date", "Fnt2", 12, pdfAlignRight
'Loop
' For I = 0 To n Step 1
I = 0
Do While Not rs.EOF
If Len(rs.Fields("Machine").Value) > 0 Then
.DrawText 3, 22 - I, rs.Fields("Machine").Value, "Fnt2", 8
Else
.DrawText 3, 22 - I, "empty", "Fnt2", 8
End If
.DrawText 4, 22 - I, rs.Fields("UserID").Value, "Fnt2", 8
.DrawText 6, 22 - I, rs.Fields("Software Title").Value, "Fnt2", 8
.DrawText 9, 22 - I, rs.Fields("Version").Value, "Fnt2", 8
.DrawText 12, 22 - I, rs.Fields("Department").Value, "Fnt2", 8
.DrawText 15, 22 - I, rs.Fields("Server").Value, "Fnt2", 8
If Len(rs.Fields("Assigned Date").Value) > 0 Then
.DrawText 18, 22 - I, rs.Fields("Assigned Date").Value, "Fnt2", 8
Else
.DrawText 18, 22 - I, "None", "Fnt2", 8
End If
I = I + 1
If I = 25 Then
.EndPage
.StartPage
.DrawText 19, 1.5, "page. " & Trim(CStr(.Pages)), "Fnt1", 12, pdfAlignRight
.DrawObject "Footers"
.DrawText 10.5, 27, "Jackson County License Report", "Fnt1", 32, pdfCenter
.Rectangle 1, 2, 19, 18.5, Stroked
I = 0
End If
rs.MoveNext
Loop
' Definisce una risorsa da stampare su tutte le pagine
.StartObject "Footers", pdfAllPages
.DrawText 20, 1.5, "of " & Trim(CStr(.Pages)), "Fnt1", 12, pdfAlignRight
.EndObject
' Chiude il documento
.ClosePDFFile
Call DBDisconnect
'Unload FrmReports
Exit Sub
Else
MsgBox "Empty Search String"
End If
End If
End With
Exit Sub
ErrHandler:
If Err <> cdlCancel Then
MsgBox Err.Description
End If
Err_Handler:
'your error handling code
strErr = "VB error " & Err.Number & vbCrLf & Err.Description
MsgBox "We Have An Error" + vbCrLf + vbCrLf + strErr, vbExclamation + vbOKOnly, "Database error"
End Sub