codice:
<% @Language = VbScript %>
<% Response.Expires = 0 %>
<% Response.Buffer = false %>
<%
Class cInclude
public Fso
public WebServerFP
private IsFile
private Version
private TagAsp
private TagAspEnd
private TagComment
private TagCommentEnd
private Root
private CurrentFile
private sub Class_initialize()
Version = "3.0.0"
WebServerFP = Request.ServerVariables("APPL_PHYSICAL_PATH")
Set Fso = CreateObject("Scripting.FileSystemObject")
TagAsp = "<" & "%"
TagAspEnd = "%" & ">"
TagComment = "<!--"
TagCommentEnd = "-->"
Reset
end sub
public sub Credit()
end sub
public function Reset()
Root="":IsFile=True
end function
private function LeggiFile(NomeFile)
Dim f ,tMp,Path
Path = WebServerFP & NomeFile
on error resume next
Set f = fso.OpenTextFile(Path , 1,False, 0)
if err.number<>0 then
Response.Write("<p style=""font-family:verdana;font-size:11"">Include File in "& CurrentFile &" not Found [" & lCase(Path) &"]
")
Response.Write("<p style=""font-family:verdana;font-size:11"">Error "& Err.number &" [" & Err.Description &"]
")
Response.end
end if
on error goto 0
LeggiFile = f.ReadAll
f.close
Set f=nothing
End Function
private function ReadRemoteFile(Url)
Dim msxml
on error resume next
Set Msxml = Server.CreateObject("MSXML2.ServerXMLHTTP.4.0")
if err.number <>0 then
Set Msxml = Server.CreateObject("MSXML2.ServerXMLHTTP")
if err.number<>0 then
Response.Write("<p style=""font-family:verdana;font-size:11"">Componente MSXML2.SereverHTTP non installato
")
Response.Write("<p style=""font-family:verdana;font-size:11"">Impossibile utilizzare la funzione IncludeRemoteURL()
")
response.End
end if
end if
on error goto 0
Msxml.Open "GET", URL, false
Msxml.Send
content = Msxml.responseText
while Msxml.readyState<>4
wend
Set Msxml = nothing
ReadRemoteFile=Content
end function
public Function Truncate(nF,ByRef Path,byRef NomeFile)
Dim pS
nF = Replace(nF,"/","\")
pS = InStrRev(nF,"\")
If pS>0 then
Path = Mid(nF,1,pS)
NomeFile = Mid (nF,pS+1,Len(nF) - pS)
else
Path="":NomeFile=nF
end if
NomeFile=Replace(NomeFile,VbCrLf,"")
NomeFile=Replace(NomeFile,Chr(9),"")
end function
public function GetAsp(s,ch)
if s<>"" then
's = Trim(s)
GetAsp = ""
GetAsp = "response.write(" & chr(34) & replace(s,chr(34),chr(34) & chr(34) ) & chr(34) & ch &")"& vbCrLf
end if
end function
public function GetHTML(s)
Dim i,ar,tMp,LenAr,Test
tMp = ""
if s<>"" then
ar = split(s,VbCrLf)
If Mid(s,Len(s),1) = vbCrLf Then Test=true
ch = " & vbcrlf"
LenAr = uBound(ar)
for i = 0 to LenAr
if i = LenAr then
If Test = treu then ch=""
end if
tMp = tMp & GetAsp(ar(i),ch)
next
end if
GetHTML = tMp
end function
Private Function GetPar(s)
GetPar = Trim(Replace(s,chr(9),""))
end function
Public Function Directive(Line,sDirective,sParametri,byRef Value)
Dim pD
pD = InStr(1,Line,sDirective,1)
if pD>0 then
Directive = "#FOUND#"
if sParametri<>"" then
ar = split(sParametri,",")
for each v in ar
if InStr(pD,Line,v,1)>0 then
Directive = uCase(v)
pD = InStr(Line,"=")+1
Value = Trim(replace(Mid(Line,pD),chr(34),""))
exit function
end if
next
end if
else
Directive = "#NOT_FOUND#"
end if
end function
Public Function ProcInclude(VirtualPath ,File)
Dim Buffer,Result,TestScript,Pos,NextTag,TagEnd,pTagAsp,pTagCom,Value
result = ""
Pos = 1
TestScript = True
if IsFile=True then
Buffer = LeggiFile(VirtualPath & File)
else
IsFile = True
Buffer = File
end if
CurrentFile = File
while Buffer<>"" and TestScript
pTagAsp = InStr(Buffer,TagAsp)
pTagCom = instr(Buffer,TagComment)
If (pTagCom<>0 or pTagAsp<>0) then
if (pTagCom=0 and pTagAsp>0) or (pTagAsp<pTagCom and pTagAsp>0) then
TestScript = True
Pos = pTagAsp
NextTag = TagAsp
TagEnd = TagAspEnd
if mid(Buffer,pTagAsp+2,1)="=" then NextTag = NextTag & "="
else
if (pTagAsp=0 and pTagCom>0) or (pTagCom<pTagAsp and pTagCom>0) then
TestScript = True
Pos = pTagCom
NextTag = TagComment
TagEnd = tagCommentEnd
end if
end if
pTagEnd = Instr(buffer,TagEnd)
else
TestScript = False
end if
if Pos = 1 and TestScript then
sTr = Mid(buffer,Pos+Len(NextTag),pTagEnd-Pos-Len(NextTag) )
select case NextTag
case TagAsp
Result = Result & sTr & vbCrLf
Case TagAsp & "="
Result = Result & "response.write(" & sTr & ")" &vbCrLf
case TagComment
TestDirective = False
pC = InStr(Str,"#")
if pC>0 then
value=""
Select Case Directive(sTr,"INCLUDE","FILE,VIRTUAL",Value)
Case "FILE":
TestDirective=True
truncate VirtualPath & Value,p,n
result = result & ProcInclude(p,n)
Case "VIRTUAL":
truncate Value,p,n
result = result & ProcInclude(p,n)
TestDirective=true
Case Else
Response.Write("Syntax error in Include :"& str)
Response.end
end Select
end if
If Not TestDirective then Result = Result & GetHTML(Mid(buffer,Pos,pTagEnd-Pos+3))
end select
buffer = mid(buffer,pTagEnd + Len(TagEnd))
else
Result = Result & GetHtml(mid(Buffer,1,Pos-1))
if TestScript then
buffer = mid(buffer,Pos)
else
result = result & GetHTML(Buffer)
end if
end if
wend
ProcInclude = result
end function
Public Function Include(NomeFile,Tipo)
Dim Path,File,tMp
if IsFile then Truncate NomeFile,Path,File
Select Case uCase(Tipo)
Case "FILE":
tMp = Replace(request.ServerVariables("URL"),"/","\")
Root = Mid(tMp,2,InStrRev(tMp,"\")-1) & Path
Case "VIRTUAL":
Root = Path
Case "VARIABLES":
File = NomeFile ' Al posto del nomeFile passo Il Contenuto che verr� assegnato a buffer
end select
CurrentFile = File
Include = ProcInclude(Root,File)
Reset
end function
public function IncludeVariables(Content)
IsFile=False
IncludeVariables=Include(Content,"VARIABLES")
end function
public function IncludeRemoteFile(URL)
IsFile=False
IncludeRemoteFile=Include(ReadRemoteFile(Url),"VARIABLES")
end function
private function Fill(number,ch,n)
dim s,v,i,result
result=""
s = cStr(number)
v = n - len(s)
for i = 1 to v
result = ch & result
next
fill = result & s
end function
public Function WriteASPCode(s,ShowLines)
dim ar,i,sTemp,j
arReservedWord = Array("Function ","Sub ","Private ","Public ","Class ","End Function","End Sub","End Class","Const ","Property ","Let ","Get ","End property","Response.Write","Execute")
arReservedColor = Array("red","red","black","black","green","red","red","green","black ","red","red","red","red","gray","red")
response.write("<table cellspacing=0 cellpagging=0 style=""font-size:11;font-family:verdana"">")
ar = split(s,vbCrLf)
for i=0 to uBound(ar)
If ShowLines then
sLine = fill(i,"0",6) & "."
end if
sTemp = Server.HTMLEncode(ar(i))
sTemp = replace(sTemp,vbTab,"")
for j=0 to uBound(arReservedWord)
sTemp = replace(sTemp,arReservedWord(j),"<b style=color:"&arReservedColor(j) &">" & arReservedWord(j) &"[/b]",1,-1,1)
next
response.write( "<tr><td valign=""top"" style=""color:gray"">" & sLine & "</td><td> "& sTemp & "</td></tr>")
next
response.write("</table>")
End function
private sub Class_Teriminate()
set fso = nothing
end sub
end class
function WriteASPCode(s,ShowLines)
Set oIncludeFile = new cInclude
oIncludeFile.WriteASPCode s,ShowLines
Set oIncludeFile=nothing
end function
function IncludeFile(NomeFile)
dim oIncludeFile,s
Set oIncludeFile = new cInclude
IncludeFile=oIncludeFile.Include(NomeFile,"FILE")
Set oIncludeFile=nothing
end Function
function IncludeVirtual(NomeFile)
dim oIncludeFile
Set oIncludeFile = new cInclude
IncludeVirtual=oIncludeFile.Include(NomeFile,"VIRTUAL")
Set oIncludeFile=nothing
end function
Function IncludeRemoteFile(URL)
dim oIncludeFile
Set oIncludeFile = new cInclude
IncludeRemoteFile = oIncludeFile.IncludeRemoteFile(URL)
Set oIncludeFile=nothing
end function
Function IncludeVariables(buffer)
dim oIncludeFile
Set oIncludeFile = new cInclude
IncludeVariables = oIncludeFile.IncludeVariables(buffer)
Set oIncludeFile=nothing
end function
Function Credit()
dim oIncludeFile
Set oIncludeFile = new cInclude
oIncludeFile.Credit()
Set oIncludeFile=nothing
end function%>
<%
response.buffer = true
'get key
key = request.querystring("key")
if key="" or isnull(key) then
key=request.form("key")
end if
if key="" or isnull(key) then response.redirect "default.asp"
'get action
a=request.form("a")
if a="" or isnull(a) then
a="I" 'display with input box
end if
' Open Connection to the database
set conn = Server.CreateObject("ADODB.Connection")
conn.Open xDb_Conn_Str
Select Case a
Case "I": ' Get a record to display
tkey = key
strsql = "SELECT * FROM [accouncements1] WHERE [ID]=" & tkey
set rs = Server.CreateObject("ADODB.Recordset")
rs.Open strsql, conn
If rs.EOF Then
Response.Clear
Response.Redirect "default.asp"
Else
rs.MoveFirst
End If
' Get the field contents
x_Title = rs("Title")
x_DetailedNotes = rs("DetailedNotes")
x_date = rs("date")
x_Keywords = rs("Keywords")
rs.Close
Set rs = Nothing
End Select
%>
<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
<html><head>
<meta http-equiv="Content-Language" content="it">
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<title>A S U N I S & C O - A DESIGN FOR LIFE</title>
<script type="text/javascript" src="js/highslide.js"></script>
<link rel="stylesheet" type="text/css" href="global_asunis.css">
<script type="text/javascript">hs.graphicsDir = 'js/graphics/';</script>
</head>
<body>
<%Execute IncludeVariables(x_DetailedNotes)%>
</body>
</html>
la classe è inclusa nel codice della pagina.
Rispondi quotando