home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 1999 January / dppcpro0199a.iso / January / Fp98 / SDK / Wizards / Vb / Htmlgen.bas < prev    next >
Encoding:
BASIC Source File  |  1997-09-18  |  11.0 KB  |  532 lines
  1. Attribute VB_Name = "HTMLGEN"
  2. ' -------------------------------------------------------------------
  3. ' File: HTMLGEN.BAS
  4. ' Copyright (c) 1995 Vermeer Technologies, Inc.  All rights reserved.
  5. ' -------------------------------------------------------------------
  6.  
  7. Option Explicit
  8.  
  9. Const ERR_FILE_NOT_FOUND = "*FILE-NOT-FOUND*"
  10.  
  11. Sub CloseDescription(f As Integer)
  12.  
  13.     Print #f, "</DL>"
  14.  
  15. End Sub
  16.  
  17. Sub CloseDocument(f As Integer)
  18.  
  19.     Print #f, "</BODY>"
  20.     Print #f, "</HTML>"
  21.  
  22. End Sub
  23.  
  24. Sub CloseFile(fnum As Integer)
  25.  
  26.     Close fnum
  27.  
  28. End Sub
  29.  
  30. Sub CloseForm(f As Integer)
  31.  
  32.     Print #f, "</FORM>"
  33.  
  34. End Sub
  35.  
  36. Sub CloseFormSelection(f As Integer)
  37.  
  38.     Print #f, "</SELECT>"
  39.  
  40. End Sub
  41.  
  42. Sub CloseList(f As Integer, ordered As Integer)
  43.  
  44.     If ordered Then
  45.         Print #f, "</OL>"
  46.     Else
  47.         Print #f, "</UL>"
  48.     End If
  49.  
  50. End Sub
  51.  
  52. Sub CloseLiteral(f As Integer)
  53.  
  54.     Print #f, "</PRE>"
  55.  
  56. End Sub
  57.  
  58. Sub CloseQuote(f As Integer)
  59.  
  60.     Print #f, "</BLOCKQUOTE>"
  61.  
  62. End Sub
  63.  
  64. Sub CloseTag(f As Integer, tagname As String)
  65.  
  66.     Print #f, "</" & tagname & ">"
  67.  
  68. End Sub
  69.  
  70. Sub CreateAnchor(s As String, text As String, anchorname As String)
  71.  
  72.     ' constructs anchor in passed string
  73.  
  74.     Dim q As String
  75.  
  76.     q = Chr$(34)  ' double quote
  77.  
  78.     If text = "" Then text = " "  ' anchor must have some text to be valid
  79.  
  80.     s = "<A NAME=" & q & anchorname & q & ">" & text & "</A>"
  81.  
  82. End Sub
  83.  
  84. Sub CreateLink(s As String, text As String, URL As String)
  85.  
  86.     ' create link in passed string
  87.  
  88.     Dim q As String
  89.  
  90.     q = Chr$(34)  ' double quote
  91.  
  92.     s = "<A HREF=" & q & URL & q & ">" & text & "</A>"
  93.  
  94. End Sub
  95.  
  96. Function HTMLString(s As String) As String
  97.  
  98.     ' handle HTML quoting
  99.  
  100.     Dim i As Integer
  101.     Dim slen As Integer
  102.     Dim out As String
  103.     Dim c As String
  104.  
  105.     out = ""
  106.  
  107.     slen = Len(s)
  108.     For i = 1 To slen
  109.         c = Mid$(s, i, 1)
  110.         Select Case c
  111.             Case Chr$(34)  ' double quote
  112.                 out = out & """
  113.             Case "&"
  114.                 out = out & "&"
  115.             Case "<"
  116.                 out = out & "<"
  117.             Case ">"
  118.                 out = out & ">"
  119.             Case Else
  120.                 out = out & c
  121.         End Select
  122.     Next i
  123.  
  124.     HTMLString = out
  125.  
  126. End Function
  127.  
  128. Sub OpenDescription(f As Integer)
  129.  
  130.     Print #f, "<DL>"
  131.  
  132. End Sub
  133.  
  134. Sub OpenDocument(f As Integer, Title As String)
  135.  
  136.     Print #f, "<HTML>"
  137.     Print #f, "<HEAD>"
  138.     Print #f, "<TITLE>"; HTMLString(Title); "</TITLE>"
  139.     Print #f, "</HEAD>"
  140.     Print #f, "<BODY>"
  141.  
  142. End Sub
  143.  
  144. Function OpenFile(filename) As Integer
  145.  
  146.     Dim fnum As Integer
  147.  
  148.     fnum = FreeFile
  149.  
  150.     ' TODO: check for file open errors
  151.     Open filename For Output As fnum
  152.  
  153.     OpenFile = fnum
  154.  
  155. End Function
  156.  
  157. Sub OpenForm(f As Integer, method As String, action As String)
  158.  
  159.     Dim q As String
  160.  
  161.     q = Chr$(34)  ' double quote
  162.  
  163.     ' TODO: verify method as "GET" or "POST"
  164.  
  165.     Print #f, "<FORM METHOD=" & method & " ACTION=" & q & action & q & ">"
  166.  
  167. End Sub
  168.  
  169. Sub OpenFormSelection(f As Integer, fldname As String, fldsize As Integer, multiple As Integer)
  170.  
  171.     Dim q As String
  172.  
  173.     q = Chr$(34)
  174.  
  175.     Print #f, "<SELECT NAME="; q; fldname; q;
  176.     If fldsize > 0 Then
  177.         Print #f, " SIZE="; CStr(fldsize);
  178.     End If
  179.     If multiple Then
  180.         Print #f, " MULTIPLE";
  181.     End If
  182.     Print #f, ">"
  183.  
  184. End Sub
  185.  
  186. Sub OpenList(f As Integer, ordered As Integer)
  187.  
  188.     If ordered Then
  189.         Print #f, "<OL>"
  190.     Else
  191.         Print #f, "<UL>"
  192.     End If
  193.  
  194. End Sub
  195.  
  196. Sub OpenLiteral(f As Integer)
  197.  
  198.     Print #f, "<PRE>"
  199.  
  200. End Sub
  201.  
  202. Sub OpenQuote(f As Integer)
  203.  
  204.     Print #f, "<BLOCKQUOTE>"
  205.  
  206. End Sub
  207.  
  208. Sub OpenTag(f As Integer, tagname As String)
  209.  
  210.     Print #f, "<" & tagname & ">"
  211.  
  212. End Sub
  213.  
  214. Function StringFromFile(filename As String) As String
  215.  
  216.     Dim f As Integer  ' file number
  217.     Dim out As String ' output
  218.     Dim ln As String  ' line of input
  219.     Dim nl As String  ' end of line chars
  220.  
  221.     ' TODO: watch out for 32K string limit
  222.  
  223.     On Error GoTo StringFromFileError
  224.  
  225.     nl = Chr$(13) & Chr$(10)  ' newline
  226.     out = ""  ' initialize string
  227.  
  228.     f = FreeFile
  229.  
  230.     Open filename For Input As f
  231.  
  232.     Do While Not EOF(f)
  233.         Line Input #f, ln
  234.         out = out & ln & nl
  235.     Loop
  236.  
  237.     Close f
  238.  
  239.     StringFromFile = out
  240.  
  241.     Exit Function
  242.  
  243. StringFromFileError:
  244.     ' file not found
  245.     StringFromFile = ERR_FILE_NOT_FOUND
  246.     Exit Function
  247.  
  248. End Function
  249.  
  250. Function StringFromHTMLFile(filename As String) As String
  251.  
  252.     Dim inp As String    ' input file
  253.     Dim inlc As String  ' input file in lower case
  254.     Dim bstart As Integer  ' first char after <BODY>
  255.     Dim bend As Integer    ' last char before </BODY>
  256.     Dim blen As Integer    ' length of body
  257.  
  258.     inp = StringFromFile(filename)
  259.     inlc = LCase$(inp)
  260.  
  261.     ' try to strip out everything between BODY tags
  262.     ' if they exist
  263.  
  264.     bstart = InStr(inlc, "<body>")
  265.     If bstart = 0 Then
  266.         ' no body start tag
  267.         StringFromHTMLFile = inp
  268.         Exit Function
  269.     End If
  270.  
  271.     ' step over start tag
  272.     bstart = bstart + Len("<body>")
  273.  
  274.     bend = InStr(bstart, inlc, "</body>")
  275.     If bend = 0 Then
  276.         ' no body end tag
  277.         StringFromHTMLFile = inp
  278.         Exit Function
  279.     End If
  280.  
  281.     ' extract body from input string (NOT lower case version)!
  282.     blen = bend - bstart
  283.     If blen > 0 Then
  284.         StringFromHTMLFile = Mid$(inp, bstart, blen)
  285.     Else
  286.         StringFromHTMLFile = ""
  287.     End If
  288.  
  289. End Function
  290.  
  291. Function StringSubstitute(inp As String, search As String, replace As String) As String
  292.  
  293.     Dim sloc As Integer   ' current location in input
  294.     Dim floc As Integer   ' where next search string is found
  295.     Dim out As String     ' output string
  296.     Dim xlen As Integer   ' length of string to be extracted
  297.     Dim xstr As String    ' extracted string to left of found search string
  298.     Dim slen As Integer   ' length of search string
  299.  
  300.     out = ""
  301.  
  302.     If inp = "" Or search = "" Then
  303.         StringSubstitute = inp
  304.         Exit Function
  305.     End If
  306.  
  307.     slen = Len(search)
  308.     sloc = 1
  309.     
  310. StringSubstituteAgain:
  311.  
  312.     floc = InStr(sloc, inp, search)
  313.     If floc > 0 Then
  314.         ' found match
  315.         xlen = floc - sloc
  316.         If xlen > 0 Then
  317.             ' copy input to left of match to output
  318.             xstr = Mid$(inp, sloc, xlen)
  319.         Else
  320.             ' nothing to copy
  321.             xstr = ""
  322.         End If
  323.         out = out & xstr & replace
  324.         sloc = floc + slen
  325.         GoTo StringSubstituteAgain
  326.     Else
  327.         ' copy remaining part of string to output
  328.         out = out & Mid$(inp, sloc)
  329.     End If
  330.  
  331.     StringSubstitute = out
  332.  
  333. End Function
  334.  
  335. Sub WriteBreak(f As Integer)
  336.  
  337.     Print #f, "<BR>"
  338.  
  339. End Sub
  340.  
  341. Sub WriteComment(f As Integer, text As String)
  342.  
  343.     Print #f, "<!-- "; text; " -->"
  344.  
  345. End Sub
  346.  
  347. Sub WriteDescriptionItem(f As Integer, Title As String, text As String)
  348.  
  349.     Print #f, "<DT>"; Title; "<DD>"; text
  350.  
  351. End Sub
  352.  
  353. Sub WriteFormCheck(f As Integer, fldname As String, checked As Integer)
  354.  
  355.     Dim q As String
  356.  
  357.     q = Chr$(34)  ' double quote
  358.  
  359.     Print #f, "<INPUT TYPE=CHECKBOX NAME="; q; fldname; q;
  360.     If checked Then
  361.         Print #f, " CHECKED";
  362.     End If
  363.     Print #f, ">"
  364.  
  365. End Sub
  366.  
  367. Sub WriteFormPassword(f As Integer, fldname As String, fldval As String, fldsize As Integer, fldlen As Integer)
  368.  
  369.     Dim q As String
  370.  
  371.     q = Chr$(34)  ' double quote
  372.  
  373.     Print #f, "<INPUT TYPE=PASSWORD NAME="; q; fldname; q; " VALUE="; q; fldval; q;
  374.     If fldsize > 0 Then  ' 0 means use default size
  375.         Print #f, " SIZE="; CStr(fldsize);
  376.     End If
  377.     If fldlen > 0 Then  ' 0 means no maxlength
  378.         Print #f, " MAXLENGTH="; CStr(fldlen);
  379.     End If
  380.     Print #f, ">"
  381.  
  382. End Sub
  383.  
  384. Sub WriteFormRadio(f As Integer, fldname As String, fldval As Integer, checked As Integer)
  385.  
  386.     Dim q As String
  387.  
  388.     q = Chr$(34)  ' double quote
  389.  
  390.     Print #f, "<INPUT TYPE=RADIO NAME="; q; fldname; q; " VALUE="; q; fldval; q;
  391.     If checked Then
  392.         Print #f, " CHECKED";
  393.     End If
  394.     Print #f, ">"
  395.  
  396. End Sub
  397.  
  398. Sub WriteFormReset(f As Integer, txtlabel As String)
  399.  
  400.     Dim q As String
  401.  
  402.     q = Chr$(34)  ' double quote
  403.  
  404.     Print #f, "<INPUT TYPE=RESET VALUE="; q; txtlabel; q; ">"
  405.  
  406. End Sub
  407.  
  408. Sub WriteFormSelectionItem(f As Integer, text As String, selected As Integer)
  409.  
  410.     Dim q As String
  411.  
  412.     q = Chr$(34)  ' double quote
  413.  
  414.     If selected Then
  415.         Print #f, "<OPTION SELECTED>"; text
  416.     Else
  417.         Print #f, "<OPTION>"; text
  418.     End If
  419.  
  420. End Sub
  421.  
  422. Sub WriteFormSubmit(f As Integer, txtlabel As String)
  423.  
  424.     Dim q As String
  425.  
  426.     q = Chr$(34)  ' double quote
  427.  
  428.     Print #f, "<INPUT TYPE=SUBMIT VALUE="; q; txtlabel; q; ">"
  429.  
  430. End Sub
  431.  
  432. Sub WriteFormTextBox(f As Integer, fldname As String, default As String, rows As Integer, cols As Integer)
  433.  
  434.     Dim q As String
  435.  
  436.     q = Chr$(34)  ' double quote
  437.  
  438.     Print #f, "<TEXTAREA NAME="; q; fldname; q;
  439.     If rows > 0 Then  ' 0 means use default rows
  440.         Print #f, " ROWS="; CStr(rows);
  441.     End If
  442.     If cols > 0 Then  ' 0 means use default cols
  443.         Print #f, " COLS="; CStr(cols);
  444.     End If
  445.     Print #f, ">";
  446.     If default <> "" Then
  447.         Print #f, default;
  448.     End If
  449.     Print #f, "</TEXTAREA>"
  450.  
  451. End Sub
  452.  
  453. Sub WriteFormTextLine(f As Integer, fldname As String, fldval As String, fldsize As Integer, fldlen As Integer)
  454.  
  455.     Dim q As String
  456.  
  457.     q = Chr$(34)  ' double quote
  458.  
  459.     Print #f, "<INPUT TYPE=TEXT NAME="; q; fldname; q; " VALUE="; q; fldval; q;
  460.     If fldsize > 0 Then  ' 0 means use default size
  461.         Print #f, " SIZE="; CStr(fldsize);
  462.     End If
  463.     If fldlen > 0 Then  ' 0 means no maxlength
  464.         Print #f, " MAXLENGTH="; CStr(fldlen);
  465.     End If
  466.     Print #f, ">"
  467.         
  468. End Sub
  469.  
  470. Sub WriteHeading(f As Integer, num As Integer, text As String)
  471.  
  472.     Dim hstr As String
  473.  
  474.     If num < 1 Then num = 1
  475.     If num > 6 Then num = 6
  476.     hstr = "H" & CStr(num)
  477.  
  478.     Print #f, "<" & hstr & ">";
  479.     Print #f, text;
  480.     Print #f, "</" & hstr & ">"
  481.  
  482. End Sub
  483.  
  484. Sub WriteImage(f As Integer, src As String, alt As String, align As String, ismap As Integer)
  485.  
  486.     Dim q As String
  487.     q = Chr$(34)    ' double quote
  488.  
  489.     Print #f, "<IMG SRC="; q; src; q;
  490.     If alt <> "" Then
  491.         Print #f, " ALT="; q; alt; q;
  492.     End If
  493.     If align <> "" Then
  494.         ' TODO: check for valid alignment attributes
  495.         Print #f, " ALIGN="; q; align; q;
  496.     End If
  497.     If ismap Then
  498.         Print #f, " ISMAP";
  499.     End If
  500.     Print #f, ">"
  501.  
  502. End Sub
  503.  
  504. Sub WriteListItem(f As Integer, text As String)
  505.  
  506.     Print #f, "<LI>"; text
  507.  
  508. End Sub
  509.  
  510. Sub WriteParagraph(f As Integer, text As String)
  511.  
  512.     Print #f, "<P>"; text; "</P>"
  513.  
  514. End Sub
  515.  
  516. Sub WriteRule(f As Integer)
  517.  
  518.     Print #f, "<HR>"
  519.  
  520. End Sub
  521.  
  522. Sub WriteText(f As Integer, text As String, nonewline As Integer)
  523.  
  524.     If nonewline Then
  525.         Print #f, text;
  526.     Else
  527.         Print #f, text
  528.     End If
  529.  
  530. End Sub
  531.  
  532.