VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ContactPage"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private cp_contact As ContactItem
Private cp_xhtml As String
Const stylesheeturl As String = "res/basic.css"
'Const stylesheeturl As String = "http://www.w3.org/Stylesheets/Core/Oldstyle"
Property Set Contact(cn As ContactItem)
Set cp_contact = cn
End Property
Public Function PageTitle() As String
'The of the page
If Len(cp_contact.CompanyName) > 0 Then
PageTitle = cp_contact.CompanyName
ElseIf Len(cp_contact.FullName) > 0 Then
PageTitle = cp_contact.FullName
Else
PageTitle = "Unnamed"
End If
PageTitle = Sanitize(PageTitle)
End Function
Private Function Sanitize(initial As String) As String
'Remove any dodgy characters
Sanitize = initial
Sanitize = Replace(Sanitize, "<", "")
Sanitize = Replace(Sanitize, ">", "")
Sanitize = Replace(Sanitize, "/", "")
Sanitize = Replace(Sanitize, "\", "")
Sanitize = Replace(Sanitize, ".", "")
End Function
Public Function PageId() As String
'The id of the root element
PageId = Replace(PageTitle, " ", "_")
End Function
Public Function PageFile() As String
'The name of the XHTML file for this contact
PageFile = PageId & ".html"
End Function
Public Sub OutputToFile(outdir As String)
'Output cp_xhtml to file, in directory outdir
Dim filepath As String
filepath = outdir & "\" & PageFile
Dim i As Integer 'disambiguation counter
Dim fso As New FileSystemObject
If fso.FileExists(filepath) Then
i = Round(Rnd * 1000, 0)
filepath = filepath & i
End If
Dim ts As TextStream
Set ts = fso.CreateTextFile(filepath)
cp_xhtml = XhtmlPage
ts.Write cp_xhtml
ts.Close
End Sub
'================================================================================================
'= XHTML Functions
'================================================================================================
Public Function XhtmlPage() As String
'The XHTML representation of cp_contact
XhtmlPage = Header_ & vbCrLf & _
Html_
End Function
Public Function Header_() As String
'The XHTML representation of cp_contact
Header_ = _
"<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "UTF-8" & Chr(34) & "?>" & vbCrLf & _
"<!DOCTYPE html PUBLIC " & Chr(34) & "-//W3C//DTD XHTML 1.0 Transitional//EN" & Chr(34) & vbCrLf & _
Chr(34) & "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd" & Chr(34) & ">"
End Function
Public Function Html_() As String
Html_ = "<html id=" & Chr(34) & PageId & Chr(34) & " xmlns=" & Chr(34) & "http://www.w3.org/1999/xhtml" & Chr(34) & ">"
Html_ = Html_ & vbCrLf & _
Head_ & vbCrLf & _
Body_ & vbCrLf & _
"</html>"
End Function
Public Function Head_() As String
Head_ = "<head>" & vbCrLf & _
Title_ & vbCrLf & _
Stylesheet_ & vbCrLf & _
"</head>"
End Function
Public Function Title_() As String
Title_ = "<title id=" & Chr(34) & "title" & Chr(34) & ">" & PageTitle & ""
End Function
Public Function Stylesheet_() As String
Stylesheet_ = ""
End Function
Public Function Body_() As String
Body_ = "" & vbCrLf & _
"
" & PageTitle & "
" & vbCrLf & _
Company_table_ & vbCrLf & _
Person_table_(1) & vbCrLf & _
Person_table_(2) & vbCrLf & _
Person_table_(3) & vbCrLf & _
Categories_ul_ & vbCrLf & _
""
End Function
Public Function Company_table_() As String
Company_table_ = "
"
End Function
Public Function Url(urlin As String) As String
'Helper function for URLs, since we don't know how they start
If Left(urlin, 4) = "http" Then
Url = urlin
ElseIf Left(urlin, 2) = "//" Then
Url = "http:" & urlin
Else
Url = "http://" & urlin
End If
End Function
Public Function Phone_tr_() As String
Phone_tr_ = "
Phone
" & vbCrLf & _
Phone_td_ & vbCrLf & _
"
"
End Function
Public Function Phone_td_() As String
Phone_td_ = "
" & cp_contact.BusinessTelephoneNumber & "
"
End Function
Public Function Address_tr_() As String
Address_tr_ = "
Address
" & vbCrLf & _
Address_td_ & vbCrLf & _
"
"
End Function
Public Function Address_td_() As String
Address_td_ = "
"
End Function
Public Function FirstName_tr_() As String
FirstName_tr_ = "
First Name
" & vbCrLf & _
FirstName_td_ & vbCrLf & _
"
"
End Function
Public Function FirstName_td_() As String
FirstName_td_ = "
" & cp_contact.FirstName & "
"
End Function
Public Function LastName_tr_() As String
LastName_tr_ = "
Last Name
" & vbCrLf & _
LastName_td_ & vbCrLf & _
"
"
End Function
Public Function LastName_td_() As String
LastName_td_ = "
" & cp_contact.LastName & "
"
End Function
Public Function Email_tr_(n As Integer) As String
Email_tr_ = "
Email
" & vbCrLf & _
Email_td_(n) & vbCrLf & _
"
"
End Function
Public Function Email_td_(n As Integer) As String
Dim email As String
If n = 1 Then
email = cp_contact.Email1Address
ElseIf n = 2 Then
email = cp_contact.Email2Address
ElseIf n = 3 Then
email = cp_contact.Email3Address
End If
Email_td_ = "
"
End Function
Public Function Mobile_tr_() As String
Mobile_tr_ = "
Mobile
" & vbCrLf & _
Mobile_td_ & vbCrLf & _
"
"
End Function
Public Function Mobile_td_() As String
Mobile_td_ = "
" & cp_contact.MobileTelephoneNumber & "
"
End Function
Public Function Categories_ul_() As String
Dim categories() As String
categories = Split(cp_contact.categories, ",")
Dim category_lis_ As String
Dim i As Integer
For i = LBound(categories) To UBound(categories)
category_lis_ = category_lis_ & _
"