Cet article fournit un ensemble complet de fonctions de collecte ASP, notamment des fonctions telles que l'extraction des caractères originaux de l'adresse, l'enregistrement de fichiers distants dans une connexion simulée locale et l'obtention du code source d'une page Web.
Copiez le code comme suit :
'================================================== = =
'Nom de la fonction : GetHttpPage
'Fonction : Récupérer le code source de la page web
'Paramètre : HttpUrl ------Adresse de la page Web
'================================================== = =
Fonction GetHttpPage(HttpUrl)
Si IsNull(HttpUrl)=True ou Len(HttpUrl)<18 ou HttpUrl="$False$" alors
GetHttpPage="$False$"
Fonction de sortie
Fin si
Faible Http
Définir Http=server.createobject("MSX" & "ML2.XM" & "LHT" & "TP")
Http.open "GET",HttpUrl,False
Http.Envoyer()
Si Http.Readystate<>4 alors
Définir Http=Rien
GetHttpPage="$False$"
Fonction de sortie
Terminer si
GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
GetHTTPPage=remplacer(remplacer(GetHTTPPage , vbCr,""),vbLf,"")
Définir Http=Rien
Si NuméroErr.<>0 alors
Err.Effacer
Fin si
Fonction de fin
'================================================== = =
'Nom de la fonction : OctetsVersBstr
'Fonction : Convertir le code source obtenu en chinois
'Paramètre : Corps ------Variable à convertir
'Paramètre : Cset ------type à convertir
'================================================== = =
Fonction BytesToBstr(Corps,Cset)
Dim Objstream
Définir Objstream = Server.CreateObject("ad" & "odb.str" & "eam")
objstream.Type = 1
objstream.Mode =3
objstream.Ouvrir
objstream.Écrire le corps
objstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Fermer
définir objstream = rien
Fonction de fin
'================================================== = =
'Nom de la fonction : PostHttpPage
'Fonction : connexion
'================================================== = =
Fonction PostHttpPage(RefererUrl,PostUrl,PostData)
DimxmlHttp
DimRetStr
Définir xmlHttp = CreateObject("Msx" & "ml2.XM" & "LHT" & "TP")
xmlHttp.Ouvrez "POST", PostUrl, False
XmlHTTP.setRequestHeader "Content-Length",Len(PostData)
xmlHttp.setRequestHeader "Type de contenu", "application/x-www-form-urlencoded"
xmlHttp.setRequestHeader "Référent", RefererUrl
xmlHttp.Envoyer PostData
Si Err.Number <> 0 Alors
Définir xmlHttp=Rien
PostHttpPage = "$Faux$"
Fonction de sortie
Fin si
PostHttpPage=bytesToBSTR(xmlHttp.responseBody,"GB2312")
Définir xmlHttp = rien
Fonction de fin
'================================================== = =
'Nom de la fonction : UrlEncoding
'Fonction : Convertir l'encodage
'================================================== = =
Fonction UrlEncoding(DataStr)
Dim StrReturn, Si, ThisChr, InnerCode, Hight8, Low8
StrRetour = ""
Pour Si = 1 à Len (DataStr)
ThisChr = Mid(DataStr,Si,1)
Si Abs(Asc(ThisChr)) < &HFF Alors
StrReturn = StrReturn & ThisChr
Autre
CodeInner = Asc(ThisChr)
Si InnerCode < 0 Alors
Code Intérieur = Code Intérieur + &H10000
Fin si
Hauteur8 = (InnerCode et &HFF00)/ &HFF
Low8 = InnerCode et &HFF
StrReturn = StrReturn & "%" & Hex (Hight8) & "%" & Hex (Low8)
Fin si
Suivant
UrlEncoding = StrReturn
Fonction de fin
'================================================== = =
'Nom de la fonction : GetBody
'Fonction : chaîne d'interception
'Paramètre : ConStr ------La chaîne à intercepter
'Paramètre : StartStr ------chaîne de démarrage
'Paramètre : OverStr ------Fin de chaîne
'Paramètre : IncluL ------Si StartStr est inclus
'Paramètre : IncluR ------s'il faut inclure OverStr
'================================================== = =
Fonction GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
Si ConStr="$False$" ou ConStr="" ou IsNull(ConStr)=True Ou StartStr="" ou IsNull(StartStr)=True Ou OverStr="" ou IsNull(OverStr)=True Alors
GetBody="$Faux$"
Fonction de sortie
Fin si
DimConStrTemp
Dim Début, Fin
ConStrTemp=Lcase(ConStr)
StartStr=Lcase(StartStr)
SurStr=Lcase(SurStr)
Début = InStrB (1, ConStrTemp, StartStr, vbBinaryCompare)
Si Début <=0 alors
GetBody="$Faux$"
Fonction de sortie
Autre
Si IncluL=False Alors
Début=Début+LenB(StartStr)
Fin si
Fin si
Over=InStrB(Démarrer,ConStrTemp,OverStr,vbBinaryCompare)
Si Over<=0 ou Over<=Start alors
GetBody="$Faux$"
Fonction de sortie
Autre
Si InclR=Vrai Alors
Sur=Sur+LenB(SurStr)
Fin si
Fin si
GetBody = MidB (ConStr, Start, Over-Start)
Fonction de fin
'================================================== = =
'Nom de la fonction : GetArray
'Fonction : Extraire l'adresse du lien, séparée par $Array$
'Paramètre : ConStr ------Extraire les caractères originaux de l'adresse
'Paramètre : StartStr ------chaîne de démarrage
'Paramètre : OverStr ------Fin de chaîne
'Paramètre : IncluL ------Si StartStr est inclus
'Paramètre : IncluR ------s'il faut inclure OverStr
'================================================== = =
Fonction GetArray (Byval ConStr, StartStr, OverStr, IncluL, IncluR)
Si ConStr="$False$" ou ConStr="" Ou IsNull(ConStr)=True ou StartStr="" Ou OverStr="" ou IsNull(StartStr)=True Ou IsNull(OverStr)=True Alors
GetArray="$Faux$"
Fonction de sortie
Fin si
Dim TempStr, TempStr2, objRegExp, Correspondances, Correspondance
TempStr=""
Définir objRegExp = Nouvelle expression rationnelle
objRegExp.IgnoreCase = True
objRegExp.Global = Vrai
objRegExp.Pattern = "("&StartStr&").+?("&OverStr&")"
Définir les correspondances =objRegExp.Execute(ConStr)
Pour chaque match dans les matchs
TempStr=TempStr & "$Array$" & Match.Value
Suivant
Définir les correspondances = rien
Si TempStr="" Alors
GetArray="$Faux$"
Fonction de sortie
Fin si
TempStr=Droite(TempStr,Len(TempStr)-7)
Si IncluL=False alors
objRegExp.Pattern =StartStr
TempStr=objRegExp.Replace(TempStr,"")
Terminer si
Si InclR=Faux alors
objRegExp.Pattern =OverStr
TempStr=objRegExp.Replace(TempStr,"")
Terminer si
Définir objRegExp = rien
Définir les correspondances = rien
TempStr=Remplacer(TempStr,"""","")
TempStr=Remplacer(TempStr,"'","")
TempStr=Remplacer(TempStr," ","")
TempStr=Remplacer(TempStr,"(","")
TempStr=Remplacer(TempStr,")","")
Si TempStr="" alors
GetArray="$Faux$"
Autre
GetArray=TempStr
Terminer si
Fonction de fin
'================================================== = =
'Nom de la fonction : DefiniteUrl
'Fonction : Convertir l'adresse relative en adresse absolue
'Paramètre : PrimitiveUrl ------ adresse relative à convertir
'Paramètre : ConsultUrl ------Adresse actuelle de la page Web
'================================================== = =
Fonction DefiniteUrl (Byval PrimitiveUrl, Byval ConsultUrl)
Dim ConTemp, PriTemp, Pi, Ci, PriArray, ConArray
Si PrimitiveUrl="" ou ConsultUrl="" ou PrimitiveUrl="$False$" ou ConsultUrl="$False$" Alors
DefiniteUrl="$False$"
Fonction de sortie
Fin si
Si Gauche(Lcase(ConsultUrl),7)<>"http://" Alors
ConsultUrl= "http://" & ConsultUrl
Fin si
ConsultUrl=Remplacer(ConsultUrl,"/","/")
ConsultUrl=Remplacer(ConsultUrl,"://","://")
PrimitiveUrl=Remplacer(PrimitiveUrl,"/","/")
Si c'est vrai(ConsultUrl,1)<>"/" Alors
Si Instr(ConsultUrl,"/")>0 Alors
Si Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 alors
Autre
ConsultUrl=ConsultUrl & "/"
Fin si
Autre
ConsultUrl=ConsultUrl & "/"
Fin si
Fin si
ConArray=Split(ConsultUrl,"/")
Si Left(LCase(PrimitiveUrl),7) = "http://" alors
DefiniteUrl=Remplacer(PrimitiveUrl,"://","://")
ElseIf Left(PrimitiveUrl,1) = "/" Alors
DefiniteUrl = ConArray (0) et PrimitiveUrl
ElseIf Left(PrimitiveUrl,2)="./" Then
PrimitiveUrl=Droite(PrimitiveUrl,Len(PrimitiveUrl)-2)
Si c'est vrai(ConsultUrl,1)="/" Alors
DefiniteUrl=ConsultUrl et PrimitiveUrl
Autre
DefiniteUrl = Gauche (ConsultUrl, InstrRev (ConsultUrl, "/")) & PrimitiveUrl
Fin si
ElseIf Left(PrimitiveUrl,3)="../" alors
Faire en restant à gauche(PrimitiveUrl,3)="../"
PrimitiveUrl=Droite(PrimitiveUrl,Len(PrimitiveUrl)-3)
Pi=Pi+1
Boucle
Pour Ci=0 à (Ubound(ConArray)-1-Pi)
Si DefiniteUrl<>"" Alors
DefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)
Autre
DefiniteUrl = ConArray (Ci)
Fin si
Suivant
DefiniteUrl = DefiniteUrl & "/" & PrimitiveUrl
Autre
Si Instr(PrimitiveUrl,"/")>0 Alors
PriArray=Split(PrimitiveUrl,"/")
Si Instr(PriArray(0),".")>0 Alors
Si c'est vrai(PrimitiveUrl,1)="/" Alors
DefiniteUrl="http://" et PrimitiveUrl
Autre
Si Instr(PriArray(Ubound(PriArray)-1),".")>0 Alors
DefiniteUrl="http://" et PrimitiveUrl
Autre
DefiniteUrl="http://" & PrimitiveUrl & "/"
Fin si
Fin si
Autre
Si c'est vrai(ConsultUrl,1)="/" Alors
DefiniteUrl=ConsultUrl et PrimitiveUrl
Autre
DefiniteUrl = Gauche (ConsultUrl, InstrRev (ConsultUrl, "/")) & PrimitiveUrl
Fin si
Fin si
Autre
Si Instr(PrimitiveUrl,".")>0 Alors
Si c'est vrai(ConsultUrl,1)="/" Alors
Si right(LCase(PrimitiveUrl),3)=".cn" ou right(LCase(PrimitiveUrl),3)="com" ou right(LCase(PrimitiveUrl),3)="net" ou right(LCase(PrimitiveUrl) ,3)="org" Alors
DefiniteUrl="http://" & PrimitiveUrl & "/"
Autre
DefiniteUrl=ConsultUrl et PrimitiveUrl
Fin si
Autre
Si right(LCase(PrimitiveUrl),3)=".cn" ou right(LCase(PrimitiveUrl),3)="com" ou right(LCase(PrimitiveUrl),3)="net" ou right(LCase(PrimitiveUrl) ,3)="org" Alors
DefiniteUrl="http://" & PrimitiveUrl & "/"
Autre
DefiniteUrl=Gauche(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl
Fin si
Fin si
Autre
Si c'est vrai(ConsultUrl,1)="/" Alors
DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"
Autre
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"
Fin si
Fin si
Fin si
Fin si
Si Left(DefiniteUrl,1)="/" alors
DefiniteUrl=Droite(DefiniteUrl,Len(DefiniteUrl)-1)
Terminer si
Si DefiniteUrl<>"" Alors
DefiniteUrl=Remplacer(DefiniteUrl,"//","/")
DefiniteUrl=Remplacer(DefiniteUrl,"://","://")
Autre
DefiniteUrl="$False$"
Fin si
Fonction de fin
'================================================== = =
'Nom de la fonction : ReplaceSaveRemoteFile
'Fonction : remplacer et enregistrer des images distantes
'Paramètre : ConStr ------ chaîne à remplacer
'Paramètre : SaveTf ------ S'il faut enregistrer le fichier, False n'enregistre pas, True enregistre
'Paramètre : TistUrl------ adresse de la page Web actuelle
'================================================== = =
Fonction ReplaceSaveRemoteFile (ConStr, InstallPath, strChannelDir, SaveTf, TistUrl)
Si ConStr="$False$" ou ConStr="" ou InstallPath="" ou strChannelDir="" Alors
ReplaceSaveRemoteFile=ConStr
Fonction de sortie
Fin si
Dim TempStr,TempStr2,TempStr3,Re,Correspondances,Match,Tempi,TempArray,TempArray2
Définir Re = Nouvelle expression rationnelle
Re.IgnoreCase = Vrai
Re.Global = Vrai
Re.Pattern ="<img.+?>"
Définir les correspondances =Re.Execute(ConStr)
Pour chaque match dans les matchs
Si TempStr<>"" alors
TempStr=TempStr & "$Array$" & Match.Value
Autre
TempStr=Match.Valeur
Terminer si
Suivant
Si TempStr<>"" Alors
TempArray=Split(TempStr,"$Array$")
TempStr=""
Pour Tempi = 0 à Ubound (TempArray)
Re.Pattern ="src/s*=/s*.+?/.(gifjpgbmpjpegpsdpngsvgdxfwmftiff)"
Définir les correspondances =Re.Execute(TempArray(Tempi))
Pour chaque match dans les matchs
Si TempStr<>"" alors
TempStr=TempStr & "$Array$" & Match.Value
Autre
TempStr=Match.Valeur
Terminer si
Suivant
Suivant
Terminer si
Si TempStr<>"" Alors
Re.Pattern="src/s*=/s*"
TempStr=Re.Replace(TempStr,"")
Fin si
Définir les correspondances = rien
Définir Re = rien
Si TempStr="" ou IsNull(TempStr)=True Alors
ReplaceSaveRemoteFile=ConStr
Fonction de sortie
Terminer si
TempStr=Remplacer(TempStr,"""","")
TempStr=Remplacer(TempStr,"'","")
TempStr=Remplacer(TempStr," ","")
Dim RemoteFileurl, SavePath, PathTemp, DtNow, strFileName, strFileType, ArrSaveFileName, RanNum, Arr_Path
DtMaintenant=Maintenant()
'************************************
Si SaveTf=True alors
SavePath=InstallPath&strChannelDir
Si CheckDir(InstallPath & strChannelDir)=False Alors
Si ce n'est pas le cas, CreateMultiFolder (InstallPath & strChannelDir) alors
réponse.Write InstallPath & strChannelDir&"Échec de la création du répertoire"
SaveTf=Faux
Fin si
Fin si
Fin si
'Commencez par supprimer les images en double
TempArray=Split(TempStr,"$Array$")
TempStr=""
Pour Tempi = 0 à Ubound (TempArray)
Si Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Alors
TempStr=TempStr & "$Array$" & TempArray(Tempi)
Fin si
Suivant
TempStr=Droite(TempStr,Len(TempStr)-7)
TempArray=Split(TempStr,"$Array$")
'Supprimer les images en double et terminer
réponse.Écrivez "<br>Image trouvée :<br>"&Replace(TempStr,"$Array$","<br>")
'Commencer à convertir les adresses d'images relatives
TempStr=""
Pour Tempi = 0 à Ubound (TempArray)
TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
Suivant
TempStr=Droite(TempStr,Len(TempStr)-7)
TempStr=Remplacer(TempStr,Chr(0),"")
TempArray2=Split(TempStr,"$Array$")
TempStr=""
'Fin de la conversion de l'adresse relative de l'image
'Remplacement/enregistrement d'image
Définir Re = Nouvelle expression rationnelle
Re.IgnoreCase = Vrai
Re.Global = Vrai
Pour Tempi = 0 à Ubound (TempArray2)
'************************************
RemoteFileUrl = TempArray2 (Tempi)
Si RemoteFileUrl<>"$False$" et SaveTf=True alors enregistrez l'image
ArrSaveFileName = Split(RemoteFileurl,".")
strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'Type de fichier
Si strFileType="asp" ou strFileType="asa" ou strFileType="aspx" ou strFileType="cer" ou strFileType="cdx" ou strFileType="exe" ou strFileType="rar" ou strFileType="zip" alors
Télécharger des fichiers=""
ReplaceSaveRemoteFile=ConStr
Fonction de sortie
Fin si
Randomiser
RanNum=Int(900*Rnd)+100
strFileName = année(DtNow) & right("0" & mois(DtNow),2) & right("0" & jour(DtNow),2) & right("0" & heure(DtNow) ),2) & right ("0" & minute(DtNow),2) & right("0" & second(DtNow),2) & ranNum & "& strFileType
Re.Pattern =TempArray(Tempi)
réponse.Écrivez "<br>Enregistrer à l'adresse locale :"&InstallPath & strChannelDir & strFileName
Si SaveRemoteFile(InstallPath & strChannelDir & strFileName,RemoteFileUrl,RemoteFileUrl)=True Alors
réponse.Écrivez "<font color=blue>Succès</font><br>"
PathTemp=InstallPath & strChannelDir & strFileName
ConStr=Re.Replace(ConStr,PathTemp)
Re.Pattern=InstallPath&strChannelDir
UploadFiles=UploadFiles & "" & InstallPath & strChannelDir & strFileName
Autre
PathTemp=RemoteFileUrl
ConStr=Re.Replace(ConStr,PathTemp)
Fin si
ElseIf RemoteFileurl<>"$False$" et SaveTf=False Then'Ne pas enregistrer l'image
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
Fin si
'************************************
Suivant
Définir Re = rien
ReplaceSaveRemoteFile=ConStr
Fin de fonction
'================================================== = =
'Nom de la fonction : RemplacerSwfFile
'Fonction : analyser le chemin de l'animation
'Paramètre : ConStr ------ chaîne à remplacer
'Paramètre : TistUrl------ adresse de la page Web actuelle
'================================================== = =
Fonction RemplacerSwfFile(ConStr,TistUrl)
Si ConStr="$False$" ou ConStr="" ou TistUrl="" ou TistUrl="$False$" Alors
RemplacerSwfFile=ConStr
Fonction de sortie
Fin si
Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
Définir Re = Nouvelle expression rationnelle
Re.IgnoreCase = Vrai
Re.Global = Vrai
Re.Pattern ="<objet.+?[^/>]>"
Définir les correspondances =Re.Execute(ConStr)
Pour chaque match dans les matchs
Si TempStr<>"" alors
TempStr=TempStr & "$Array$" & Match.Value
Autre
TempStr=Match.Valeur
Terminer si
Suivant
Si TempStr<>"" Alors
TempArray=Split(TempStr,"$Array$")
TempStr=""
Pour Tempi = 0 à Ubound (TempArray)
Re.Pattern ="valeur/s*=/s*.+?/.swf"
Définir les correspondances =Re.Execute(TempArray(Tempi))
Pour chaque match dans les matchs
Si TempStr<>"" alors
TempStr=TempStr & "$Array$" & Match.Value
Autre
TempStr=Match.Valeur
Terminer si
Suivant
Suivant
Terminer si
Si TempStr<>"" Alors
Re.Pattern ="valeur/s*=/s*"
TempStr=Re.Replace(TempStr,"")
Fin si
Si TempStr="" ou IsNull(TempStr)=True Alors
RemplacerSwfFile=ConStr
Fonction de sortie
Terminer si
TempStr=Remplacer(TempStr,"""","")
TempStr=Remplacer(TempStr,"'","")
TempStr=Remplacer(TempStr," ","")
Définir les correspondances = rien
Définir Re = rien
'Commencez par supprimer les fichiers en double
TempArray=Split(TempStr,"$Array$")
TempStr=""
Pour Tempi = 0 à Ubound (TempArray)
Si Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Alors
TempStr=TempStr & "$Array$" & TempArray(Tempi)
Fin si
Suivant
TempStr=Droite(TempStr,Len(TempStr)-7)
TempArray=Split(TempStr,"$Array$")
'Supprimer les fichiers en double et terminer
'Commencer à convertir les adresses relatives
TempStr=""
Pour Tempi = 0 à Ubound (TempArray)
TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
Suivant
TempStr=Droite(TempStr,Len(TempStr)-7)
TempStr=Remplacer(TempStr,Chr(0),"")
TempArray2=Split(TempStr,"$Array$")
TempStr=""
'Fin de la conversion de l'adresse relative
'remplacer
Définir Re = Nouvelle expression rationnelle
Re.IgnoreCase = Vrai
Re.Global = Vrai
Pour Tempi = 0 à Ubound (TempArray2)
RemoteFileUrl = TempArray2 (Tempi)
Re.Pattern =TempArray(Tempi)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
Suivant
Définir Re = rien
RemplacerSwfFile=ConStr
Fin de fonction
'================================================== = =
'Nom du processus : SaveRemoteFile
'Fonction : enregistrer les fichiers distants en local
'Paramètre : LocalFileName ------ nom du fichier local
'Paramètre : RemoteFileUrl ------ URL du fichier distant
'Paramètre : Référent ------ Fichier d'appel à distance (pour l'anti-collecte, utiliser l'adresse de la page de contenu, laisser vide s'il n'y a pas d'anti-collecte)
'================================================== = =
Fonction SaveRemoteFile (LocalFileName, RemoteFileUrl, Referer)
SaveRemoteFile=Vrai
dim Annonces, Récupération, GetRemoteData
Définir la récupération = Server.CreateObject("Microsoft.XMLHTTP")
Avec récupération
.Ouvrez "Obtenir", RemoteFileUrl, False, "", ""
si Référent<>"" alors .setRequestHeader "Référent",Référent
.Envoyer
Si .Readystate<>4 alors
SaveRemoteFile=Faux
Fonction de sortie
Fin si
GetRemoteData = .ResponseBody
Terminer par
Définir la récupération = Rien
Définir les annonces = Server.CreateObject("Adodb.Stream")
Avec des publicités
.Type = 1
.Ouvrir
.Écrire GetRemoteData
.SaveToFile serveur.MapPath(LocalFileName),2
.Annuler()
.Fermer()
Terminer par
Définir les annonces = rien
fonction de fin
'================================================== = =
'Nom de la fonction : GetPaing
'Fonction : Obtenir la pagination
'================================================== = =
Fonction GetPaing(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
Si ConStr="$False$" ou ConStr="" Ou StartStr="" Ou OverStr="" ou IsNull(ConStr)=True ou IsNull(StartStr)=True Ou IsNull(OverStr)=True Alors
GetPaing="$Faux$"
Fonction de sortie
Fin si
Dim Début, Fin, ConTemp, TempStr
TempStr=LCase(ConStr)
StartStr=LCase(StartStr)
SurStr=LCase(SurStr)
Sur=Instr(1,TempStr,OverStr)
Si supérieur <=0 alors
GetPaing="$Faux$"
Fonction de sortie
Autre
Si InclR=Vrai Alors
Sur=Sur+Len(SurStr)
Fin si
Fin si
TempStr=Milieu(TempStr,1,Plus)
Début=InstrRev(TempStr,StartStr)
Si IncluL=False Alors
Début=Début+Len(StartStr)
Fin si
Si Début <= 0 Ou Début> = Fin Alors
GetPaing="$Faux$"
Fonction de sortie
Fin si
ConTemp = Milieu (ConStr, Start, Over-Start)
ConTemp=Trim(ConTemp)
'ConTemp=Remplacer(ConTemp," ","")
ConTemp=Remplacer(ConTemp,","","")
ConTemp=Remplacer(ConTemp,"'","")
ConTemp=Remplacer(ConTemp,"""","")
ConTemp=Remplacer(ConTemp,">","")
ConTemp=Remplacer(ConTemp,"<","")
ConTemp=Remplacer(ConTemp," ;","")
GetPaing=ConTemp
Fonction de fin
'************************************************
'Nom de la fonction : gotTopic
'Fonction : tronque la chaîne, chaque caractère chinois compte pour deux caractères et le caractère anglais compte pour un caractère.
'Paramètre : str ---- chaîne d'origine
' strlen ---- longueur d'interception
'Valeur de retour : chaîne interceptée
'************************************************
fonction gotTopic(str,strlen)
si str="" alors
gotTopic=""
fonction de sortie
finir si
faible l, t, c, je
str=replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<")
l=len(chaîne)
t=0
pour i=1 à l
c=Abs(Asc(Mid(str,i,1)))
si c>255 alors
t=t+2
autre
t=t+1
finir si
si t>=strlen alors
gotTopic=gauche(str,i) & "…"
sortie pour
autre
gotTopic=str
finir si
suivant
gotTopic=replace(replace(replace(replace(gotTopic," "," "),chr(34),"""),">",">"),"<","<;")
fonction de fin
'*********************************************
'Nom de la fonction : JoinChar
'Fonction : Ajouter ? ou & à l'adresse
'Paramètre : strUrl ---- URL
'Valeur de retour : URL avec ? ou & ajouté
'*********************************************
fonction JoinChar(strUrl)
si strUrl="" alors
JoinChar=""
fonction de sortie
finir si
si InStr(strUrl,"?")<len(strUrl) alors
si InStr(strUrl,"?")>1 alors
si InStr(strUrl,"&")<len(strUrl) alors
JoinChar=strUrl & "&"
autre
JoinChar=strUrl
finir si
autre
JoinChar=strUrl & "?"
finir si
autre
JoinChar=strUrl
finir si
fonction de fin
'************************************************ *
'Nom de la fonction : CreateKeyWord
'Fonction : Générer des mots-clés à partir de la chaîne donnée
'Paramètre : Constr --- la chaîne d'origine pour générer le mot-clé
'Valeur de retour : mot-clé généré
'************************************************ *
Fonction CreateKeyWord(byval Constr,Num)
Si Constr="" ou IsNull(Constr)=True ou Constr="$False$" Alors
CreateKeyWord="$False$"
Fonction de sortie
Fin si
Si Num="" ou IsNumeric(Num)=False Alors
Nombre=2
Fin si
Constr=Remplacer(Constr,CHR(32),"")
Constr=Remplacer(Constr,CHR(9),"")
Constr=Remplacer(Constr," ","")
Constr=Remplacer(Constr," ","")
Constr=Remplacer(Constr,"(","")
Constr=Remplacer(Constr,")","")
Constr=Remplacer(Constr,"<","")
Constr=Remplacer(Constr,">","")
Constr=Remplacer(Constr,"""","")
Constr=Remplacer(Constr,"?","")
Constr=Remplacer(Constr,"*","")
Constr=Remplacer(Constr,"","")
Constr=Remplacer(Constr,","","")
Constr=Remplacer(Constr,".","")
Constr=Remplacer(Constr,"/","")
Constr=Remplacer(Constr,"/","")
Constr=Remplacer(Constr,"-","")
Constr=Remplacer(Constr,"@","")
Constr=Remplacer(Constr,"#","")
Constr=Remplacer(Constr,"$","")
Constr=Remplacer(Constr,"%","")
Constr=Remplacer(Constr,"&","")
Constr=Remplacer(Constr,"+","")
Constr=Remplacer(Constr,":","")
Constr=Remplacer(Constr,"：","")
Constr=Remplacer(Constr,"'","")
Constr=Remplacer(Constr,""","")
Constr=Remplacer(Constr,""","")
Dim i,ConstrTemp
Pour i=1 À Len(Constr)
ConstrTemp=ConstrTemp & "" & Mid(Constr,i,Num)
Suivant
Si Len(ConstrTemp)<254 Alors
ConstrTemp=ConstrTemp & ""
Autre
ConstrTemp=Gauche(ConstrTemp,254) & ""
Fin si
CreateKeyWord=ConstrTemp
Fonction de fin
'================================================== = =
'Nom de la fonction : CheckUrl
'Fonction : Vérifier l'URL
'Paramètre : strUrl ------ Pour vérifier l'URL
'================================================== = =
Fonction CheckUrl(strUrl)
Dim Ré
Définir Re=new RegExp
Re.IgnoreCase=true
Re.Global=Vrai
Re.Pattern="http://([/w-]+/.)+[/w-]+(/[/w-./?%&=]*) ?"
Si Re.test(strUrl)=True Alors
CheckUrl=strUrl
Autre
CheckUrl="$Faux$"
Fin si
Définir Rs = Rien
Fonction de fin
'================================================== = =
'Nom de la fonction : ScriptHtml
'Fonction : filtrer les balises html
'Paramètre : ConStr ------ La chaîne à filtrer
'================================================== = =
Fonction ScriptHtml(Byval ConStr,TagName,FType)
Dim Ré
Définir Re=new RegExp
Re.IgnoreCase=true
Re.Global=Vrai
Sélectionnez le type F du cas
Cas 1
Re.Pattern="<" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Cas 2
Re.Pattern="<" & TagName & "([^>])*>.*?</" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Cas 3
Re.Pattern="<" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Re.Pattern="</" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Fin de la sélection
ScriptHtml=ConStr
Définir Re=Rien
Fonction de fin
'================================================== = =
'Nom de la fonction : RemoveHTML
'Fonction : Supprimer complètement les balises html
'Paramètre : strHTML ------ La chaîne à filtrer
'================================================== = =
Fonction SupprimerHTML(strHTML)
Dim objRegExp, Correspondance, Correspondances
Définir objRegExp = Nouvelle expression rationnelle
objRegExp.IgnoreCase = True
objRegExp.Global = Vrai
'Obtenez le <> fermé
objRegExp.Pattern = "<.+?>"
'Correspondre
Définir les correspondances = objRegExp.Execute(strHTML)
'Parcourir l'ensemble correspondant et remplacer les éléments correspondants
Pour chaque match dans les matchs
strHtml=Remplacer(strHTML,Match.Value,"")
Suivant
SupprimerHTML=strHTML
Définir objRegExp = Rien
Fonction de fin
'================================================== = =
'Nom de la fonction : CheckDir
'Fonction : Vérifier si le dossier existe
'Paramètre : FolderPath ------ chemin du dossier
'================================================== = =
Fonction CheckDir (byval FolderPath)
faible fso
Définir fso = Server.CreateObject("Scripting.FileSystemObject")
Si fso.FolderExists(Server.MapPath(folderpath)) alors
'exister
CheckDir = Vrai
Autre
'n'existe pas
CheckDir = Faux
Terminer si
Définir fso = rien
Fonction de fin
'================================================== = =
'Nom de la fonction : MakeNewsDir
'Fonction : Créer un dossier
'Paramètre : nom du dossier ------ nom du dossier
'================================================== = =
Fonction MakeNewsDir (nom du dossier byval)
faible fso
Définir fso = Server.CreateObject("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
fso.CreateFolder(Server.MapPath(nom du dossier))
Si fso.FolderExists(Server.MapPath(foldername)) Alors
MakeNewsDir = Vrai
Autre
MakeNewsDir = Faux
Fin si
Définir fso = rien
Fonction de fin
'================================================== = =
'Nom de la fonction : DelDir
'Fonction : Créer un dossier
'Paramètre : nom du dossier ------ nom du dossier
'================================================== = =
Fonction DelDir (nom du dossier byval)
faible fso
Définir fso = Server.CreateObject("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
Si fso.FolderExists(Server.MapPath(foldername)) Then 'Déterminer si le dossier existe
fso.DeleteFolder (Server.MapPath(foldername)) 'Supprimer le dossier
Fin si
Définir fso = rien
Fonction de fin
'************************************************ *
'Nom de la fonction : IsObjInstalled
'Fonction : Vérifier si le composant a été installé
'Paramètre : strClassString ---- nom du composant
'Valeur de retour : True ---- Déjà installé
'Faux ---- non installé
'************************************************ *
Fonction IsObjInstalled(strClassString)
IsObjInstalled = Faux
Erreur = 0
DimxTestObj
Définir xTestObj = Server.CreateObject(strClassString)
Si 0 = Err Alors IsObjInstalled = True
Définir xTestObj = Rien
Erreur = 0
Fonction de fin
'************************************************ *
'Nom de la fonction : strLongueur
'Fonction : Trouver la longueur de la chaîne. Les caractères chinois comptent pour deux caractères et les caractères anglais comptent pour un caractère.
'Paramètre : str ----Chaîne avec la longueur requise
'Valeur de retour : longueur de la chaîne
'************************************************ *
fonction strLongueur(str)
EN ERREUR REPRISER SUIVANT
faible WINNT_CHINESE
WINNT_CHINESE = (len("Chine")=2)
si WINNT_CHINESE alors
faible l, t, c
je suis faible
l=len(chaîne)
t = l
pour i=1 à l
c=asc(milieu(str,i,1))
si c<0 alors c=c+65536
si c>255 alors
t=t+1
finir si
suivant
strLongueur=t
autre
strLongueur=len(str)
finir si
si err.number<>0 alors err.clear
fonction de fin
'************************************************ * **
'Nom de la fonction : CreateMultiFolder
'Fonction : Créez des répertoires à plusieurs niveaux, vous pouvez créer des répertoires racine inexistants
'Paramètre : le nom du répertoire à créer, qui peut être multi-niveau
'Valeur logique renvoyée : Vrai en cas de succès, Faux en cas d'échec
'Créer le répertoire racine du répertoire à partir du répertoire courant
'************************************************ * **
Fonction CreateMultiFolder (ByVal CFolder)
Dim objFSO, PhCreateFolder, CreateFolderArray, CreateFolder
Dim i, ii, CreateFolderSub, PhCreateFolderSub, BlInfo
BlInfo=Faux
CréerDossier = CFolder
En cas d'erreur, reprendre ensuite
Définir objFSO = Server.CreateObject("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
Si erreur alors
Err.Effacer()
Fonction de sortie
Fin si
CreateFolder = Remplacer(CreateFolder,"/","/")
Si Left(CreateFolder,1)="/" Alors
'CreateFolder = Droite(CreateFolder,Len(CreateFolder)-1)
Fin si
Si c'est vrai(CreateFolder,1)="/" Alors
CreateFolder = Gauche (CreateFolder, Len (CreateFolder) -1)
Fin si
CreateFolderArray = Split(CreateFolder,"/")
Pour i = 0 à UBound (CreateFolderArray)
CreateFolderSub = ""
Pour ii = 0 à i
CreateFolderSub = CreateFolderSub & CreateFolderArray(ii) & "/"
Suivant
PhCreateFolderSub = Server.MapPath (CreateFolderSub)
'response.Write PhCreateFolderSub&"<br>"
Si ce n'est pas le cas, objFSO.FolderExists(PhCreateFolderSub) Alors
objFSO.CreateFolder(PhCreateFolderSub)
Fin si
Suivant
Si erreur alors
Err.Effacer()
Autre
BlInfo=Vrai
Fin si
Définir objFSO = rien
CreateMultiFolder = BlInfo
Fonction de fin
'************************************************ *
'Nom de la fonction : FSOFileRead
'Fonction : Utilisez FSO pour lire la fonction de contenu du fichier
'Paramètre : nom de fichier ---- nom de fichier
'Valeur de retour : contenu du fichier
'************************************************ *
fonction FSOFileRead (nom de fichier)
Dim objFSO, objCountFile, FiletempData
Définir objFSO = Server.CreateObject("Scripting.FileSystemObject")
Définir objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FSOFileRead = objCountFile.ReadAll
objCountFile.Fermer
Définir objCountFile=Rien
Définir objFSO = Rien
Fonction de fin
'************************************************ *
'Nom de la fonction : FSOlinedit
'Fonction : utilisez FSO pour lire une certaine ligne de la fonction de fichier
'Paramètre : nom de fichier ---- nom de fichier
' lineNum ---- numéro de ligne
'Valeur de retour : le contenu de la ligne dans le fichier
'************************************************ *
fonction FSOlinedit (nom de fichier, numéro de ligne)
si linge < 1 alors quittez la fonction
dim fso, f, temparray, tempcnt
set fso = serveur.CreateObject("scripting.filesystemobject")
sinon fso.fileExists(server.mappath(filename)) alors quittez la fonction
set f = fso.opentextfile(server.mappath(filename),1)
sinon f.AtEndofStream alors
tempcnt = f.readall
f.fermer
définir f = rien
temparray = split(tempcnt,chr(13)&chr(10))
si lineNum>ubound(temparray)+1 alors
fonction de sortie
autre
FSOlinedit = temparray(lineNum-1)
finir si
finir si
fonction de fin
'************************************************ *
'Nom de la fonction : FSOlinewrite
'Fonction : utilisez FSO pour écrire une certaine ligne de la fonction de fichier
'Paramètre : nom de fichier ---- nom de fichier
' lineNum ---- numéro de ligne
' Contenu de la ligne ---- contenu
'Valeur de retour : Aucune
'************************************************ *
fonction FSOlinewrite (nom de fichier, numéro de ligne, contenu de ligne)
si linge < 1 alors quittez la fonction
dim fso, f, temparray, tempCnt
set fso = serveur.CreateObject("scripting.filesystemobject")
sinon fso.fileExists(server.mappath(filename)) alors quittez la fonction
set f = fso.opentextfile(server.mappath(filename),1)
sinon f.AtEndofStream alors
tempcnt = f.readall
f.fermer
temparray = split(tempcnt,chr(13)&chr(10))
si lineNum>ubound(temparray)+1 alors
fonction de sortie
autre
temparray(lineNum-1) = lineContent
finir si
tempcnt = rejoindre (temparray, chr (13) & chr (10))
set f = fso.createtextfile(server.mappath(filename),true)
f.writetempcnt
finir si
f.fermer
définir f = rien
fonction de fin
'************************************************ *
'Nom de la fonction : Htmlmake
'Fonction : Utiliser FSO pour créer des fichiers
'Paramètre : HtmlFolder ---- chemin
' HtmlFilename ---- nom du fichier
'Contenu HTML ----Contenu
'************************************************ *
fonction Htmlmake (HtmlFolder, HtmlFilename, HtmlContent)
En cas d'erreur, reprendre ensuite
chemin de fichier faible, fso, fout
chemin de fichier = Dossier HTML&"/"&Nom de fichier HTML
Définir fso = Server.CreateObject("Scripting.FileSystemObject")
Si fso.FolderExists(HtmlFolder) Alors
Autre
CréerMultiFolder (HtmlFolder)
&, ;nbs, p; Fin si
Définir fout = fso.Createtextfile(server.mappath(filepath),true)
fout.writeline HtmlContent
fout.close
définir fso = rien
Définir fso = Server.CreateObject("Scripting.FileSystemObject")
Si fso.fileexists(Server.MapPath(filepath)) Alors
Response.Write "Le fichier<font color=red>"&HtmlFilename&"</font> a été généré !<br>"
Autre
'Response.Write Server.MapPath (chemin du fichier)
Response.Write "Le fichier<font color=red>"&HtmlFilename&"</font> n'a pas été généré !<br>"
Fin si
Définir fso = rien
Fin de fonction
'************************************************ *
'Nom de la fonction : Htmldel
'Fonction : Utiliser FSO pour supprimer des fichiers
'Paramètre : HtmlFolder ---- chemin
' HtmlFilename ---- nom du fichier
'************************************************ *
Sous Htmldel (Dossier HTML, Nom de fichier HTML)
chemin de fichier faible, fso
chemin de fichier = Dossier HTML&"/"&Nom de fichier HTML
Définir fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFile(Server.mappath(chemin du fichier))
Définir fso = rien
Définir fso = Server.CreateObject("Scripting.FileSystemObject")
Si fso.fileexists(Server.MapPath(filepath)) Alors
Response.Write "Le fichier<font color=red>"&HtmlFilename&"</font> n'est pas supprimé !<br>"
Autre
'Response.Write Server.MapPath (chemin du fichier)
Response.Write "Le fichier<font color=red>"&HtmlFilename&"</font> a été supprimé !<br>"
Fin si
Définir fso = rien
Fin du sous-marin
'================================================== =
'Nom du processus : HTMLEncode
'Fonction : filtrer le format HTML
'Paramètre : fString ----Contenu de la conversion
'================================================== =
fonction HTMLEncode (ByVal fString)
Si IsNull(fString)=False ou fString<>"" ou fString<>"$False$" Alors
fString = Remplacer(fString, ">", ">")
fString = Remplacer(fString, "<", "<")
fString = Remplacer(fString, Chr(32), " ")
fString = Remplacer(fString, Chr(9), " ")
fString = Remplacer(fString, Chr(34), """)
fString = Remplacer(fString, Chr(39), "'")
fString = Remplacer(fString, Chr(13), "")
fString = Remplacer(fString, " ", " ")
fString = Remplacer(fString, CHR(10) & CHR(10), "</P><P>")
fString = Remplacer(fString, Chr(10), "<br /> ")
HTMLEncode = fChaîne
autre
HTMLEncode = "$Faux$"
finir si
fonction de fin
'================================================== =
'Nom du processus : unHTMLEncode
'Fonction : restaurer le format HTML
'Paramètre : fString ----Contenu de la conversion
'================================================== =
fonction unHTMLEncode(ByVal fString)
Si IsNull(fString)=False ou fString<>"" ou fString<>"$False$" Alors
fString = Remplacer(fString, ">", ">")
fString = Remplacer(fString, "<", "<")
fString = Remplacer(fString, " ", Chr(32))
fString = Remplacer(fString, """, Chr(34))
fString = Remplacer(fString, "'", Chr(39))
fString = Remplacer(fString, "", Chr(13))
fString = Remplacer(fString, " ", " ")
fString = Remplacer(fString, "</P><P>" , CHR(10) & CHR(10))
fString = Remplacer(fString, "<br> ", Chr(10))
unHTMLEncode = fString
autre
unHTMLEncode = "$False$"
finir si
fonction de fin
fonction unhtmllist (contenu)
unhtmllist=contenu
si contenu <> "" alors
unhtmllist=replace(unhtmllist,"'","";")
unhtmllist=replace(unhtmllist,chr(10),"")
unHtmllist=replace(unHtmllist,chr(13),"<br>")
finir si
fonction de fin
fonction unhtmllists (contenu)
unhtmllists=contenu
si contenu <> "" alors
unhtmllists=replace(unhtmllists,"""","")
unhtmllists=replace(unhtmllists,"'","")
unhtmllists=replace(unhtmllists,chr(10),"")
unHtmllists=replace(unHtmllists,chr(13),"<br>")
finir si
fonction de fin
fonction listes html (contenu)
listes html=contenu
si contenu <> "" alors
htmllists=replace(htmllists,"''","""")
htmllists=replace(htmllists,"","'")
htmllists=replace(htmllists,"<br>",chr(13)&chr(10))
finir si
fonction de fin
fonction uhtmllists (contenu)
uhtmllists=contenu
si contenu <> "" alors
uhtlists=remplacer(uhtlists,"""","''")
uhtlists=replace(uhtlists,"'","";")
uhtlists=replace(uhtlists,chr(10),"")
uHtmllists=replace(uHtmllists,chr(13),"<br>")
finir si
fonction de fin
'================================================== =
'Processus : Dormir
'Fonction : Le programme s'arrête ici pendant quelques secondes
'Paramètres : iSeconds Nombre de secondes de pause
'================================================== =
Sous-sommeil (isecondes)
réponse.Écrivez "<font color=blue>Commencez la pause pendant "&iSeconds&" secondes</font><br>"
Dim t:t=Minuterie()
Tandis que(Timer()<t+iSeconds)
'Ne rien faire
Wende
réponse.Écrivez "<font color=blue>Pause"&iSeconds&" fin des secondes</font><br>"
Fin du sous-marin
'================================================== = =
'Nom de la fonction : MonArray
'Fonction : extraire les balises pour séparer
'Paramètre : ConStr ------Extraire les caractères originaux de l'adresse
'================================================== = =
Fonction MonArray(ByvalConStr)
Définir objRegExp = Nouvelle expression rationnelle
objRegExp.IgnoreCase = True
objRegExp.Global = Vrai
objRegExp.Pattern = "({).+?(})"
Définir les correspondances =objRegExp.Execute(ConStr)
Pour chaque match dans les matchs
TempStr=TempStr & "" & Match.Value
Suivant
Définir les correspondances = rien
TempStr=Droite(TempStr,Len(TempStr)-1)
objRegExp.Pattern="{"
TempStr=objRegExp.Replace(TempStr,"")
objRegExp.Pattern="}"
TempStr=objRegExp.Replace(TempStr,"")
Définir objRegExp = rien
Définir les correspondances = rien
TempStr=Remplacer(TempStr,"$","")
Si TempStr="" alors
MyArray="Rien à extraire dans le code"
Autre
MonTableau=TempStr
Terminer si
Fonction de fin
'================================================== = =
'Nom de la fonction : randm
'Fonction : générer un nombre aléatoire à 6 chiffres
'================================================== = =
Fonction aléatoire
randomiser
randm=Int((900000*rnd)+100000)
Fonction de fin
%>