Important alert: (current site time 9/18/2014 1:17:20 AM EDT)
 

VB icon

HtmlLinkedToPDF

Email
Submitted on: 5/8/2012 5:31:01 PM
By: Mike Manke 
Level: Advanced
User Rating: Unrated
Compatibility: VB.NET
Views: 2294
 
     This code creates two files. The first file is a HTML file with a Hyperlink to a page in a PDF file. The second is a pdf file generated with Using ABCpdf(Allowed attributes: href) you can download a trial for ABCpdf from http://www.websupergoo.com/abcpdf-1.htm A reference to ABCpdf will have to be added to the project and an Imports WebSupergoo added before the Public Class First create a form with a single button on it Copy the Code to the forms code section When you click on the button a temporary table is created with a dummy report. (This part can be replaced with code or a function to extract data you would like to place in a PDF.) Then a Temporary HTML file is created. the PDF file Name is set up then the PGM sleeps for one second since the time(in HHMMSS format) is used for the file name The Temporary table is read and a page break if done when the words "Archive Accounts Workbook" are found in the text if two page breaks have occurred then the PDF is closed and written and the next filename is set up if the word Guarantor is found in the text the next 25 characters are used for a name and a HTML line is written the current line is printed to the pdf When all records are read then the last pdf file is written and the HTML is written also
 
code:
Can't Copy and Paste this?
Click here for a copy-and-paste friendly version of this code!
 
Terms of Agreement:   
By using this code, you agree to the following terms...   
  1. You may use this code in your own programs (and may compile it into a program and distribute it in compiled format for languages that allow it) freely and with no charge.
  2. You MAY NOT redistribute this code (for example to a web site) without written permission from the original author. Failure to do so is a violation of copyright laws.   
  3. You may link to this code from another website, but ONLY if it is not wrapped in a frame. 
  4. You will abide by any additional copyright restrictions which the author may have placed in the code or code's description.
				
//**************************************
// Name: HtmlLinkedToPDF
// Description:This code creates two files. 
The first file is a HTML file with a Hyperlink to a page in a PDF file.
The second is a pdf file generated with Using <a href="http://www.websupergoo.com/abcpdf-1.htm>ABCpdf</a>(Allowed attributes: href)
you can download a trial for ABCpdf from http://www.websupergoo.com/abcpdf-1.htm
A reference to ABCpdf will have to be added to the project
and an Imports WebSupergoo added before the Public Class
First create a form with a single button on it
Copy the Code to the forms code section
When you click on the button a temporary table is created with a dummy report. (This part can be 
replaced with code or a function to extract data you would like to place in a PDF.)
Then a Temporary HTML file is created.
the PDF file Name is set up then the PGM sleeps for one second since the time(in HHMMSS format) is used for the file name
The Temporary table is read and a page break if done when the words "Archive Accounts Workbook" are found in the text
if two page breaks have occurred then the PDF is closed and written and the next filename is set up
if the word Guarantor is found in the text the next 25 characters are used for a name and a HTML line is written
the current line is printed to the pdf
When all records are read then the last pdf file is written and the HTML is written also
// By: Mike Manke
//
//This code is copyrighted and has// limited warranties.Please see http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=8756&lngWId=10//for details.//**************************************

Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
 Dim strPathName As String = My.Application.Info.DirectoryPath
 Dim pdf As New ABCpdf8.Doc
 Dim img As New ABCpdf8.XImage
 Dim w, h, l, b, theid As Double
 Dim landscape As Boolean
 Dim pdfMain As New ABCpdf8.Doc
 Dim Gname As String
 Dim TName As String = ""
 Dim LName As String = ""
 Dim FName As String = ""
 Dim StrFileName As String
 Dim RecWork As DataTable
 Dim MyLen As Long
 Dim pgct As Long = 1
 Dim PgBreak As Long = 2
 'Create Table
 RecWork = CreateWorkBook()
 'Fill Table With Data 
 FillValTable(RecWork, "5/01/12 Archive Accounts Workbook for NO ENTITY")
 FillValTable(RecWork, "Guarantor: Jack Anyone CNumber: 88888")
 FillValTable(RecWork, "785 AnyStreet, NONE, WI 54000 ")
 FillValTable(RecWork, " Patient: Jack Anyone CNumber: JA88888 ")
 FillValTable(RecWork, "B D.O.S. Amount Code Description/Comment ")
 FillValTable(RecWork, " 7/05/11 223.00 1 00 Prof. Services ")
 FillValTable(RecWork, "Guarantor: John Doe BNumber: 99999")
 FillValTable(RecWork, "1812 BARTLETT AVENUE, NONE, WI 54000 ")
 FillValTable(RecWork, " Patient: John Doe BNumber: JD99999 ")
 FillValTable(RecWork, "B D.O.S. Amount Code Description/Comment ")
 FillValTable(RecWork, " 8/09/11 389.00 1 00 Prof. Services ")
 FillValTable(RecWork, "5/01/12 Archive Accounts Workbook for NO ENTITY")
 FillValTable(RecWork, "Guarantor: Jim Exit CNumber: 77777")
 FillValTable(RecWork, "799 Street, NONE, WI 54000 ")
 FillValTable(RecWork, " Patient: Jim Exit CNumber: JC777777 ")
 FillValTable(RecWork, "B D.O.S. Amount Code Description/Comment ")
 FillValTable(RecWork, " 5/05/11 23.00 1 00 Prof. Services ")
 FillValTable(RecWork, "Guarantor: Bill Fir CNumber: 789456")
 FillValTable(RecWork, "181 BARTLETT AVENUE, NONE, WI 54000 ")
 FillValTable(RecWork, " Patient: Bill Fir CNumber: BF789456 ")
 FillValTable(RecWork, "B D.O.S. Amount Code Description/Comment ")
 FillValTable(RecWork, " 1/09/11 89.00 1 00 Prof. Services ")
 FillValTable(RecWork, "5/01/12 Archive Accounts Workbook for NO ENTITY")
 FillValTable(RecWork, "Guarantor: Jane GoodniteNumber: 8799")
 FillValTable(RecWork, "885 AnyStreet, NONE, WI 54000 ")
 FillValTable(RecWork, " Patient: Jane GoodniteNumber: JG8799 ")
 FillValTable(RecWork, "B D.O.S. Amount Code Description/Comment ")
 FillValTable(RecWork, " 7/07/11 22.00 1 00 Prof. Services ")
 FillValTable(RecWork, "Guarantor: Bob Grabber BNumber: 887524")
 FillValTable(RecWork, "112 BARTLETT AVENUE, NONE, WI 54000 ")
 FillValTable(RecWork, " Patient: Bob Grabber BNumber: BG887524 ")
 FillValTable(RecWork, "B D.O.S. Amount Code Description/Comment ")
 FillValTable(RecWork, " 8/09/11 39.00 1 00 Prof. Services ")
 FillValTable(RecWork, "5/01/12 Archive Accounts Workbook for NO ENTITY")
 FillValTable(RecWork, "Guarantor: Phil KipperNumber: 875")
 FillValTable(RecWork, "1299 Street, NONE, WI 54000 ")
 FillValTable(RecWork, " Patient: Phil KipperNumber: PK875 ")
 FillValTable(RecWork, "B D.O.S. Amount Code Description/Comment ")
 FillValTable(RecWork, " 5/05/11 213.00 1 00 Prof. Services ")
 FillValTable(RecWork, "Guarantor: Sam Name CNumber: 9456")
 FillValTable(RecWork, "512 BARTLETT AVENUE, NONE, WI 54000 ")
 FillValTable(RecWork, " Patient: Sam Name CNumber: SN9456 ")
 FillValTable(RecWork, "B D.O.S. Amount Code Description/Comment ")
 FillValTable(RecWork, " 1/09/11 489.00 1 00 Prof. Services ")
 'Open Working HTML file, this file will have hyperlinks to the page in the PDF file the Garantors name is on
 FileOpen(1, strPathName & "Workbook.htm", OpenMode.Output)
 'Setup PDF file Name 
 StrFileName = Trim("Workbook-" & Format(Now, "MM-dd-yy_hh-mm-ss") & ".pdf")
 'Sleep for 1 second
 Threading.Thread.Sleep(1000)
 'Set the PDF to a landscape format
 landscape = True
 w = pdf.MediaBox.Width
 h = pdf.MediaBox.Height
 l = pdf.MediaBox.Left
 b = pdf.MediaBox.Bottom
 pdf.Transform.Rotate(90, l, b)
 pdf.Transform.Translate(w, 0)
 pdf.Rect.Width = h
 pdf.Rect.Height = w
 pdf.FontSize = 9
 pdf.Font = pdf.AddFont("Courier")
 'Read through table to get report data
 For Each Dr In RecWork.Rows
'check for a page break and add 1 to the page counter
MyLen = InStr(Dr.Item("rptext"), "Archive Accounts Workbook")
If MyLen > 0 Then
pgct += 1
pdf.AddPage()
End If
'Create new PDF and HTML after a number of pages 
If pgct > PgBreak Then
' adjust the default rotation and save to temp location
pdf.Flatten()
theid = pdf.GetInfo(pdf.Root, "Pages")
If landscape Then pdf.Transform.Rotate(90, pdf.MediaBox.Left, pdf.MediaBox.Bottom)
pdf.Save(strPathName & StrFileName)
pdf.Clear()
FileClose(1)
'Setup HTML filename with the first and las names found this is usefull if you limit the PDF to a number of pages
TName = "Workbook " & FName & "-" & LName & ".htm"
My.Computer.FileSystem.RenameFile(strPathName & "Workbook.htm", TName)
'initilize variables
FName = ""
pgct = 1
'Open Working HTML file, this file will have hyperlinks to the page in the PDF file the Garantors name is on
FileOpen(1, strPathName & "Workbook.htm", OpenMode.Output)
'Setup PDF file Name 
StrFileName = Trim("Workbook-" & Format(Now, "MM-dd-yy_hh-mm-ss") & ".pdf")
'Sleep for 1 second to avoid dup file names
Threading.Thread.Sleep(1000)
'Set the PDF to a landscape format
landscape = True
w = pdf.MediaBox.Width
h = pdf.MediaBox.Height
l = pdf.MediaBox.Left
b = pdf.MediaBox.Bottom
pdf.Transform.Rotate(90, l, b)
pdf.Transform.Translate(w, 0)
pdf.Rect.Width = h
pdf.Rect.Height = w
pdf.FontSize = 9
pdf.Font = pdf.AddFont("Courier")
End If
'check for the name if the line has a name output a record to the HTML with the name and the PDF Page number
MyLen = InStr(Dr.Item("rptext"), "Guarantor:")
If MyLen > 0 Then
Gname = Mid(Dr.Item("rptext"), MyLen + 11, 25)
'If the name is blank use @
If Trim(Gname) = "" Then Gname = "@"
If Trim(FName) = "" Then FName = Gname.Trim
LName = Gname.Trim
Print(1, "<a href=" & URLEncode(StrFileName) & "#page=" & pgct & ">" & Gname & "</a><br>")
End If
'Add text to the PDF file
pdf.AddText("" & RTrim(Dr.Item("rptext")))
 Next
 ' adjust the default rotation and save to temp location
 pdf.Flatten()
 theid = pdf.GetInfo(pdf.Root, "Pages")
 If landscape Then pdf.Transform.Rotate(90, pdf.MediaBox.Left, pdf.MediaBox.Bottom)
 pdf.Save(strPathName & StrFileName)
 pdf.Clear()
 FileClose(1)
 'Setup HTML filename with the first and las names found this is usefull if you limit the PDF to a number of pages
 TName = "Workbook " & FName & "-" & LName & ".htm"
 FName = ""
 My.Computer.FileSystem.RenameFile(strPathName & "Workbook.htm", TName)
cleanup:
 pdf = Nothing
 Exit Sub
err_handler:
 End Sub
 Public Function URLEncode(ByVal sRawURL As String) As String
 On Error GoTo err_handler
 Dim iLoop As Integer
 Dim sRtn As String = ""
 Dim sTmp As String
 Const sValidChars = "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz:/.?=_-$(){}~&"
 URLEncode = ""
 If Len(sRawURL) > 0 Then
' Loop through each char
For iLoop = 1 To Len(sRawURL)
sTmp = Mid(sRawURL, iLoop, 1)
If InStr(1, sValidChars, sTmp, vbBinaryCompare) = 0 Then
 ' If not ValidChar, convert to HEX and p
 ' refix with %
 sTmp = Hex(Asc(sTmp))
 If sTmp = "20" Then
 sTmp = "+"
 ElseIf Len(sTmp) = 1 Then
 sTmp = "%0" & sTmp
 Else
 sTmp = "%" & sTmp
 End If
End If
sRtn = sRtn & sTmp
Next iLoop
URLEncode = sRtn
 End If
 Exit Function
err_handler:
 End Function
 Private Function CreateWorkBook() As DataTable
 Dim Table1 As DataTable
 'Create Table
 Table1 = New DataTable("Workbook")
 Try
'declare Patient columns
Table1.Columns.Add("rptext")
 Catch ex As Exception
 End Try
 Return Table1
 End Function
 Public Sub FillValTable(ByRef InTab As DataTable, ByVal Val As String)
 Dim AddNewRow As DataRow
 'Add a row to the table
 AddNewRow = InTab.NewRow
 AddNewRow("rptext") = Val
 InTab.Rows.Add(AddNewRow)
 End Sub


Report Bad Submission
Use this form to tell us if this entry should be deleted (i.e contains no code, is a virus, etc.).
This submission should be removed because:

Your Vote

What do you think of this code (in the Advanced category)?
(The code with your highest vote will win this month's coding contest!)
Excellent  Good  Average  Below Average  Poor (See voting log ...)
 

Other User Comments


 There are no comments on this submission.
 

Add Your Feedback
Your feedback will be posted below and an email sent to the author. Please remember that the author was kind enough to share this with you, so any criticisms must be stated politely, or they will be deleted. (For feedback not related to this particular code, please click here instead.)
 

To post feedback, first please login.