|
Option Compare Database
Option Explicit 'Passare la lista degli identificativi e la chiave di ricerca Private Function MakeHTMLList(arrID() As Variant, strKEY As String) Dim dbs As Database Dim rst As Recordset Dim FL As Integer Dim i As Long Dim j As Long Dim strHead As String 'Parte iniziale Dim strList As String 'Elenco dei titoli delle tips Dim strBody As String 'Elenco dei codici delle tips Dim strEnd As String 'Parte finale Dim strTip As String 'Codice della tip Dim strTipFormatted As String 'Codice formattato della tip 'Creo le stringhe strHead = "<html><head><title>VBT32 CodeBookŪ 2000</title></head>" strHead = strHead & "<body link=#000080 vlink=#000080 alink=#000080>" strHead = strHead & "<p align=center><b><font face=arial size=6 color=#000080><u>" strHead = strHead & "<a name=top></a>VBT32 CodeBookŪ 2000</u></font><font _ color=#000080 face=arial size=4><br></font></b>" strHead = strHead & "<font color=#000080 face=arial size=4>Risultato ricerca _ con chiave: </font><b><font color=#FF0000 face=arial size=4>" strHead = strHead & UCase$(strKEY) & "</font></b><br><br>" strHead = strHead & "<div><font face=arial size=3 color=#000080><table _ border=0 width=100% cellspacing=5 cellpadding=5>" Set dbs = OpenDatabase("MIODB.MDB") For i = 0 To UBound(arrID) Set rst = dbs.OpenRecordset("SELECT * FROM codeitems WHERE ID=" & _ arrID(i) & ";", dbOpenForwardOnly) strList = strList & "<tr><td bgcolor=#FFFFCC><b><a href=#" & rst!id & _ ">[#" & rst!id & "] " & rst!Description & "</a></b></td></tr>" strBody = strBody & "<tr><td width=100% bgcolor=#000080><b><font _ color=#FFFFFF><a name=" & rst!id & "></a>" & rst!id & " - " & _ rst!Description & "</font></b></td></tr>" strBody = strBody & "<tr><td width=100%><font face=courier new size=3>" 'Prendo il codice per formattarlo strTip = rst!code For j = 1 To Len(strTip) If Mid$(strTip, j, 2) = vbNewLine Then 'Inserisco il ritorno a capo strTipFormatted = strTipFormatted & "<br>" j = j + 1 ElseIf Mid$(strTip, j, 1) = vbLf Then 'Inserisco il ritorno a capo strTipFormatted = strTipFormatted & "<br>" j = j + 1 ElseIf Mid$(strTip, j, Len(strKEY)) = strKEY Then 'Coloro ed evidenzio la chiave di ricerca strTipFormatted = strTipFormatted & _ "<span style=background-color:#FFFFCC><font _ color=#FF0000> " & strKEY & "</font></span>" j = j + Len(strKEY) - 1 Else 'Ricopio il carattere strTipFormatted = strTipFormatted & Mid$(strTip, j, 1) End If Next j 'Imposto la tip formattata strBody = strBody & strTipFormatted & "</font></td></tr></font></font>" strBody = strBody & "<tr><td width=100%><p align=right><a href=#top><font _ face=arial color=#000080 size=1>Ritorna all'Inizio</font></a></td></tr>" Next i 'Imposto la parte finale della lista dei titoli strList = strList & "</table></div><p> </p><div><font _ face=arial size=3><table border=0 cellpadding=5 cellspacing=5 width=100%>" 'Creo la parte finale della pagina strEnd = "</tr></table></div><p> </p><p><font face=arial _ size=2>by <a href=mailto:programmer@vbt32.cjb.net>Piras M.</a>" strEnd = strEnd & "& <a href=mailto:webmaster@vbt32.cjb.net>Sardi F.</a><br>" strEnd = strEnd & "<a href=http://vbt32.cjb.net/>http://vbt32.cjb.net/</a></font> _ </p></body></html>" 'Scrivo il file FL = FreeFile Open "C:\PROVAHTML.HTM" For Output As FL Print #FL, strHead; Print #FL, strList; Print #FL, strBody; Print #FL, strEnd; Close FL rst.Close: Set rst = Nothing dbs.Close: Set dbs = Nothing MsgBox "OK" End Function Private Function provalancio() Dim arrID(5) arrID(0) = 50 arrID(1) = 81 arrID(2) = 124 arrID(3) = 200 arrID(4) = 354 arrID(5) = 415 MakeHTMLList arrID, "DIM" End Function |