codice:
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 <b>"& CurrentFile &"</b> not Found [<b>" & lCase(Path) &"</b>]<p>")
Response.Write("<p style=""font-family:verdana;font-size:11"">Error <b>"& Err.number &"</b> [<b>" & Err.Description &"</b>]<p>")
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 <b>MSXML2.SereverHTTP </b> non installato<br>")
Response.Write("<p style=""font-family:verdana;font-size:11"">Impossibile utilizzare la funzione IncludeRemoteURL()<br>")
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
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
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
Rispondi quotando
Originariamente inviata da Fidelio-565
