Dieser Artikel stellt einen vollständigen Satz von ASP-Sammlungsfunktionen bereit, einschließlich Funktionen wie dem Extrahieren der Originalzeichen der Adresse, dem Speichern von Remote-Dateien bei der lokalen simulierten Anmeldung und dem Abrufen des Quellcodes einer Webseite.
Kopieren Sie den Codecode wie folgt:
'============================================== = =
'Funktionsname: GetHttpPage
'Funktion: Holen Sie sich den Quellcode der Webseite
'Parameter: HttpUrl ------Webseitenadresse
'============================================== = =
Funktion GetHttpPage(HttpUrl)
Wenn IsNull(HttpUrl)=True oder Len(HttpUrl)<18 oder HttpUrl="$False$" dann
GetHttpPage="$False$"
Exit-Funktion
Ende wenn
Http dimmen
Setze Http=server.createobject("MSX" & "ML2.XM" & "LHT" & "TP")
Http.open „GET“,HttpUrl,False
Http.Send()
Wenn Http.Readystate<>4 dann
Setzen Sie Http=Nothing
GetHttpPage="$False$"
Exit-Funktion
Beenden Sie, wenn
GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
GetHTTPPage=replace(replace(GetHTTPPage , vbCr,""),vbLf,"")
Setzen Sie Http=Nothing
Wenn Err.number<>0 dann
Fehler.Klar
Ende wenn
Funktion beenden
'============================================== = =
'Funktionsname: BytesToBstr
'Funktion: Konvertieren Sie den erhaltenen Quellcode in Chinesisch
'Parameter: Body ------Variable, die konvertiert werden soll
'Parameter: Cset ------Typ, der konvertiert werden soll
'============================================== = =
Funktion BytesToBstr(Body,Cset)
Dim Objstream
Setze Objstream = Server.CreateObject("ad" & "odb.str" & "eam")
objstream.Type = 1
objstream.Mode =3
objstream.Öffnen
objstream.Text schreiben
objstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Schließen
set objstream = nichts
Funktion beenden
'============================================== = =
'Funktionsname: PostHttpPage
'Funktion: Anmelden
'============================================== = =
Funktion PostHttpPage(RefererUrl,PostUrl,PostData)
DimxmlHttp
DimRetStr
Setze xmlHttp = CreateObject("Msx" & "ml2.XM" & "LHT" & "TP")
xmlHttp.Open „POST“, PostUrl, False
XmlHTTP.setRequestHeader „Content-Length“,Len(PostData)
xmlHttp.setRequestHeader „Content-Type“, „application/x-www-form-urlencoded“
xmlHttp.setRequestHeader „Referer“, RefererUrl
xmlHttp.Send PostData
Wenn Err.Number <> 0, dann
Setze xmlHttp=Nothing
PostHttpPage = "$False$"
Exit-Funktion
Ende wenn
PostHttpPage=bytesToBSTR(xmlHttp.responseBody,"GB2312")
Setze xmlHttp = nichts
Funktion beenden
'============================================== = =
'Funktionsname: UrlEncoding
'Funktion: Kodierung konvertieren
'============================================== = =
Funktion UrlEncoding(DataStr)
Dim StrReturn, Si, ThisChr, InnerCode, Hight8, Low8
StrReturn = ""
Für Si = 1 bis Len(DataStr)
ThisChr = Mid(DataStr,Si,1)
Wenn Abs(Asc(ThisChr)) < &HFF Dann
StrReturn = StrReturn & ThisChr
Anders
InnerCode = Asc(ThisChr)
Wenn InnerCode < 0, dann
InnerCode = InnerCode + &H10000
Ende wenn
Hight8 = (InnerCode And &HFF00)/ &HFF
Low8 = InnerCode und &HFF
StrReturn = StrReturn & „%“ & Hex(Hight8) & „%“ & Hex(Low8)
Ende wenn
Nächste
UrlEncoding = StrReturn
Funktion beenden
'============================================== = =
'Funktionsname: GetBody
'Funktion: Zeichenfolge abfangen
'Parameter: ConStr ------Die abzufangende Zeichenfolge
'Parameter: StartStr ------Startzeichenfolge
'Parameter: OverStr ------Endstring
'Parameter: IncluL ------Ob StartStr enthalten ist
'Parameter:IncluR ------ob OverStr eingeschlossen werden soll
'============================================== = =
Funktion GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
Wenn ConStr="$False$" oder ConStr="" oder IsNull(ConStr)=True oder StartStr="" oder IsNull(StartStr)=True oder OverStr="" oder IsNull(OverStr)=True, dann
GetBody="$False$"
Exit-Funktion
Ende wenn
DimConStrTemp
Dim Start, Over
ConStrTemp=Lcase(ConStr)
StartStr=Lcase(StartStr)
OverStr=Lcase(OverStr)
Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
Wenn Start<=0 dann
GetBody="$False$"
Exit-Funktion
Anders
Wenn IncluL=False, dann
Start=Start+LenB(StartStr)
Ende wenn
Ende wenn
Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
Wenn Over<=0 oder Over<=Start dann
GetBody="$False$"
Exit-Funktion
Anders
Wenn InclR=True, dann
Over=Over+LenB(OverStr)
Ende wenn
Ende wenn
GetBody=MidB(ConStr,Start,Over-Start)
Funktion beenden
'============================================== = =
'Funktionsname: GetArray
'Funktion: Extrahieren Sie die Linkadresse, getrennt durch $Array$
'Parameter: ConStr ------Extrahieren Sie die Originalzeichen der Adresse
'Parameter: StartStr ------Startzeichenfolge
'Parameter: OverStr ------Endstring
'Parameter: IncluL ------Ob StartStr enthalten ist
'Parameter:IncluR ------ob OverStr eingeschlossen werden soll
'============================================== = =
Funktion GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
Wenn ConStr="$False$" oder ConStr="" oder IsNull(ConStr)=True oder StartStr="" oder OverStr="" oder IsNull(StartStr)=True oder IsNull(OverStr)=True, dann
GetArray="$False$"
Exit-Funktion
Ende wenn
Dimmen Sie TempStr,TempStr2,objRegExp,Matches,Match
TempStr=""
Setze objRegExp = Neuer Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "("&StartStr&").+?("&OverStr&")"
Übereinstimmungen festlegen =objRegExp.Execute(ConStr)
Für jedes Spiel in Spielen
TempStr=TempStr & "$Array$" & Match.Value
Nächste
Setze Übereinstimmungen=nichts
Wenn TempStr="" Dann
GetArray="$False$"
Exit-Funktion
Ende wenn
TempStr=Right(TempStr,Len(TempStr)-7)
Wenn IncluL=False, dann
objRegExp.Pattern =StartStr
TempStr=objRegExp.Replace(TempStr,"")
Beenden Sie, wenn
Wenn InclR=False, dann
objRegExp.Pattern =OverStr
TempStr=objRegExp.Replace(TempStr,"")
Beenden Sie, wenn
Setze objRegExp=nothing
Setze Übereinstimmungen=nichts
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr," ","")
TempStr=Replace(TempStr,"(","")
TempStr=Replace(TempStr,")","")
Wenn TempStr="", dann
GetArray="$False$"
Anders
GetArray=TempStr
Beenden Sie, wenn
Funktion beenden
'============================================== = =
'Funktionsname: DefiniteUrl
'Funktion: Relative Adresse in absolute Adresse umwandeln
'Parameter: PrimitiveUrl ------ relative Adresse, die konvertiert werden soll
'Parameter: ConsultUrl ------Aktuelle Webseitenadresse
'============================================== = =
Funktion DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
Dim ConTemp, PriTemp, Pi, Ci, PriArray, ConArray
Wenn PrimitiveUrl="" oder ConsultUrl="" oder PrimitiveUrl="$False$" oder ConsultUrl="$False$" Dann
DefiniteUrl="$False$"
Exit-Funktion
Ende wenn
If Left(Lcase(ConsultUrl),7)<>"http://" Then
ConsultUrl= "http://" & ConsultUrl
Ende wenn
ConsultUrl=Replace(ConsultUrl,"/","/")
ConsultUrl=Replace(ConsultUrl,"://","://")
PrimitiveUrl=Replace(PrimitiveUrl,"/","/")
If Right(ConsultUrl,1)<>"/" Then
Wenn Instr(ConsultUrl,"/")>0 Dann
Wenn Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 dann
Anders
ConsultUrl=ConsultUrl & "/"
Ende wenn
Anders
ConsultUrl=ConsultUrl & "/"
Ende wenn
Ende wenn
ConArray=Split(ConsultUrl,"/")
Wenn Left(LCase(PrimitiveUrl),7) = "http://", dann
DefiniteUrl=Replace(PrimitiveUrl,"://","://")
ElseIf Left(PrimitiveUrl,1) = "/" Then
DefiniteUrl=ConArray(0) & PrimitiveUrl
ElseIf Left(PrimitiveUrl,2)="./" Then
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-2)
Wenn Right(ConsultUrl,1)="/" Dann
DefiniteUrl=ConsultUrl & PrimitiveUrl
Anders
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
Ende wenn
ElseIf Left(PrimitiveUrl,3)="../" then
Do While Left(PrimitiveUrl,3)="../"
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)
Pi=Pi+1
Schleife
Für Ci=0 bis (Ubound(ConArray)-1-Pi)
Wenn DefiniteUrl<>"" Dann
DefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)
Anders
DefiniteUrl=ConArray(Ci)
Ende wenn
Nächste
DefiniteUrl=DefiniteUrl & „/“ & PrimitiveUrl
Anders
Wenn Instr(PrimitiveUrl,"/")>0 Dann
PriArray=Split(PrimitiveUrl,"/")
Wenn Instr(PriArray(0),".")>0 Dann
Wenn Right(PrimitiveUrl,1)="/" Dann
DefiniteUrl="http://" & PrimitiveUrl
Anders
Wenn Instr(PriArray(Ubound(PriArray)-1),".")>0 Dann
DefiniteUrl="http://" & PrimitiveUrl
Anders
DefiniteUrl="http://" & PrimitiveUrl & "/"
Ende wenn
Ende wenn
Anders
Wenn Right(ConsultUrl,1)="/" Dann
DefiniteUrl=ConsultUrl & PrimitiveUrl
Anders
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
Ende wenn
Ende wenn
Anders
Wenn Instr(PrimitiveUrl,".")>0 Dann
Wenn Right(ConsultUrl,1)="/" Dann
Wenn right(LCase(PrimitiveUrl),3)=".cn" oder right(LCase(PrimitiveUrl),3)="com" oder right(LCase(PrimitiveUrl),3)="net" oder right(LCase(PrimitiveUrl) ,3)="org" Dann
DefiniteUrl="http://" & PrimitiveUrl & "/"
Anders
DefiniteUrl=ConsultUrl & PrimitiveUrl
Ende wenn
Anders
Wenn right(LCase(PrimitiveUrl),3)=".cn" oder right(LCase(PrimitiveUrl),3)="com" oder right(LCase(PrimitiveUrl),3)="net" oder right(LCase(PrimitiveUrl) ,3)="org" Dann
DefiniteUrl="http://" & PrimitiveUrl & "/"
Anders
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl
Ende wenn
Ende wenn
Anders
Wenn Right(ConsultUrl,1)="/" Dann
DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"
Anders
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"
Ende wenn
Ende wenn
Ende wenn
Ende wenn
Wenn Left(DefiniteUrl,1)="/" dann
DefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)
Beenden Sie, wenn
Wenn DefiniteUrl<>"" Dann
DefiniteUrl=Replace(DefiniteUrl,"//","/")
DefiniteUrl=Replace(DefiniteUrl,"://","://")
Anders
DefiniteUrl="$False$"
Ende wenn
Funktion beenden
'============================================== = =
'Funktionsname: ReplacementSaveRemoteFile
Funktion: Remote-Bilder ersetzen und speichern
'Parameter: ConStr ------ zu ersetzende Zeichenfolge
'Parameter: SaveTf ------ Gibt an, ob die Datei gespeichert werden soll. False speichert nicht, True speichert
'Parameter: TistUrl------ aktuelle Webseitenadresse
'============================================== = =
Funktion ReplacementSaveRemoteFile(ConStr,InstallPath,strChannelDir,SaveTf,TistUrl)
Wenn ConStr="$False$" oder ConStr="" oder InstallPath="" oder strChannelDir="" Dann
ReplacementSaveRemoteFile=ConStr
Exit-Funktion
Ende wenn
Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
Setze Re = Neuer regulärer Ausdruck
Re.IgnoreCase = True
Re.Global = True
Re.Pattern ="<img.+?>"
Set Matches =Re.Execute(ConStr)
Für jedes Spiel in Spielen
Wenn TempStr<>"" dann
TempStr=TempStr & "$Array$" & Match.Value
Anders
TempStr=Match.Value
Beenden Sie, wenn
Nächste
Wenn TempStr<>"" Dann
TempArray=Split(TempStr,"$Array$")
TempStr=""
Für Tempi=0 bis Ubound(TempArray)
Re.Pattern ="src/s*=/s*.+?/.(gifjpgbmpjpegpsdpngsvgdxfwmftiff)"
Set Matches =Re.Execute(TempArray(Tempi))
Für jedes Spiel in Spielen
Wenn TempStr<>"" dann
TempStr=TempStr & "$Array$" & Match.Value
Anders
TempStr=Match.Value
Beenden Sie, wenn
Nächste
Nächste
Beenden Sie, wenn
Wenn TempStr<>"" Dann
Re.Pattern="src/s*=/s*"
TempStr=Re.Replace(TempStr,"")
Ende wenn
Setze Übereinstimmungen=nichts
Setze Re=nichts
Wenn TempStr="" oder IsNull(TempStr)=True, dann
ReplacementSaveRemoteFile=ConStr
Exit-Funktion
Beenden Sie, wenn
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr," ","")
Dimmen Sie RemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_Path
DtNow=Now()
'*********************************
Wenn SaveTf=True, dann
SavePath=InstallPath&strChannelDir
Wenn CheckDir(InstallPath & strChannelDir)=False, dann
Wenn nicht, CreateMultiFolder(InstallPath & strChannelDir) Dann
Response.Write InstallPath & strChannelDir&"Verzeichniserstellung fehlgeschlagen"
SaveTf=False
Ende wenn
Ende wenn
Ende wenn
„Beginnen Sie damit, doppelte Bilder zu entfernen.“
TempArray=Split(TempStr,"$Array$")
TempStr=""
Für Tempi=0 bis Ubound(TempArray)
Wenn Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Dann
TempStr=TempStr & "$Array$" & TempArray(Tempi)
Ende wenn
Nächste
TempStr=Right(TempStr,Len(TempStr)-7)
TempArray=Split(TempStr,"$Array$")
„Doppelte Bilder entfernen und beenden.“
Response.Write „<br>Bild gefunden:<br>“&Replace(TempStr,“$Array$“,<br>“)
'Beginnen Sie mit der Konvertierung relativer Bildadressen
TempStr=""
Für Tempi=0 bis Ubound(TempArray)
TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
Nächste
TempStr=Right(TempStr,Len(TempStr)-7)
TempStr=Replace(TempStr,Chr(0),"")
TempArray2=Split(TempStr,"$Array$")
TempStr=""
'Ende der Konvertierung der relativen Bildadresse
'Bild ersetzen/speichern
Setze Re = Neuer regulärer Ausdruck
Re.IgnoreCase = True
Re.Global = True
Für Tempi=0 bis Ubound(TempArray2)
'*********************************
RemoteFileUrl=TempArray2(Tempi)
Wenn RemoteFileUrl<>"$False$" und SaveTf=True, dann speichern Sie das Bild
ArrSaveFileName = Split(RemoteFileurl,".")
strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'Dateityp
Wenn strFileType="asp" oder strFileType="asa" oder strFileType="aspx" oder strFileType="cer" oder strFileType="cdx" oder strFileType="exe" oder strFileType="rar" oder strFileType="zip" dann
UploadFiles=""
ReplacementSaveRemoteFile=ConStr
Exit-Funktion
Ende wenn
Randomisieren
RanNum=Int(900*Rnd)+100
strFileName = Jahr(DtNow) & right("0" & Monat(DtNow),2) & right("0" & Tag(DtNow),2) & right("0" & Stunde(DtNow). ),2) & right ("0" & minute(DtNow),2) & right("0" & second(DtNow),2) & ranNum & "."
Re.Pattern =TempArray(Tempi)
Response.Write „<br>Speichern unter lokaler Adresse:“&InstallPath & strChannelDir & strFileName
Wenn SaveRemoteFile(InstallPath & strChannelDir & strFileName,RemoteFileUrl,RemoteFileUrl)=True, dann
Antwort. Schreiben Sie „<font color=blue>Erfolg</font><br>“
PathTemp=InstallPath & strChannelDir & strFileName
ConStr=Re.Replace(ConStr,PathTemp)
Re.Pattern=InstallPath&strChannelDir
UploadFiles=UploadFiles & "" & InstallPath & strChannelDir & strFileName
Anders
PathTemp=RemoteFileUrl
ConStr=Re.Replace(ConStr,PathTemp)
Ende wenn
ElseIf RemoteFileurl<>"$False$" und SaveTf=False Then'Speichern Sie das Bild nicht
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
Ende wenn
'*********************************
Nächste
Setze Re=nichts
ReplacementSaveRemoteFile=ConStr
Funktion beenden
'============================================== = =
'Funktionsname: ReplacementSwfFile
'Funktion: Animationspfad analysieren
'Parameter: ConStr ------ zu ersetzende Zeichenfolge
'Parameter: TistUrl------ aktuelle Webseitenadresse
'============================================== = =
Funktion ReplacementSwfFile(ConStr,TistUrl)
Wenn ConStr="$False$" oder ConStr="" oder TistUrl="" oder TistUrl="$False$" Dann
ReplacementSwfFile=ConStr
Exit-Funktion
Ende wenn
Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
Setze Re = Neuer regulärer Ausdruck
Re.IgnoreCase = True
Re.Global = True
Re.Pattern = „<object.+?[^/>]>“
Set Matches =Re.Execute(ConStr)
Für jedes Spiel in Spielen
Wenn TempStr<>"" dann
TempStr=TempStr & "$Array$" & Match.Value
Anders
TempStr=Match.Value
Beenden Sie, wenn
Nächste
Wenn TempStr<>"" Dann
TempArray=Split(TempStr,"$Array$")
TempStr=""
Für Tempi=0 bis Ubound(TempArray)
Re.Pattern = „value/s*=/s*.+?/.swf“
Set Matches =Re.Execute(TempArray(Tempi))
Für jedes Spiel in Spielen
Wenn TempStr<>"" dann
TempStr=TempStr & "$Array$" & Match.Value
Anders
TempStr=Match.Value
Beenden Sie, wenn
Nächste
Nächste
Beenden Sie, wenn
Wenn TempStr<>"" Dann
Re.Pattern = „value/s*=/s*“
TempStr=Re.Replace(TempStr,"")
Ende wenn
Wenn TempStr="" oder IsNull(TempStr)=True, dann
ReplacementSwfFile=ConStr
Exit-Funktion
Beenden Sie, wenn
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,"'","")
TempStr=Replace(TempStr," ","")
Setze Übereinstimmungen=nichts
Setze Re=nichts
„Beginnen Sie damit, doppelte Dateien zu entfernen.“
TempArray=Split(TempStr,"$Array$")
TempStr=""
Für Tempi=0 bis Ubound(TempArray)
Wenn Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Dann
TempStr=TempStr & "$Array$" & TempArray(Tempi)
Ende wenn
Nächste
TempStr=Right(TempStr,Len(TempStr)-7)
TempArray=Split(TempStr,"$Array$")
'Doppelte Dateien entfernen und beenden
'Beginnen Sie mit der Konvertierung relativer Adressen
TempStr=""
Für Tempi=0 bis Ubound(TempArray)
TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
Nächste
TempStr=Right(TempStr,Len(TempStr)-7)
TempStr=Replace(TempStr,Chr(0),"")
TempArray2=Split(TempStr,"$Array$")
TempStr=""
'Ende der Konvertierung der relativen Adresse
'ersetzen
Setze Re = Neuer regulärer Ausdruck
Re.IgnoreCase = True
Re.Global = True
Für Tempi=0 bis Ubound(TempArray2)
RemoteFileUrl=TempArray2(Tempi)
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
Nächste
Setze Re=nichts
ReplacementSwfFile=ConStr
Funktion beenden
'============================================== = =
'Prozessname: SaveRemoteFile
'Funktion: Remote-Dateien lokal speichern
'Parameter: LocalFileName ------ lokaler Dateiname
'Parameter: RemoteFileUrl ------ Remote-Datei-URL
'Parameter: Referrer ------ Remote-Aufrufdatei (für Anti-Sammlung verwenden Sie die Adresse der Inhaltsseite, lassen Sie es leer, wenn keine Anti-Sammlung vorhanden ist)
'============================================== = =
Funktion SaveRemoteFile(LocalFileName,RemoteFileUrl,Referer)
SaveRemoteFile=True
dim Ads,Retrieval,GetRemoteData
Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
Mit Abruf
.Öffnen Sie „Get“, RemoteFileUrl, False, „“, „“
if Referer<>"" then .setRequestHeader "Referer",Referer
.Schicken
Wenn .Readystate<>4 dann
SaveRemoteFile=False
Exit-Funktion
Ende wenn
GetRemoteData = .ResponseBody
Ende mit
Abruf festlegen = Nichts
Set Ads = Server.CreateObject("Adodb.Stream")
Mit Werbung
.Typ = 1
.Offen
.GetRemoteData schreiben
.SaveToFile server.MapPath(LocalFileName),2
.Stornieren()
.Schließen()
Ende mit
Legen Sie „Anzeigen=nichts“ fest
end Funktion
'============================================== = =
'Funktionsname: GetPaing
'Funktion: Paginierung abrufen
'============================================== = =
Funktion GetPaing(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
Wenn ConStr="$False$" oder ConStr="" oder StartStr="" oder OverStr="" oder IsNull(ConStr)=True oder IsNull(StartStr)=True oder IsNull(OverStr)=True, dann
GetPaing="$False$"
Exit-Funktion
Ende wenn
Dimmen Sie Start, Over, ConTemp, TempStr
TempStr=LCase(ConStr)
StartStr=LCase(StartStr)
OverStr=LCase(OverStr)
Over=Instr(1,TempStr,OverStr)
Wenn Over<=0 Dann
GetPaing="$False$"
Exit-Funktion
Anders
Wenn InclR=True, dann
Over=Over+Len(OverStr)
Ende wenn
Ende wenn
TempStr=Mid(TempStr,1,Over)
Start=InstrRev(TempStr,StartStr)
Wenn IncluL=False, dann
Start=Start+Len(StartStr)
Ende wenn
Wenn Start<=0 oder Start>=Over Then
GetPaing="$False$"
Exit-Funktion
Ende wenn
ConTemp=Mid(ConStr,Start,Over-Start)
ConTemp=Trim(ConTemp)
'ConTemp=Replace(ConTemp," ","")
ConTemp=Replace(ConTemp,",","")
ConTemp=Replace(ConTemp,"'","")
ConTemp=Replace(ConTemp,"""","")
ConTemp=Replace(ConTemp,">","")
ConTemp=Replace(ConTemp,"<","")
ConTemp=Replace(ConTemp," ;","")
GetPaing=ConTemp
Funktion beenden
'**************************************************
'Funktionsname: gotTopic
'Funktion: Die Zeichenfolge abschneiden, jedes chinesische Zeichen zählt als zwei Zeichen und das englische Zeichen zählt als ein Zeichen
'Parameter: str ---- Originalzeichenfolge
' strlen ---- Länge des Abschnitts
'Rückgabewert: abgefangener String
'**************************************************
Funktion gotTopic(str,strlen)
wenn str="" dann
gotTopic=""
Exit-Funktion
Ende wenn
dim l,t,c,i
str=replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<")
l=len(str)
t=0
für i=1 bis l
c=Abs(Asc(Mid(str,i,1)))
wenn c>255 dann
t=t+2
anders
t=t+1
Ende wenn
wenn t>=strlen dann
gotTopic=left(str,i) & „…“
Ausgang für
anders
gotTopic=str
Ende wenn
nächste
gotTopic=replace(replace(replace(replace(gotTopic," "," "),chr(34),"""),">",">"),"<","<;")
Endfunktion
'*********************************************
'Funktionsname: JoinChar
'Funktion: ? oder & zur Adresse hinzufügen
'Parameter: strUrl ---- URL
'Rückgabewert: URL mit ? oder & hinzugefügt
'*********************************************
Funktion JoinChar(strUrl)
if strUrl="" dann
JoinChar=""
Exit-Funktion
Ende wenn
if InStr(strUrl,"?")<len(strUrl) then
if InStr(strUrl,"?")>1 dann
if InStr(strUrl,"&")<len(strUrl) then
JoinChar=strUrl & "&"
anders
JoinChar=strUrl
Ende wenn
anders
JoinChar=strUrl & "?"
Ende wenn
anders
JoinChar=strUrl
Ende wenn
Endfunktion
'************************************************** *
'Funktionsname: CreateKeyWord
'Funktion: Schlüsselwörter aus der angegebenen Zeichenfolge generieren
'Parameter: Constr – die ursprüngliche Zeichenfolge zum Generieren des Schlüsselworts
'Rückgabewert: generiertes Schlüsselwort
'************************************************** *
Funktion CreateKeyWord(byval Constr,Num)
Wenn Constr="" oder IsNull(Constr)=True oder Constr="$False$" Dann
CreateKeyWord="$False$"
Exit-Funktion
Ende wenn
Wenn Num="" oder IsNumeric(Num)=False, dann
Anzahl=2
Ende wenn
Constr=Replace(Constr,CHR(32),"")
Constr=Replace(Constr,CHR(9),"")
Constr=Replace(Constr," ","")
Constr=Replace(Constr," ","")
Constr=Replace(Constr,"(","")
Constr=Replace(Constr,")","")
Constr=Replace(Constr,"<","")
Constr=Replace(Constr,">","")
Constr=Replace(Constr,"""","")
Constr=Replace(Constr,"?","")
Constr=Replace(Constr,"*","")
Constr=Replace(Constr,"","")
Constr=Replace(Constr,",","")
Constr=Replace(Constr,".","")
Constr=Replace(Constr,"/","")
Constr=Replace(Constr,"/","")
Constr=Replace(Constr,"-","")
Constr=Replace(Constr,"@","")
Constr=Replace(Constr,"#","")
Constr=Replace(Constr,"$","")
Constr=Replace(Constr,"%","")
Constr=Replace(Constr,"&","")
Constr=Replace(Constr,"+","")
Constr=Replace(Constr,::,"")
Constr=Replace(Constr,"：","")
Constr=Replace(Constr,"'","")
Constr=Replace(Constr,""","")
Constr=Replace(Constr,""","")
Dim i,ConstrTemp
Für i=1 zu Len(Constr)
ConstrTemp=ConstrTemp & "" & Mid(Constr,i,Num)
Nächste
Wenn Len(ConstrTemp)<254, dann
ConstrTemp=ConstrTemp & ""
Anders
ConstrTemp=Left(ConstrTemp,254) & ""
Ende wenn
CreateKeyWord=ConstrTemp
Funktion beenden
'============================================== = =
'Funktionsname: CheckUrl
'Funktion: URL prüfen
'Parameter: strUrl ------ Um die URL zu überprüfen
'============================================== = =
Funktion CheckUrl(strUrl)
Dim Re
Setze Re=new RegExp
Re.IgnoreCase=true
Re.Global=True
Re.Pattern="http://([/w-]+/.)+[/w-]+(/[/w-./?%&=]*)?"
Wenn Re.test(strUrl)=True, dann
CheckUrl=strUrl
Anders
CheckUrl="$False$"
Ende wenn
Setze Rs=Nichts
Funktion beenden
'============================================== = =
'Funktionsname: ScriptHtml
'Funktion: HTML-Tags filtern
'Parameter: ConStr ------ Die zu filternde Zeichenfolge
'============================================== = =
Funktion ScriptHtml(Byval ConStr,TagName,FType)
Dim Re
Setze Re=new RegExp
Re.IgnoreCase=true
Re.Global=True
Wählen Sie Fall-FType aus
Fall 1
Re.Pattern="<" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Fall 2
Re.Pattern="<" & TagName & "([^>])*>.*?</" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Fall 3
Re.Pattern="<" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Re.Pattern="</" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Endauswahl
ScriptHtml=ConStr
Setze Re=Nothing
Funktion beenden
'============================================== = =
'Funktionsname: RemoveHTML
'Funktion: HTML-Tags vollständig entfernen
'Parameter: strHTML ------ Die zu filternde Zeichenfolge
'============================================== = =
Funktion RemoveHTML(strHTML)
Dim objRegExp, Match, Matches
Setze objRegExp = Neuer Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
'Holen Sie sich das geschlossene <>
objRegExp.Pattern = "<.+?>"
'Übereinstimmen
Set Matches = objRegExp.Execute(strHTML)
' Durchlaufen Sie das passende Set und ersetzen Sie passende Elemente
Für jedes Spiel in Spielen
strHtml=Replace(strHTML,Match.Value,"")
Nächste
RemoveHTML=strHTML
Setze objRegExp = Nothing
Funktion beenden
'============================================== = =
'Funktionsname: CheckDir
'Funktion: Prüfen, ob der Ordner existiert
'Parameter: FolderPath ------ Ordnerpfad
'============================================== = =
Funktion CheckDir(byval FolderPath)
dim fso
Setze fso = Server.CreateObject("Scripting.FileSystemObject")
Wenn fso.FolderExists(Server.MapPath(folderpath)) dann
'existieren
CheckDir = True
Anders
'existiert nicht
CheckDir = False
Beenden Sie, wenn
Setze fso = nichts
Funktion beenden
'============================================== = =
'Funktionsname: MakeNewsDir
'Funktion: Einen Ordner erstellen
'Parameter: Ordnername ------ Ordnername
'============================================== = =
Funktion MakeNewsDir(byval Ordnername)
dim fso
Setze fso = Server.CreateObject("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
fso.CreateFolder(Server.MapPath(Ordnername))
Wenn fso.FolderExists(Server.MapPath(Ordnername)) dann
MakeNewsDir = True
Anders
MakeNewsDir = False
Ende wenn
Setze fso = nichts
Funktion beenden
'============================================== = =
'Funktionsname: DelDir
'Funktion: Einen Ordner erstellen
'Parameter: Ordnername ------ Ordnername
'============================================== = =
Funktion DelDir(byval Ordnername)
dim fso
Setze fso = Server.CreateObject("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
If fso.FolderExists(Server.MapPath(foldername)) Then 'Bestimmen Sie, ob der Ordner vorhanden ist.'
fso.DeleteFolder (Server.MapPath(foldername)) 'Ordner löschen
Ende wenn
Setze fso = nichts
Funktion beenden
'************************************************** *
'Funktionsname: IsObjInstalled
'Funktion: Prüfen, ob die Komponente installiert wurde
'Parameter: strClassString ---- Komponentenname
'Rückgabewert: True ---- Bereits installiert
' Falsch ---- nicht installiert
'************************************************** *
Funktion IsObjInstalled(strClassString)
IsObjInstalled = False
Fehler = 0
DimxTestObj
Setze xTestObj = Server.CreateObject(strClassString)
Wenn 0 = Err, dann ist IsObjInstalled = True
Setze xTestObj = Nothing
Fehler = 0
Funktion beenden
'************************************************** *
'Funktionsname: strLength
'Funktion: Ermitteln Sie die Länge der Zeichenfolge. Chinesische Schriftzeichen zählen als zwei Schriftzeichen und englische Schriftzeichen als ein Schriftzeichen.
'Parameter: str ----String mit erforderlicher Länge
'Rückgabewert: Stringlänge
'************************************************** *
Funktion strLength(str)
BEI FEHLER WEITERFAHREN
dimmen Sie WINNT_CHINESE
WINNT_CHINESE = (len("China")=2)
wenn WINNT_CHINESE dann
dim l,t,c
dim ich
l=len(str)
t=l
für i=1 bis l
c=asc(mid(str,i,1))
wenn c<0, dann c=c+65536
wenn c>255 dann
t=t+1
Ende wenn
nächste
strLength=t
anders
strLength=len(str)
Ende wenn
Wenn err.number<>0, dann err.clear
Endfunktion
'************************************************** * **
'Funktionsname: CreateMultiFolder
'Funktion: Erstellen Sie mehrstufige Verzeichnisse. Sie können nicht vorhandene Stammverzeichnisse erstellen
'Parameter: Der Name des zu erstellenden Verzeichnisses, das mehrstufig sein kann
'Logischen Wert zurückgeben: Wahr bei Erfolg, Falsch bei Fehler
'Erstellen Sie das Stammverzeichnis des Verzeichnisses, beginnend mit dem aktuellen Verzeichnis
'************************************************** * **
Funktion CreateMultiFolder(ByVal CFolder)
Dim objFSO,PhCreateFolder,CreateFolderArray,CreateFolder
Dim i,ii,CreateFolderSub,PhCreateFolderSub,BlInfo
BlInfo=Falsch
CreateFolder = CFolder
Bei Fehler Weiter fortsetzen
Setze objFSO = Server.CreateObject("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
Wenn Sie sich irren, dann
Err.Clear()
Exit-Funktion
Ende wenn
CreateFolder = Ersetzen(CreateFolder,"/","/")
Wenn Left(CreateFolder,1)="/" Dann
'CreateFolder = Right(CreateFolder,Len(CreateFolder)-1)
Ende wenn
Wenn Right(CreateFolder,1)="/" Dann
CreateFolder = Left(CreateFolder,Len(CreateFolder)-1)
Ende wenn
CreateFolderArray = Split(CreateFolder,"/")
Für i = 0 bis UBound(CreateFolderArray)
CreateFolderSub = ""
Für ii = 0 bis i
CreateFolderSub = CreateFolderSub & CreateFolderArray(ii) & "/"
Nächste
PhCreateFolderSub = Server.MapPath(CreateFolderSub)
'response.Write PhCreateFolderSub&"<br>"
Wenn nicht objFSO.FolderExists(PhCreateFolderSub) Dann
objFSO.CreateFolder(PhCreateFolderSub)
Ende wenn
Nächste
Wenn Sie sich irren, dann
Err.Clear()
Anders
BlInfo=True
Ende wenn
Setze objFSO=nichts
CreateMultiFolder = BlInfo
Funktion beenden
'************************************************** *
'Funktionsname: FSOFileRead
'Funktion: Verwenden Sie FSO, um die Dateiinhaltsfunktion zu lesen
'Parameter: Dateiname ---- Dateiname
'Rückgabewert: Dateiinhalt
'************************************************** *
Funktion FSOFileRead(Dateiname)
Dimmen Sie objFSO,objCountFile,FiletempData
Setze objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FSOFileRead = objCountFile.ReadAll
objCountFile.Close
Setze objCountFile=Nothing
Setze objFSO = Nichts
Funktion beenden
'************************************************** *
'Funktionsname: FSOlinedit
'Funktion: Verwenden Sie FSO, um eine bestimmte Zeile der Dateifunktion zu lesen
'Parameter: Dateiname ---- Dateiname
' lineNum ---- Zeilennummer
'Rückgabewert: der Inhalt der Zeile in der Datei
'************************************************** *
Funktion FSOlineedit(filename,lineNum)
Wenn Leinen < 1, dann beenden Sie die Funktion
dim fso,f,temparray,tempcnt
set fso = server.CreateObject("scripting.filesystemobject")
Wenn nicht fso.fileExists(server.mappath(filename)), dann beenden Sie die Funktion
set f = fso.opentextfile(server.mappath(filename),1)
wenn nicht f.AtEndofStream dann
tempcnt = f.readall
f.schließen
setze f = nichts
temparray = split(tempcnt,chr(13)&chr(10))
wenn lineNum>ubound(temparray)+1 dann
Exit-Funktion
anders
FSOlinedit = temparray(lineNum-1)
Ende wenn
Ende wenn
Endfunktion
'************************************************** *
'Funktionsname: FSOlinewrite
'Funktion: Verwenden Sie FSO, um eine bestimmte Zeile der Dateifunktion zu schreiben
'Parameter: Dateiname ---- Dateiname
' lineNum ---- Zeilennummer
' Zeileninhalt ---- Inhalt
'Rückgabewert: Keiner
'************************************************** *
Funktion FSOlinewrite(filename,lineNum,Linecontent)
Wenn Leinen < 1, dann beenden Sie die Funktion
dim fso,f,temparray,tempCnt
set fso = server.CreateObject("scripting.filesystemobject")
Wenn nicht fso.fileExists(server.mappath(filename)), dann beenden Sie die Funktion
set f = fso.opentextfile(server.mappath(filename),1)
wenn nicht f.AtEndofStream dann
tempcnt = f.readall
f.schließen
temparray = split(tempcnt,chr(13)&chr(10))
wenn lineNum>ubound(temparray)+1 dann
Exit-Funktion
anders
temparray(lineNum-1) = lineContent
Ende wenn
tempcnt = join(temparray,chr(13)&chr(10))
set f = fso.createtextfile(server.mappath(filename),true)
f.writetempcnt
Ende wenn
f.schließen
setze f = nichts
Endfunktion
'************************************************** *
'Funktionsname: Htmlmake
'Funktion: FSO zum Erstellen von Dateien verwenden
'Parameter: HtmlFolder ---- Pfad
' HtmlFilename ---- Dateiname
'HtmlContent ----Content
'************************************************** *
Funktion Htmlmake(HtmlFolder,HtmlFilename,HtmlContent)
Bei Fehler Weiter fortsetzen
Dateipfad,fso,fout dimmen
filepath = HtmlFolder&"/"&HtmlFilename
Setze fso = Server.CreateObject("Scripting.FileSystemObject")
Wenn fso.FolderExists(HtmlFolder) Dann
Anders
CreateMultiFolder(HtmlFolder)
&, ;nbs, p;
Setze fout = fso.Createtextfile(server.mappath(filepath),true)
fout.writeline HtmlContent
fout.close
setze fso=nichts
Setze fso = Server.CreateObject("Scripting.FileSystemObject")
Wenn fso.fileexists(Server.MapPath(filepath)) dann
Response.Write „Datei<font color=red>“&HtmlFilename&“</font> wurde generiert!<br>“
Anders
'Response.Write Server.MapPath(Dateipfad)
Response.Write „File<font color=red>“&HtmlFilename&“</font> wurde nicht generiert!<br>“
Ende wenn
Setze fso = nichts
Funktion beenden
'************************************************** *
'Funktionsname: Htmldel
'Funktion: FSO zum Löschen von Dateien verwenden
'Parameter: HtmlFolder ---- Pfad
' HtmlFilename ---- Dateiname
'************************************************** *
Sub Htmldel(HtmlFolder,HtmlFilename)
Dateipfad dimmen,fso
filepath = HtmlFolder&"/"&HtmlFilename
Setze fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFile(Server.mappath(Dateipfad))
Setze fso = nichts
Setze fso = Server.CreateObject("Scripting.FileSystemObject")
Wenn fso.fileexists(Server.MapPath(filepath)) dann
Response.Write „Datei<font color=red>“&HtmlFilename&“</font> wurde nicht gelöscht!<br>“
Anders
'Response.Write Server.MapPath(Dateipfad)
Response.Write „Datei<font color=red>“&HtmlFilename&“</font> wurde gelöscht!<br>“
Ende wenn
Setze fso = nichts
Sub beenden
'============================================== =
'Prozessname: HTMLEncode
'Funktion: HTML-Format filtern
'Parameter: fString ----Konvertierungsinhalt
'============================================== =
Funktion HTMLEncode(ByVal fString)
Wenn IsNull(fString)=False oder fString<>"" oder fString<>"$False$" Dann
fString = Ersetzen(fString, ">", ">")
fString = Ersetzen(fString, "<", "<")
fString = Ersetzen(fString, Chr(32), " ")
fString = Ersetzen(fString, Chr(9), " ")
fString = Ersetzen(fString, Chr(34), """)
fString = Ersetzen(fString, Chr(39), "'")
fString = Ersetzen(fString, Chr(13), "")
fString = Ersetzen(fString, " ", " ")
fString = Replacement(fString, CHR(10) & CHR(10), "</P><P>")
fString = Replacement(fString, Chr(10), "<br /> ")
HTMLEncode = fString
anders
HTMLEncode = "$False$"
Ende wenn
Endfunktion
'============================================== =
'Prozessname: unHTMLEncode
'Funktion: HTML-Format wiederherstellen
'Parameter: fString ----Konvertierungsinhalt
'============================================== =
Funktion unHTMLEncode(ByVal fString)
Wenn IsNull(fString)=False oder fString<>"" oder fString<>"$False$" Dann
fString = Ersetzen(fString, ">", ">")
fString = Ersetzen(fString, "<", "<")
fString = Ersetzen(fString, " ", Chr(32))
fString = Ersetzen(fString, """, Chr(34))
fString = Ersetzen(fString, "'", Chr(39))
fString = Ersetzen(fString, "", Chr(13))
fString = Ersetzen(fString, " ", " ")
fString = Replacement(fString, "</P><P>", CHR(10) & CHR(10))
fString = Replacement(fString, "<br> ", Chr(10))
unHTMLEncode = fString
anders
unHTMLEncode = "$False$"
Ende wenn
Endfunktion
Funktion unhtmllist(content)
unhtmllist=content
wenn Inhalt <> "", dann
unhtmllist=replace(unhtmllist,"'","";")
unhtmllist=replace(unhtmllist,chr(10),"")
unHtmllist=replace(unHtmllist,chr(13),"<br>")
Ende wenn
Endfunktion
Funktion unhtmllists(content)
unhtmllists=content
wenn Inhalt <> "", dann
unhtmllists=replace(unhtmllists,'''''''')
unhtmllists=replace(unhtmllists,"'","")
unhtmllists=replace(unhtmllists,chr(10),"")
unHtmllists=replace(unHtmllists,chr(13),"<br>")
Ende wenn
Endfunktion
Funktion htmllists(content)
htmllists=content
wenn Inhalt <> "", dann
htmllists=replace(htmllists,"''","""")
htmllists=replace(htmllists,"","'")
htmllists=replace(htmllists,"<br>",chr(13)&chr(10))
Ende wenn
Endfunktion
Funktion uhtmllists(content)
uhtmllists=content
wenn Inhalt <> "", dann
uhtlists=replace(uhtlists,'''''''''')
uhtlists=replace(uhtlists,"'","";")
uhtlists=replace(uhtlists,chr(10),"")
uHtmllists=replace(uHtmllists,chr(13),"<br>")
Ende wenn
Endfunktion
'============================================== =
„Prozess: Schlafen.“
'Funktion: Das Programm stoppt hier für einige Sekunden
'Parameter: iSeconds Anzahl der Sekunden, die pausiert werden sollen
'============================================== =
Nebenschlaf (iSeconds)
Antwort.Write „<font color=blue>Pausieren für „&iSeconds&“ Sekunden starten</font><br>“
Dimmen t:t=Timer()
While(Timer()<t+iSeconds)
„Nichts tun.“
Wend
Antwort. Schreiben Sie „<font color=blue>Pause“&iSeconds&“ Sekunden Ende</font><br>“
Sub beenden
'============================================== = =
'Funktionsname: MyArray
'Funktion: Tags zum Trennen extrahieren
'Parameter: ConStr ------Extrahieren Sie die Originalzeichen der Adresse
'============================================== = =
Funktion MyArray(ByvalConStr)
Setze objRegExp = Neuer Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "({).+?(})"
Übereinstimmungen festlegen =objRegExp.Execute(ConStr)
Für jedes Spiel in Spielen
TempStr=TempStr & "" & Match.Value
Nächste
Setze Übereinstimmungen=nichts
TempStr=Right(TempStr,Len(TempStr)-1)
objRegExp.Pattern="{"
TempStr=objRegExp.Replace(TempStr,"")
objRegExp.Pattern="}"
TempStr=objRegExp.Replace(TempStr,"")
Setze objRegExp=nothing
Setze Übereinstimmungen=nichts
TempStr=Replace(TempStr,"$","")
Wenn TempStr="", dann
MyArray="Nichts im Code zu extrahieren"
Anders
MyArray=TempStr
Beenden Sie, wenn
Funktion beenden
'============================================== = =
'Funktionsname: Randm
'Funktion: 6-stellige Zufallszahl generieren
'============================================== = =
Funktion randm
randomisieren
randm=Int((900000*rnd)+100000)
Funktion beenden
%>