VBA Snippets
HTML_Table2Column
Public Function HTML_Table2Column(ByVal bHeadingRow As Boolean, _
ByVal sColFirst As String, _
ByVal iColFirstWidth As Integer, _
ByVal sColSecond As String, _
ByVal lRowCurrent As Long, _
Optional ByVal sLinkPrefix As String = "", _
Optional ByVal bshaderow As Boolean = True, _
Optional ByVal sRowColour As String = sCOLOUR_TABLESHADING, _
Optional ByVal bAddSectionBookmarks As Boolean = False) As Long
Dim lrowno As Long
lrowno = lRowCurrent
Do Until Len(Range(sColFirst & lrowno).Value) = 0 And _
Len(Range(sColFirst & lrowno + 1).Value) = 0 And _
Len(Range(sColFirst & lrowno + 2).Value) = 0
If bHeadingRow = True Then
Call HTML_TableAddHeading(Range(sColFirst & lrowno).Value, , , _
bAddSectionBookmarks)
lrowno = lrowno + 1
bshaderow = True
End If
gsHTML_TEXT = gsHTML_TEXT & "<TABLE WIDTH=""100%"""
gsHTML_TEXT = gsHTML_TEXT & " BORDER=""" & gsTABLEBORDERS & """"
gsHTML_TEXT = gsHTML_TEXT & " BGCOLOR=""WHITE"">"
Do Until Len(Range(sColFirst & lrowno).Value) = 0
If bshaderow = True Then
gsHTML_TEXT = gsHTML_TEXT & "<TR BGCOLOR=""" & sRowColour & """>"
Else
gsHTML_TEXT = gsHTML_TEXT & "<TR>"
End If
'--------------------------------------------------------- first column
gsHTML_TEXT = gsHTML_TEXT & "<TD WIDTH=" & iColFirstWidth & " VALIGN=TOP>"
gsHTML_TEXT = gsHTML_TEXT & "<FONT COLOR=" & sCOLOUR_GENERAL_FONTCOLOUR
gsHTML_TEXT = gsHTML_TEXT & " SIZE=2>"
gsHTML_TEXT = gsHTML_TEXT & Range(sColFirst & lrowno).Value
gsHTML_TEXT = gsHTML_TEXT & "</FONT>"
gsHTML_TEXT = gsHTML_TEXT & "</TD>"
'--------------------------------------------------------- second column
gsHTML_TEXT = gsHTML_TEXT & "<TD VALIGN=""TOP"">"
gsHTML_TEXT = gsHTML_TEXT & "<FONT COLOR=" & sCOLOUR_GENERAL_FONTCOLOUR
gsHTML_TEXT = gsHTML_TEXT & " SIZE=2>"
If IsError(Range(sColSecond & lrowno).Value) = False Then
gsHTML_TEXT = gsHTML_TEXT & Range(sColSecond & lrowno).Value
Else
gsHTML_TEXT = gsHTML_TEXT & "ERROR"
End If
gsHTML_TEXT = gsHTML_TEXT & "</FONT>"
gsHTML_TEXT = gsHTML_TEXT & "</TD>"
'---------------------------------------------------------
gsHTML_TEXT = gsHTML_TEXT & "</TR>"
lrowno = lrowno + 1
bshaderow = Not bshaderow
Loop
gsHTML_TEXT = gsHTML_TEXT & "</TABLE>"
gsHTML_TEXT = gsHTML_TEXT & "<BR>"
lrowno = lrowno + 2
Loop
HTML_Table2Column = lrowno
End Function
HTML_TableAddRow1Column
Public Sub HTML_TableAddRow1Column(ByVal sFirstColWidth As String, _
ByVal sCol1Value As String, _
Optional ByVal bBulletCol1 As Boolean = False, _
Optional ByVal bBoldCol1 As Boolean = False, _
Optional ByVal sFontColour As String = sCOLOUR_GENERAL_FONTCOLOUR, _
Optional ByVal sBackGroundColour As String = "", _
Optional ByVal bshaderow As Boolean = False, _
Optional ByVal sRowColour As String = sCOLOUR_TABLESHADING)
If bshaderow = True Then
gsHTML_TEXT = gsHTML_TEXT & "<TR BGCOLOR=""" & sRowColour & """>"
Else
gsHTML_TEXT = gsHTML_TEXT & "<TR>"
End If
gsHTML_TEXT = gsHTML_TEXT & "<TD WIDTH=""" & sINDENTSIZE & """> </TD>"
gsHTML_TEXT = gsHTML_TEXT & "<TD WIDTH=" & sFirstColWidth & " VALIGN=""TOP"">"
gsHTML_TEXT = gsHTML_TEXT & "<FONT COLOR=""" & sCOLOUR_GENERAL_FONTCOLOUR & """"
gsHTML_TEXT = gsHTML_TEXT & " SIZE=""2"">"
If bBoldCol1 = True Then gsHTML_TEXT = gsHTML_TEXT & "<B>"
If bBulletCol1 = True Then gsHTML_TEXT = gsHTML_TEXT & "<LI type=square>"
gsHTML_TEXT = gsHTML_TEXT & sCol1Value
If bBoldCol1 = True Then gsHTML_TEXT = gsHTML_TEXT & "</B>"
gsHTML_TEXT = gsHTML_TEXT & "</FONT>"
gsHTML_TEXT = gsHTML_TEXT & "</TD>"
gsHTML_TEXT = gsHTML_TEXT & "</TR>"
End Sub
HTML_TableAddText2Column
Public Function HTML_TableAddText2Column(ByVal lRowFirst As Long, _
Optional ByVal sReplaceChar As String = ".", _
Optional ByVal sCellPadding As String = "10") As Long
Dim llastrow As Long
Dim lrowno As Long
llastrow = lRowFirst
Do While Left(Range("A" & llastrow).Value, 3) = "TB2"
llastrow = llastrow + 1
Loop
llastrow = llastrow - 1
gsHTML_TEXT = gsHTML_TEXT & "<TABLE WIDTH=""100%"""
gsHTML_TEXT = gsHTML_TEXT & " BORDER=""" & gsTABLEBORDERS & """"
gsHTML_TEXT = gsHTML_TEXT & " BGCOLOR=""WHITE"""
gsHTML_TEXT = gsHTML_TEXT & " CELLPADDING=" & sCellPadding & ">"
For lrowno = lRowFirst To llastrow
gsHTML_TEXT = gsHTML_TEXT & "<TR>"
gsHTML_TEXT = gsHTML_TEXT & "<TD WIDTH=""180"" VALIGN=""TOP"">"
gsHTML_TEXT = gsHTML_TEXT & "<FONT COLOR=""" & sCOLOUR_GENERAL_FONTCOLOUR & """ SIZE=""2"">"
gsHTML_TEXT = gsHTML_TEXT & "<B>"
gsHTML_TEXT = gsHTML_TEXT & Range("B" & lrowno).Value
gsHTML_TEXT = gsHTML_TEXT & "</B>"
gsHTML_TEXT = gsHTML_TEXT & "</FONT>"
gsHTML_TEXT = gsHTML_TEXT & "</TD>"
gsHTML_TEXT = gsHTML_TEXT & "<TD VALIGN=""TOP"">"
gsHTML_TEXT = gsHTML_TEXT & "<FONT COLOR=""" & sCOLOUR_GENERAL_FONTCOLOUR & """ SIZE=""2"">"
gsHTML_TEXT = gsHTML_TEXT & Str_CharReplace(Range("C" & lrowno).Value, _
". ", sReplaceChar & "<BR>")
gsHTML_TEXT = gsHTML_TEXT & "</FONT>"
gsHTML_TEXT = gsHTML_TEXT & "</TD>"
gsHTML_TEXT = gsHTML_TEXT & "</TR>"
Next lrowno
gsHTML_TEXT = gsHTML_TEXT & "</TABLE>"
gsHTML_TEXT = gsHTML_TEXT & "<BR>"
HTML_TableAddText2Column = lrowno - 1
End Function
HTML_TableAddText3Column
Public Function HTML_TableAddText3Column(ByVal lRowFirst As Long, _
Optional ByVal sReplaceChar As String = ".", _
Optional ByVal sCellPadding As String = "10") As Long
Dim llastrow As Long
Dim lrowno As Long
llastrow = lRowFirst
Do While Left(Range("A" & llastrow).Value, 3) = "TB3"
llastrow = llastrow + 1
Loop
llastrow = llastrow - 1
gsHTML_TEXT = gsHTML_TEXT & "<TABLE WIDTH=""100%"""
gsHTML_TEXT = gsHTML_TEXT & " BORDER=""" & gsTABLEBORDERS & """"
gsHTML_TEXT = gsHTML_TEXT & " BGCOLOR=""WHITE"""
gsHTML_TEXT = gsHTML_TEXT & " CELLPADDING=" & sCellPadding & ">"
For lrowno = lRowFirst To llastrow
gsHTML_TEXT = gsHTML_TEXT & "<TR>"
gsHTML_TEXT = gsHTML_TEXT & "<TD WIDTH=""180"" VALIGN=""TOP"">"
gsHTML_TEXT = gsHTML_TEXT & "<FONT COLOR=""" & sCOLOUR_GENERAL_FONTCOLOUR & """ SIZE=""2"">"
gsHTML_TEXT = gsHTML_TEXT & "<B>"
gsHTML_TEXT = gsHTML_TEXT & Range("B" & lrowno).Value
gsHTML_TEXT = gsHTML_TEXT & "</B>"
gsHTML_TEXT = gsHTML_TEXT & "</FONT>"
gsHTML_TEXT = gsHTML_TEXT & "</TD>"
gsHTML_TEXT = gsHTML_TEXT & "<TD WIDTH=""60"" VALIGN=""TOP"">"
gsHTML_TEXT = gsHTML_TEXT & "<FONT COLOR=""" & sCOLOUR_GENERAL_FONTCOLOUR & """ SIZE=""2"">"
gsHTML_TEXT = gsHTML_TEXT & Range("C" & lrowno).Value
gsHTML_TEXT = gsHTML_TEXT & "</FONT>"
gsHTML_TEXT = gsHTML_TEXT & "</TD>"
gsHTML_TEXT = gsHTML_TEXT & "<TD VALIGN=""TOP"">"
gsHTML_TEXT = gsHTML_TEXT & "<FONT COLOR=""" & sCOLOUR_GENERAL_FONTCOLOUR & """ SIZE=""2"">"
gsHTML_TEXT = gsHTML_TEXT & Range("D" & lrowno).Value
gsHTML_TEXT = gsHTML_TEXT & "</FONT>"
gsHTML_TEXT = gsHTML_TEXT & "</TD>"
gsHTML_TEXT = gsHTML_TEXT & "</TR>"
Next lrowno
gsHTML_TEXT = gsHTML_TEXT & "</TABLE>"
gsHTML_TEXT = gsHTML_TEXT & "<BR>"
HTML_TableAddText3Column = lrowno - 1
End Function
HTML_TablePicturesText2Column
Public Function HTML_TablePicturesText2Column(ByVal lRowFirst As Long, _
Optional sReplaceChar As String = ".", _
Optional sCellPadding As String = "10") As Long
Dim lnoofrows As Long
Dim lrowno As Long
Dim stotaltext As String
lnoofrows = 0
Do While Left(Range("A" & lRowFirst + lnoofrows).Value, 4) = "TB2p"
stotaltext = stotaltext & Range("B" & lRowFirst + lnoofrows + 1).Value
stotaltext = stotaltext & "<BR><BR>"
lnoofrows = lnoofrows + 1
Loop
gsHTML_TEXT = gsHTML_TEXT & "<TABLE WIDTH=""100%"""
gsHTML_TEXT = gsHTML_TEXT & " BORDER=""" & gsTABLEBORDERS & """"
gsHTML_TEXT = gsHTML_TEXT & " BGCOLOR=""WHITE"""
gsHTML_TEXT = gsHTML_TEXT & " CELLPADDING=" & sCellPadding & ">"
gsHTML_TEXT = gsHTML_TEXT & "<TR>"
gsHTML_TEXT = gsHTML_TEXT & "<TD VALIGN=""TOP"">"
gsHTML_TEXT = gsHTML_TEXT & "<FONT COLOR=""" & sCOLOUR_GENERAL_FONTCOLOUR & """ SIZE=""2"">"
gsHTML_TEXT = gsHTML_TEXT & Range("B" & lRowFirst).Value
gsHTML_TEXT = gsHTML_TEXT & "</FONT>"
gsHTML_TEXT = gsHTML_TEXT & "</TD>"
gsHTML_TEXT = gsHTML_TEXT & "<TD WIDTH=""20"">"
gsHTML_TEXT = gsHTML_TEXT & " "
gsHTML_TEXT = gsHTML_TEXT & "</TD>"
gsHTML_TEXT = gsHTML_TEXT & "<TD VALIGN=""TOP"">"
gsHTML_TEXT = gsHTML_TEXT & "<FONT COLOR=""" & sCOLOUR_GENERAL_FONTCOLOUR & """ SIZE=""2"">"
gsHTML_TEXT = gsHTML_TEXT & stotaltext
gsHTML_TEXT = gsHTML_TEXT & "</FONT>"
gsHTML_TEXT = gsHTML_TEXT & "</TD>"
gsHTML_TEXT = gsHTML_TEXT & "</TR>"
gsHTML_TEXT = gsHTML_TEXT & "</TABLE>"
gsHTML_TEXT = gsHTML_TEXT & "<BR>"
HTML_TablePicturesText2Column = lRowFirst + lnoofrows
End Function
HTML_TableSummary1Column
Public Sub HTML_TableSummary1Column(iFirstColWidth As Integer, _
sColFirst As String, _
ByVal lrowno As Long, _
Optional bBulletCol1 As Boolean = False, _
Optional bBoldCol1 As Boolean = False)
Do Until Len(Range(sColFirst & lrowno).Value) = 0 And _
Len(Range(sColFirst & lrowno + 1).Value) = 0 And _
Len(Range(sColFirst & lrowno + 2).Value) = 0
gsHTML_TEXT = gsHTML_TEXT & "<TABLE WIDTH=""100%"""
gsHTML_TEXT = gsHTML_TEXT & " BORDER=" & gsTABLEBORDERS
gsHTML_TEXT = gsHTML_TEXT & " BGCOLOR=" & sCOLOUR_GENERAL_HEADINGCOLOUR & ">"
gsHTML_TEXT = gsHTML_TEXT & "<TR>"
gsHTML_TEXT = gsHTML_TEXT & "<TD BGCOLOR = " & sCOLOUR_GENERAL_HEADINGCOLOUR & ">"
gsHTML_TEXT = gsHTML_TEXT & "<FONT COLOR=WHITEe"
gsHTML_TEXT = gsHTML_TEXT & " SIZE=3>"
gsHTML_TEXT = gsHTML_TEXT & "<B>"
gsHTML_TEXT = gsHTML_TEXT & Range(sColFirst & lrowno).Value
gsHTML_TEXT = gsHTML_TEXT & "</B>"
gsHTML_TEXT = gsHTML_TEXT & "</FONT>"
gsHTML_TEXT = gsHTML_TEXT & "</TD>"
gsHTML_TEXT = gsHTML_TEXT & "</TR>"
gsHTML_TEXT = gsHTML_TEXT & "</TABLE>"
gsHTML_TEXT = gsHTML_TEXT & "<TABLE WIDTH=100%"
gsHTML_TEXT = gsHTML_TEXT & " BORDER=0"
gsHTML_TEXT = gsHTML_TEXT & " BGCOLOR=WHITE>"
lrowno = lrowno + 1
Do Until Len(Range(sColFirst & lrowno).Value) = 0
Call HTML_TableAddRow1Column("100%", Range(sColFirst & lrowno).Value, _
True, False)
lrowno = lrowno + 1
Loop
gsHTML_TEXT = gsHTML_TEXT & "</TABLE>"
gsHTML_TEXT = gsHTML_TEXT & "<HR>"
lrowno = lrowno + 2
Loop
End Sub
© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited Top