home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / YES!_100s_52412222002.psc / html.bas < prev    next >
Encoding:
BASIC Source File  |  1999-07-30  |  10.5 KB  |  436 lines
  1. Option Explicit
  2.  
  3. Global Const ATTR_NORMAL = 0  'Normal files
  4. Global Const ATTR_HIDDEN = 2  'Hidden files
  5. Global Const ATTR_SYSTEM = 4  'System files
  6. Global Const ATTR_DIRECTORY = 16  'Directory
  7.  
  8. Function Array_To_HTML_Table (TLines() As String, TableAlign As String, TableWidth As String, Border As Integer, CelsPerRow As Integer, Cel_Alignment As String) As String
  9. ' Important:
  10. ' This function takes PLAIN text as input not HTML!
  11.  
  12. Dim tmp As String
  13. Dim indx As Integer
  14. Dim inner_index As Integer
  15. Dim CrLf As String
  16. Dim q As String
  17. Dim Table_Header As String
  18. Dim sBorder As String
  19.  
  20. If Border = True Then sBorder = "BORDER" Else sBorder = ""
  21. Select Case Left(LCase(TableAlign), 1)
  22.     Case "c": TableAlign = "CENTER"
  23.     Case "l": TableAlign = "LEFT"
  24.     Case "r": TableAlign = "RIGHT"
  25.     Case Else: TableAlign = "LEFT"
  26. End Select
  27.  
  28. Select Case Left(LCase(Cel_Alignment), 1)
  29.     Case "c": Cel_Alignment = "CENTER"
  30.     Case "l": Cel_Alignment = "LEFT"
  31.     Case "r": Cel_Alignment = "RIGHT"
  32.     Case Else: Cel_Alignment = "LEFT"
  33. End Select
  34. Table_Header = "<TABLE " + sBorder + " ALIGN=" + TableAlign + " WIDTH=" + TableWidth + ">"
  35. 'MsgBox Table_Header
  36. 'CelsPerRow
  37. q = Chr(34)
  38. CrLf = Chr(13) + Chr(10)
  39.  
  40. Dim Max_Bound As Integer
  41. Max_Bound = ((UBound(TLines) \ CelsPerRow) + (UBound(TLines) Mod CelsPerRow)) * CelsPerRow
  42.  
  43. ReDim Preserve TLines(1 To Max_Bound)
  44. tmp = Table_Header + CrLf
  45. 'For indx = LBound(TLines) To UBound(TLines): MsgBox TLines(indx): Next
  46. Debug.Print LBound(TLines)
  47. Debug.Print UBound(TLines)
  48. 'Debug.Print CelsPerRow
  49. 'Debug.Print UBound(TLines) \ CelsPerRow
  50. 'Dim LastInnerIndex As Integer
  51. 'LastInnerIndex = 0
  52.  
  53. For indx = LBound(TLines) To UBound(TLines) \ CelsPerRow
  54.     tmp = tmp + "<TR ALIGN=" + Cel_Alignment + ">"
  55.         
  56.         For inner_index = indx * CelsPerRow - CelsPerRow + 1 To (indx * CelsPerRow)
  57.             tmp = tmp + "<TD>" + TLines(inner_index) + "</TD>" + CrLf
  58.         Next inner_index
  59.         
  60.     tmp = tmp + "</TR>" + CrLf
  61. Next indx
  62. tmp = tmp + "</TABLE>"
  63. Array_To_HTML_Table = tmp
  64.  
  65. End Function
  66.  
  67. Function Body_Colors (TextColor As String, LinkColor As String, ALinkColor As String, VLinkColor As String) As String
  68. Dim sText As String
  69. Dim sLink As String
  70. Dim sALink As String
  71. Dim sVLink As String
  72.  
  73. If TextColor = "" Then
  74.     sText = ""
  75. Else
  76.     sText = "TEXT=" & TextColor
  77. End If
  78. '''''''''''''''''''''''''''''''''
  79. If LinkColor = "" Then
  80.     sLink = ""
  81. Else
  82.     sLink = "LINK=" & LinkColor
  83. End If
  84. '''''''''''''''''''''''''''''''''
  85. If ALinkColor = "" Then
  86.     sALink = ""
  87. Else
  88.     sALink = "ALINK=" & ALinkColor
  89. End If
  90. '''''''''''''''''''''''''''''''''
  91. If VLinkColor = "" Then
  92.     sVLink = ""
  93. Else
  94.     sVLink = "VLINK=" & VLinkColor
  95. End If
  96.  
  97. Body_Colors = Trim$(sText & " " & sLink & " " & sALink & " " & sVLink)
  98. End Function
  99.  
  100. Function HTML_Body (BGColor As String, BGPic As String, BGFixed As Integer, Colors As String) As String
  101. Dim sColor As String
  102. Dim sPic As String
  103. Dim sFixed As String
  104. Dim sColors As String
  105.  
  106. Dim q As String
  107. Dim CrLf As String
  108.  
  109. q = Chr(34)
  110. CrLf = Chr(13) + Chr(10)
  111.  
  112. If BGColor = "" Then sColor = "" Else sColor = "BGCOLOR=" & BGColor
  113. If BGFixed = True Then sFixed = "BGPROPERTIES=FIXED" Else sFixed = ""
  114. If BGPic = "" Then
  115.     sPic = ""
  116.     sFixed = ""
  117. Else
  118.     sPic = "BACKGROUND=" & q & BGPic & q
  119. End If
  120.  
  121. If Colors = "" Then sColors = "" Else sColors = CrLf + Colors
  122. HTML_Body = Trim$("<BODY " & sColor & " " & sPic & " " & sFixed & " " & sColors) & ">" + CrLf
  123.  
  124. End Function
  125.  
  126. Function HTML_Bold (HTML As String) As String
  127.  
  128.     HTML_Bold = "<B>" + HTML + "</B>"
  129.  
  130. End Function
  131.  
  132. Function HTML_Font (HTML As String, Face As String, Size As Integer, Color As String) As String
  133. '//TODO
  134. '  Check if color is a hex value or a color name,
  135. '  valid color names are red,green,blue,cyan,magenta,black,grey,....?
  136. Dim tmp As String
  137. Dim CrLf As String
  138. Dim q As String
  139.  
  140. CrLf = Chr(13) + Chr(10)
  141. q = Chr(34)
  142.  
  143. If Color = "" Then Color = "black"
  144. If Face = "" Then Face = "MS Sans Serif"
  145. If Size = 0 Then Size = 3
  146.  
  147. tmp = "<FONT COLOR=" + Color + " FACE=" + q + Face + q + " SIZE=" + Format$(Size) + ">"
  148. tmp = tmp + CrLf + HTML + CrLf + "</FONT>"
  149.  
  150. HTML_Font = tmp
  151.  
  152. End Function
  153.  
  154. Function HTML_Italic (HTML As String) As String
  155.  
  156.     HTML_Italic = "<I>" + HTML + "</I>"
  157.  
  158. End Function
  159.  
  160. Function HTML_Link (Target As String, Caption As String) As String
  161. Dim tmp As String
  162. Dim q As String * 1
  163. q = ""
  164. tmp = "<A HREF=" + q + Target + q + ">" + Caption + "</A>"
  165.  
  166. HTML_Link = tmp
  167.  
  168. End Function
  169.  
  170. Function HTML_Table (HTMLCells As String, Border As Integer, Alignment As String, TableWidth As String) As String
  171. Dim sBorder As String
  172. Dim sAlign As String
  173.  
  174. Dim CrLf As String
  175. CrLf = Chr(13) + Chr(10)
  176.  
  177. If Border <= 0 Then
  178.     sBorder = ""
  179. Else
  180.     sBorder = "BORDER=" & CStr(Border)
  181. End If
  182. Select Case LCase$(Alignment)
  183.     Case "c", "center"
  184.         sAlign = "CENTER"
  185.     Case "l", "left"
  186.         sAlign = "LEFT"
  187.     Case "r", "right"
  188.         sAlign = "ROGHT"
  189.     Case "t", "top"
  190.         sAlign = "TOP"
  191.     End Select
  192.  
  193. HTML_Table = "<TABLE " + sBorder + " ALIGN=" + sAlign + " WIDTH=" + TableWidth + " >" + CrLf + HTMLCells + CrLf + "</TABLE>" + CrLf
  194.  
  195. End Function
  196.  
  197. Function HTML_TableCell (astr As String) As String
  198.  
  199. HTML_TableCell = "<TD>" + astr + "</TD>"
  200.  
  201. End Function
  202.  
  203. Function HTML_TableRow (astr As String) As String
  204.  
  205. Dim CrLf As String
  206. CrLf = Chr(13) + Chr(10)
  207.  
  208. HTML_TableRow = "<TR>" + CrLf + astr + CrLf + "</TR>" + CrLf
  209.  
  210. End Function
  211.  
  212. Function HTML_Underline (HTML As String) As String
  213.  
  214.     HTML_Underline = "<U>" + HTML + "</U>"
  215.  
  216. End Function
  217.  
  218. Function ReadFile (sFileName As String) As String
  219. On Error GoTo ReadFileError
  220. Dim FF As Integer
  221. Dim TmpStr As String
  222.  
  223. FF = FreeFile
  224. Open sFileName For Input As #FF
  225. TmpStr = Input$(LOF(FF), FF)
  226. Close #FF
  227. ReadFile = TmpStr
  228. Exit Function
  229.  
  230. ReadFileError:
  231.     ReadFile = ""
  232.     Exit Function
  233.  
  234. End Function
  235.  
  236. Function Text_2_HTML (Text As String) As String
  237. ' Important:
  238. ' This function takes PLAIN text as input not HTML!
  239.  
  240. Dim tmp As String
  241. Dim indx As Integer
  242. Dim CrLf As String
  243. Dim q As String
  244.  
  245.  
  246. ReDim TLines(1 To 1) As String
  247. q = Chr(34)
  248. CrLf = Chr(13) + Chr(10)
  249. TextToLines Text, TLines()
  250.  
  251. tmp = ""
  252.  
  253. For indx = LBound(TLines) To UBound(TLines)
  254.         tmp = tmp + TLines(indx) + "<BR>" + CrLf
  255. Next indx
  256.  
  257.  
  258. Text_2_HTML = tmp
  259.  
  260. End Function
  261.  
  262. Function Text_2_HTML_List (Text As String, Numbered As Integer) As String
  263. ' Important:
  264. ' This function takes PLAIN text as input not HTML!
  265.  
  266. Dim tmp As String
  267. Dim indx As Integer
  268. Dim CrLf As String
  269. Dim q As String
  270.  
  271. Dim LstO As String, LstC As String
  272.  
  273.  
  274. ReDim TLines(1 To 1) As String
  275. q = Chr(34)
  276. CrLf = Chr(13) + Chr(10)
  277. TextToLines Text, TLines()
  278.  
  279.  
  280. If Numbered = True Then
  281.     LstO = "<OL>"
  282.     LstC = "</OL>"
  283. Else
  284.     LstO = "<UL>"
  285.     LstC = "</UL>"
  286. End If
  287.  
  288.  
  289. tmp = LstO
  290.  
  291. For indx = LBound(TLines) To UBound(TLines)
  292.         If TLines(indx) <> "" Then
  293.             tmp = tmp + "<LI>" + TLines(indx) + "<BR>" + CrLf
  294.         Else
  295.             tmp = tmp + "<BR>" + CrLf
  296.         End If
  297. Next indx
  298.  
  299.  
  300. 'If Right(tmp, 6) = "<BR>" + CrLf Then
  301. '    tmp = Left(tmp, Len(tmp) - 6)
  302. 'End If
  303.  
  304.  
  305. tmp = tmp + LstC
  306.  
  307. Text_2_HTML_List = tmp
  308.  
  309. End Function
  310.  
  311. Function Text_To_HTML_Table (Text As String, TableAlign As String, TableWidth As String, Border As Integer, CelsPerRow As Integer, Cel_Alignment As String) As String
  312. ' Important:
  313. ' This function takes PLAIN text as input not HTML!
  314.  
  315. Dim tmp As String
  316. Dim indx As Integer
  317. Dim inner_index As Integer
  318. Dim CrLf As String
  319. Dim q As String
  320. Dim Table_Header As String
  321. Dim sBorder As String
  322.  
  323. If Border = True Then sBorder = "BORDER" Else sBorder = ""
  324. Select Case Left(LCase(TableAlign), 1)
  325.     Case "c": TableAlign = "CENTER"
  326.     Case "l": TableAlign = "LEFT"
  327.     Case "r": TableAlign = "RIGHT"
  328.     Case Else: TableAlign = "LEFT"
  329. End Select
  330.  
  331. Select Case Left(LCase(Cel_Alignment), 1)
  332.     Case "c": Cel_Alignment = "CENTER"
  333.     Case "l": Cel_Alignment = "LEFT"
  334.     Case "r": Cel_Alignment = "RIGHT"
  335.     Case Else: Cel_Alignment = "LEFT"
  336. End Select
  337. Table_Header = "<TABLE " + sBorder + " ALIGN=" + TableAlign + " WIDTH=" + TableWidth + ">"
  338. 'MsgBox Table_Header
  339. 'CelsPerRow
  340. ReDim TLines(1 To 1) As String
  341. q = Chr(34)
  342. CrLf = Chr(13) + Chr(10)
  343. TextToLines Text, TLines()
  344.  
  345. Dim Max_Bound As Integer
  346. Max_Bound = ((UBound(TLines) \ CelsPerRow) + (UBound(TLines) Mod CelsPerRow)) * CelsPerRow
  347.  
  348. ReDim Preserve TLines(1 To Max_Bound)
  349. tmp = Table_Header + CrLf
  350. 'For indx = LBound(TLines) To UBound(TLines): MsgBox TLines(indx): Next
  351. Debug.Print LBound(TLines)
  352. Debug.Print UBound(TLines)
  353. 'Debug.Print CelsPerRow
  354. 'Debug.Print UBound(TLines) \ CelsPerRow
  355. 'Dim LastInnerIndex As Integer
  356. 'LastInnerIndex = 0
  357.  
  358. For indx = LBound(TLines) To UBound(TLines) \ CelsPerRow
  359.     tmp = tmp + "<TR ALIGN=" + Cel_Alignment + ">"
  360.         
  361.         For inner_index = indx * CelsPerRow - CelsPerRow + 1 To (indx * CelsPerRow)
  362.             tmp = tmp + "<TD>" + TLines(inner_index) + "</TD>" + CrLf
  363.         Next inner_index
  364.         
  365.     tmp = tmp + "</TR>" + CrLf
  366. Next indx
  367. tmp = tmp + "</TABLE>"
  368. Text_To_HTML_Table = tmp
  369.  
  370. End Function
  371.  
  372. Sub TextToLines (Text As String, Lines() As String)
  373. '//TODO
  374. '  use temp files in the temp folder...
  375.  
  376. Dim FF As Integer
  377. Dim index As Integer
  378. FF = FreeFile
  379. Open "c:\~~tmp.tmp" For Output As #FF
  380. Print #FF, Text
  381. Close FF
  382. FF = FreeFile
  383. Open "c:\~~tmp.tmp" For Input As #FF
  384. index = 1
  385. Do While Not EOF(FF)
  386.     ReDim Preserve Lines(1 To index)
  387.     Line Input #FF, Lines(index)
  388.     index = index + 1
  389. Loop
  390. Close #FF
  391. Kill "c:\~~tmp.tmp"
  392. End Sub
  393.  
  394. Function WriteFile (sFileName As String, sContents As String) As Integer
  395.  
  396. Const ATTR_ALL_FILES = ATTR_NORMAL Or ATTR_HIDDEN Or ATTR_SYSTEM Or ATTR_DIRECTORY
  397. Dim FF As Integer
  398.  
  399. On Error GoTo WriteFileError
  400.  
  401. FF = FreeFile
  402. If Dir(sFileName, ATTR_ALL_FILES) = "" Then
  403.     Open sFileName For Output As #FF
  404.     Print #FF, sContents
  405.     Close #FF
  406.     WriteFile = True
  407. Else       'File Already Exists
  408.     WriteFile = False
  409. End If
  410.  
  411. Exit Function
  412.  
  413. WriteFileError:
  414.     WriteFile = False
  415.     Exit Function
  416.  
  417. End Function
  418.  
  419. Function WriteHTMLFile (sFileName As String, sContents As String, sTitle As String) As Integer
  420. Dim HTML_Header As String
  421. Dim HTML_Footer As String
  422. Dim HTML As String
  423. Dim iRet As Integer
  424. Dim CrLf As String
  425. CrLf = Chr(13) + Chr(10)
  426.  
  427. HTML_Header = "<HTML>" + CrLf + "<TITLE>" + CrLf + sTitle + "</TITLE>" + CrLf + "<BODY>"
  428. HTML_Footer = "</BODY>" + CrLf + "</HTML>"
  429. HTML = HTML_Header + sContents + HTML_Footer
  430. iRet = WriteFile(sFileName, HTML)
  431.  
  432. WriteHTMLFile = iRet
  433.  
  434. End Function
  435.  
  436.