code de programme
<%
'******************************
'Nom de la classe :
'Nom : bibliothèque générale
'Date : 2008/10/28
'Auteur : par Xilou
"Site Web : http://www.chinacms.org
'Description : Bibliothèque générale
'Copyright : Veuillez indiquer la source et l'auteur lors de la réimpression
'******************************
'Dernière modification : 20090108
'Nombre de modifications : 2
'Description des modifications :
'20090108 Ajoutez les fonctions suivantes :
' A2U(),U2A(),UrlEncode(),UrlDecode(),GBToUTF8(),Bytes2Str(),Str2Bytes()
'20090108 Ajoutez les fonctions suivantes :
'AryToVbsString(arr)
'Version actuelle :
'******************************/
'Sortir
Sous-écho (str)
Response.Write str
Fin du sous
-point d'arrêt
Sous-arrêt()
Réponse.Fin()
End Sub
'Sortie et bouclage
SousBr(str)
Echo str & "<br />" & vbcrlf
End Sub
'Simplifier Request.Form()
'f : nom du formulaire
Fonction P(f)
P = Remplacer (Request.Form (f), Chr (0), "")
End Function
'Recevez le formulaire et remplacez les guillemets simples
Fonction Pr(f)
Pr = Remplacer(Request.Form(f), Chr(0), "")
Pr = Remplacer(Pr, "'", "''")
Fin de la fonction
'Simplifier Request.Querystring()
'f : nom du formulaire
FonctionG(f)
G = Remplacer(Request.QueryString(f), Chr(0), "")
End Function
'Recevoir les paramètres d'URL et remplacer les guillemets simples
FonctionGr(f)
Gr = Remplacer(Request.QueryString(f), Chr(0), "")
Gr = Remplacer(Gr, "'", "''")
End Function
'//Construction()?:Opération ternaire par Xilou www.chinacms.org
'ifThen renvoie s1 pour vrai et s2 pour faux
Fonction IfThen(ifTrue, s1, s2)
Dim t
Si siVrai Alors
t = s1
Autre
t = s2
Fin si
SiAlors = t
Fin de fonction
'Afficher oui et non en différentes couleurs
Fonction IfThenFont(ifTrue, s1, s2)
Dimstr
Si siVrai Alors
str = "<font color=""#006600"">" & s1 & "</font>"
Autre
str = "<font color=""#FF0000"">" & s2 & "</font>"
Fin si
IfThenFont = chaîne
End Function
'Créer un objet Dictionnaire
Fonction NewHashTable()
Définir NewHashTable = Server.CreateObj("Scripting.Dictionary")
NewHashTable.CompareMode = 1 'Les valeurs clés ne sont pas sensibles à la casse
Fin de la fonction
'Créer XmlHttp
Fonction NewXmlHttp()
Définir NewXmlHttp = Server.createobject("MSXML2.XMLHTTP")
Fonction de fin
'Créer XmlDom
Fonction NewXmlDom()
Fin de la fonction
'Créer AdoStream
Fonction NewAdoStream()
Définir NewAdoStream = Server.CreateObject("Adodb.Stream")
End Function
'Créer un tableau à 1 dimension
'Renvoie un tableau vide de n éléments
'n : nombre d'éléments
FonctionNouveauArray(n)
Dim aire : ary = array()
ReDimaire (n-1)
NouveauArray = ary
Fin de la fonction
'Construct Try..Catch
Sous-Essayer()
En cas d'erreur, reprendre ensuite
End Sub
'Construct Try..Catch
'msg : Le message d'erreur renvoyé, s'il est vide, Err.Description est renvoyé
Sous-prise (msg)
Faible HTML
html = "<ul><li>$1</li></ul>"
Si erreur alors
Si msg <> "" Alors
echo Remplacer(html, "$1", msg)
Arrêt
Autre
echo Remplacer(html, "$1", Err.Description)
Arrêt
Fin si
Err.Effacer
Réponse.Fin()
Fin si
End Sub
'--------------------------------l'opération du tableau commence
'Déterminer si une certaine valeur existe dans le tableau
Fonction InArray(arr, s)
If Not IsArray(arr) Then InArray = False : Quitter la fonction
Faible je
Pour i = LBound(arr) À UBound(arr)
Si s = arr(i) Alors InArray = True : Quitter la fonction
Suivant
DansArray = Faux
End Function
'Remplacez les espaces réservés dans str par les valeurs du tableau ary.
'Renvoie la chaîne remplacée
'str : La chaîne à remplacer, les espaces réservés sont $0, $1, $2...
'ary : Tableau utilisé pour le remplacement, chaque valeur correspond à 0 $, 1 $, 2 $... dans l'espace réservé.
'Par exemple : ReplaceByAry("$0-$1-$2 $3:$4:$5",Array(y,m,d,h,i,s))
Fonction ReplaceByAry(str,ary)
Dim je, j, L1, L2 : j = 0
Si IsArray(ary) Alors
L1 = LBound(ary) : L2 = UBound(ary)
Pour i = L1 à L2
str = Remplacer(str, "$"&j, ary(i))
j = j+1
Suivant
Fin si
RemplacerByAry = str
Fonction de fin
'----------------------------------l'opération du tableau se termine
'------------- --- ---------------L'opération de nombre aléatoire commence
'Obtenir des nombres aléatoires
c'est un nombre aléatoire
Fonction RndNumber(m,n)
Randomiser
RndNumber = Int((n - m + 1) * Rnd + m)
End Function
'Obtenir une chaîne aléatoire
'n : longueur générée
Fonction RndText(n)
Dim str1, str2, i, x, L
str1 = "NOPQRSTUVWXYZ012ABCDEFGHIJKLM3456abcdefghijklm789nopqrstuvwxyz"
L = Len(str1)
Randomiser
Pour i = 1 À n
x = Int((L - 1 + 1) * Rnd + 1)
str2 = str2 & Milieu (str1,x,1)
Suivant
RndTexte = str2
End Function
'Générer m à n chaînes aléatoires à partir de la chaîne str
'Si str est vide, une chaîne aléatoire sera générée par défaut à partir de chiffres et de lettres
'str : Pour générer une chaîne aléatoire à partir de cette chaîne
'm,n : génère n à m bits
Fonction RndByText(str, m, n)
Dim je, k, str2, L, x
Si str = "" Alors str = "NOPQRSTUVWXYZ012ABCDEFGHIJKLM3456abcdefghijklm789nopqrstuvwxyz"
L = Len(force)
Si n = m Alors
k = n
Autre
Randomiser
k = Int((n - m + 1) * Rnd + m)
Fin si
Randomiser
Pour i = 1 À k
x = Int((L - 1 + 1) * Rnd + 1)
str2 = str2 & Milieu (str, x, 1)
Suivant
RndByText = str2
End Function
'La date et l'heure forment des nombres aléatoires
'Renvoie la combinaison de chiffres de l'heure actuelle
Fonction RndByDateTime()
Dim dt : dt = Maintenant()
RndByDateTime = Année (dt) & Mois (dt) & Jour (dt) & Heure (dt) & Minute (dt) & Seconde (dt)
Fonction de fin
'----------------------------------L'opération de nombre aléatoire se termine
'------------------- -------------------------L'opération de chaîne commence
'Détermine le nombre de fois qu'une chaîne str2 apparaît dans une autre chaîne str1
'Renvoie le nombre de fois, sinon, renvoie 0
'str1 : expression de chaîne qui accepte la recherche
'str2 : expression de chaîne à rechercher
'start : La position de départ à rechercher. Si vide, cela signifie commencer à 1 par défaut.
Fonction InStrTimes(str1, str2, start)
Dim a,c
Si start = "" Alors start = 1
c = 0
a = InStr(début, str1, str2)
Faire pendant qu'un > 0
c = c + 1
une = InStr(a+1, str1, str2)
Boucle
InStrTimes = c
End Function
'Concaténation de chaînes
'Pas de retour
'strResult : Caractères enregistrés après connexion
'str : caractère à concaténer
'partition : symbole de séparation entre les caractères de connexion
Sub JoinStr (par référence strResult, str, partition)
Si strResult <> "" Alors
strResult = strResult & partition & str
Autre
strRésultat = str
Fin si
End Sub
'Calculer la longueur en octets de la chaîne, un caractère chinois = 2 octets
FonctionStrLen(str)
Si isNull(str) ou Str = "" Alors
StrLen = 0
Fonction de sortie
Fin si
Faible WINNT_CHINESE
WINNT_CHINESE = (len("exemple")=2)
Si WINNT_CHINESE Alors
Faible l,t,c
Faible je
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
Suivant
StrLen = t
Autre
StrLen = len(str)
Fin si
End Function
'Chaîne d'interception
'str : la chaîne à intercepter
'strlen : la longueur à intercepter
' addStr : utilisez-le à la place s'il dépasse la longueur, par exemple :...
Fonction CutStr(str, strlen, addStr)
Dim je, l, t, c
If Is_Empty(str) Then CutStr = "" : Quitter la fonction
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
Fin si
Si t > strlen Alors
CutStr = gauche (str, i) & addStr
Quitter pour
Autre
CutStr = chaîne
Fin si
Suivant
End Function
'Convertir la pleine largeur en demi-largeur
Fonction SBCcaseConvert(str)
Dim b, c, je
b = "1,2,3,4,5,6,7,8,9,0," _
&"A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X, Ｙ,Ｚ"
c = "1,2,3,4,5,6,7,8,9,0," _
&"A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X, Y,Z"
b = divisé(b,",")
c = divisé(c,",")
Pour i = 0 Vers Ubound(b)
Si instr(str,b(i)) > 0 Alors
str = Remplacer (str, b(i), c(i))
Fin si
Suivant
SBCcaseConvert = chaîne
End Function
'est équivalent à escape() en javascript
Fonction VbsEscape(str)
dimi,s,c,a
s = ""
Pour i=1 à Len(str)
c = Milieu (str,i,1)
une = ASCW(c)
Si (a>=48 et a<=57) ou (a>=65 et a<=90) ou (a>=97 et a<=122) Alors
s = s&c
SinonSi InStr("@*_+-./",c) > 0 Alors
s = s&c
SinonSi a>0 et a<16 Alors
s = s & "%0" & Hex(a)
SinonSi a>=16 et a<256 Alors
s = s & "%" & Hex(a)
Autre
s = s & "%u" & Hex(a)
Fin si
Suivant
VbsEscape=s
End Function
'Décoder les données codées à l'aide de escape() en javascript, utilisé lors de l'appel d'ajax
Fonction VbsUnEscape(str)
Dim x
x = InStr(str,"%")
Faire pendant que x > 0
VbsUnEscape = VbsUnEscape & Mid(str,1,x-1)
Si LCase(Mid(str,x+1,1)) = "u" Alors
VbsUnEscape = VbsUnEscape & ChrW(CLng("&H"&Mid(str,x+2,4)))
str = Milieu (str,x+6)
Autre
VbsUnEscape = VbsUnEscape & Chr(CLng("&H"&Mid(str,x+1,2)))
str = Milieu (str,x+3)
Fin si
x = InStr(str,"%")
Boucle
VbsUnEscape = VbsUnEscape & str
Fonction de fin
'Convertir les caractères ascii en forme d'encodage Unicode
Fonction A2U(str)
Dim i,L,uTexte
L = Len(force)
Pour i = 1 à L
uText = uText & "&#" & AscW(Mid(str,i,1)) & ";"
Suivant
A2U = uTexte
End Function
'Convertir le codage Unicode en ascii
'str : La chaîne à transcoder doit être composée de caractères Unicode, sinon une erreur se produira
Fonction U2A(str)
Dim ary,i,L,newStr
ary = Split(str,";")
L = UBound(ary)
Pour i = 0 À L - 1
newStr = newStr & ChrW(Remplacer(ary(i),"&#",""))
Suivant
U2A = nouvelleStr
Fonction de fin
'encodage d'URL
Fonction UrlEncode(str)
UrlEncode = Serveur.UrlEncode(str)
Décodage de l'URL
de la fonction de fin
FonctionUrlDecode(str)
Dim newstr, havechar, lastchar, i, char_c, next_1_c, next_1_Num
nouvelle chaîne = ""
havechar = faux
dernier caractère = ""
Pour i = 1 À Len(str)
char_c = Milieu(str,i,1)
Si char_c = "+" Alors
nouvelle chaîne = nouvelle chaîne & " "
SinonSi char_c = "%" Alors
next_1_c = Milieu (str, i+1, 2)
next_1_num = Cint("&H" & next_1_c)
Si havechar Alors
havechar = faux
newstr = newstr & Chr(CInt("&H" & lastchar & next_1_c))
Autre
Si Abs(next_1_num) <= 127 Alors
nouvelle chaîne = nouvelle chaîne & Chr (next_1_num)
Autre
havechar = vrai
dernier caractère = next_1_c
Fin si
Fin si
je = je + 2
Autre
nouvelle chaîne = nouvelle chaîne & char_c
Fin si
Suivant
UrlDecode = chaîne de nouvelles
Fonction de fin
'GB en UTF8 - Convertir le texte codé GB en texte codé UTF8
Fonction GBToUTF8(gbStr)
Dim wch,uch,szRet,szInput
Dim x
Faible nAsc, nAsc2, nAsc3
szInput = gbStr
'Si le paramètre d'entrée est vide, quittez la fonction
Si szInput = "" Alors
toUTF8 = szInput
Fonction de sortie
Fin si
'Démarrer la conversion
Pour x = 1 À Len(szInput)
'Utiliser la fonction Mid pour diviser le texte codé en Go
wch = Milieu (szInput, x, 1)
'Utilisez la fonction ascW pour renvoyer le code de caractère Unicode de chaque texte codé en Go
'Remarque : la fonction asc renvoie le code de caractère ANSI, faites attention à la différence
nAsc = AscW(wch)
Si nAsc < 0 Alors nAsc = nAsc + 65536
Si (nAsc Et &HFF80) = 0 Alors
szRet = szRet & wch
Autre
Si (nAsc Et &HF000) = 0 Alors
uch = "%" & Hex(((nAsc 2 ^ 6)) ou &HC0) & Hex(nAsc Et &H3F ou &H80)
szRet = szRet&uch
Autre
'Le code de caractères Unicode du texte codé en Go adopte un modèle de trois octets entre 0800 et FFFF.
uch = "%" & Hex((nAsc 2 ^ 12) ou &HE0) & "%" & _
Hex((nAsc 2 ^ 6) Et &H3F ou &H80) & "%" & _
Hex(nAsc et &H3F ou &H80)
szRet = szRet&uch
Fin si
Fin si
Suivant
GBToUTF8 = szRet
Fonction de fin
'Conversion du flux d'octets en flux de caractères
Fonction Bytes2Str(vin,charset)
Dim ms,strRet
Set ms = Server.CreateObject("ADODB.Stream") 'Créer un objet flux
ms.Type = 1 'Binaire
ms.Ouvrir
ms.Write vin 'Écrivez vin dans l'objet stream
ms.Position = 0 'Définissez la position de départ de l'objet flux sur 0 pour définir la propriété Charset
ms.Type = 2 'Texte
ms.Charset = charset 'Définit le mode de codage de l'objet flux sur charset
strRet = ms.ReadText 'Obtenir le flux de caractères
ms.close 'Ferme l'objet flux
Définir ms = rien
Octets2Str = strRet
Fonction de fin
'Conversion du flux de caractères en flux d'octets
Fonction Str2Bytes(str,charset)
Dim ms,strRet
Set ms = CreateObject("ADODB.Stream") 'Créer un objet flux
ms.Type = 2 'Texte
ms.Charset = charset 'Définit le mode de codage de l'objet flux sur charset
ms.Ouvrir
ms.WriteText str 'Écrit str dans l'objet flux
ms.Position = 0 'Définissez la position de départ de l'objet flux sur 0 pour définir la propriété Charset
ms.Type = 1 'Vout binaire
= ms.Read(ms.Size) 'Obtenir le flux de caractères
ms.close 'Ferme l'objet flux
Définir ms = rien
Str2Bytes = vout
Fonction de fin
'--------------------------------L'opération de chaîne se termine
'------------- -------- --------------------L'opération d'heure et de date démarre
'Obtenir le nombre correspondant de jours dans le mois en fonction de l'année et du mois
'Renvoie le nombre de jours
'y : année, tel que : 2008
je suis : mois, tel que : 3
Fonction GetDayCount(y,m)
Faible c
Sélectionnez le cas m
Cas 1, 3, 5, 7, 8, 10, 12
c=31
Cas 2
Si IsDate(y&"-"&m&"-"&"29") Alors
c=29
Autre
c=28
Fin si
Autre cas
c=30
Fin de la sélection
GetDayCount = c
End Function
'Détermine si une date et une heure se situent entre une certaine période de temps, y compris l'heure aux deux extrémités de la comparaison
Fonction IsBetweenTime (fromTime, toTime, strTime)
Si DateDiff("s",fromTime,strTime) >= 0 Et DateDiff("s",toTime,strTime) <= 0 Alors
EstBetweenTime = Vrai
Autre
EstBetweenTime = Faux
Fin si
Fonction de fin
'--------------------------------L'opération d'heure et de date se termine
'---------------- ---------- --------------------Début des opérations liées au chiffrement de sécurité
'----------------------------------Fin des opérations liées au cryptage de sécurité
'-------------- ---- -----------------L'opération de vérification de la légalité des données commence
'Détecte la chaîne via une expression régulière et renvoie true|false
Fonction RegExpTest(strPatrn,strText)
Dim objRegExp, correspondances
Définir objRegExp = Nouvelle RegExp
objRegExp.Pattern = strPatrn
objRegExp.IgnoreCase = Faux
objRegExp.Global = Vrai
RegExpTest = objRegExp.Test(strText)
'Définir les correspondances = objRegExp.Execute(strText)
Définir objRegExp = rien
End Function
« Est-ce un entier positif ?
FunctionIsPint(str)
IsPint = RegExpTest("^[1-9]{1}d*$", str)
End Function
'Que ce soit 0 ou un entier positif
FonctionIsInt(str)
IsInt = RegExpTest("^0|([1-9]{1}d*)$", str)
Fonction de fin
'E-mail
FunctionIsEmail(str)
Modèle de gradation
motif = "^w+((-w+)|(.w+))*@[A-Za-z0-9]+((.|-)[A-Za-z0-9]+ )*.[A-Za-z0-9]+$"
IsEmail = RegExpTest (motif, str)
Fonction de fin
'téléphone portable
FunctionIsMobile(str)
Modèle de gradation
motif = "^(130|131|132|133|153|134|135|136|137|138|139|158|159){1}d{8}$"
IsMobile = RegExpTest (modèle, str)
Fonction de fin
'QQ
FonctionIsQQ(str)
Modèle de gradation
motif = "^[1-9]d{4,8}$"
IsQQ = RegExpTest(motif,str)
Fonction de fin
'Carte d'identité
FunctionIsIdCard(e)
Dim arrVerifyCode, Wi, Checker
arrVerifyCode = Split("1,0,x,9,8,7,6,5,4,3,2", ",")
Wi = Divisé("7,9,10,5,8,4,2,1,6,3,7,9,10,5,8,4,2", ",")
Vérificateur = Split("1,9,8,7,6,5,4,3,2,1,1", ",")
Si Len(e) < 15 ou Len(e) = 16 ou Len(e) = 17 ou Len(e) > 18 Alors
IsIdCard = Faux
Fonction de sortie
Fin si
Dim. A
Si Len(e) = 18 Alors
Ai = Milieu (e, 1, 17)
SinonSi Len(e) = 15 Alors
Ai=e
Ai = Gauche (Ai, 6) & "19" & Milieu (Ai, 7, 9)
Fin si
Si ce n'est pas IsNumeric (Ai), alors
IsIdCard=Faux
Fonction de sortie
Fin si
Dim strYear, strMonth, strDay, BirthDay
strAnnée = CInt (Mid (Ai, 7, 4))
strMois = CInt(Mid(Ai, 11, 2))
strDay = CInt (Mid (Ai, 13, 2))
Jour de naissance = Trim(strYear) + "-" + Trim(strMonth) + "-" + Trim(strDay)
Si IsDate(BirthDay) Alors
Si DateDiff("aaaa",Maintenant,BirthDay)<-140 ou cdate(BirthDay)>date() Alors
IsIdCard=Faux
Fonction de sortie
Fin si
Si strMonth > 12 ou strDay > 31 Alors
IsIdCard=Faux
Fonction de sortie
Fin si
Autre
IsIdCard=Faux
Fonction de sortie
Fin si
Dim i,TotalmulAiWi
Pour i = 0 à 16
TotalmulAiWi = TotalmulAiWi + CInt(Mid(Ai, i + 1, 1)) * Wi(i)
Suivant
Faible valeur du module
modValue = TotalmulAiWi Mod 11
Dim strVerifyCode
strVerifyCode = arrVerifyCode (modValue)
Ai = Ai & strVerifyCode
IsIdCard = Ai
Si Len(e) = 18 Et e <> Ai Alors
IsIdCard=Faux
Fonction de sortie
Fin si
IsIdCard=Vrai
Fonction de fin
'Code Postal
Fonction IsZipCode(str)
Modèle de gradation
motif = "^[1-9]d{2,5}$"
IsZipCode = RegExpTest (motif, str)
Fonction de fin
'Qu'il soit vide, y compris les fonctions IsEmpty(), IsNull(), ""
Fonction Is_Empty(str)
Si IsNull(str) ou IsEmpty(str) ou str="" Alors
Is_Empty=Vrai
Autre
Is_Empty=Faux
Fin si
Fonction de fin
'--------------------------------L'opération de vérification de la validité des données se termine
'--------- -- ---------------------L'opération sur le fichier démarre
'Obtenir le suffixe du fichier, tel que jpg
Fonction GetFileExt(f)
GetFileExt = Lcase(Mid(f,InStrRev(f,".") + 1))
Fonction de fin
'Générer un dossier
'path : le chemin d'accès au dossier à générer, utilisez un chemin relatif
Sous-Dossier(chemin)
Faible fso
Définir fso = Server.CreateObject("Scripting.FileSystemObject")
Si ce n'est pas le cas fso.FolderExists (chemin) alors
fso.CreateFolder(chemin)
Fin si
Définir fso = Rien
End Sub
'Supprimer le dossier
'path : chemin du dossier, utiliser le chemin relatif
Sous-Dossier (chemin)
Faible fso
Définir fso = Server.CreateObject("Scripting.FileSystemObject")
Si fso.FolderExists(chemin) Alors
chemin fso.DeleteFolder, vrai
Autre
echo "Le chemin n'existe pas :" & chemin
Fin si
Définir fso = Rien
End Sub
'Générer un fichier
'path : Générer le chemin du fichier, y compris le nom
'strText : contenu du fichier
Sous CFile (chemin, strText)
Faible f,fso
Définir fso = Server.CreateObject("Scripting.FileSystemObject")
Définir f = fso.CreateTextFile (chemin)
f.Écrire strText
Définir f = Rien
Définir fso = Rien
End Sub
'Supprimer le fichier
'path : chemin du fichier, y compris le nom
Sous-Fichier(chemin)
Faible fso
Définir fso = Server.CreateObject("Scripting.FileSystemObject")
Si fso.FileExists(chemin) Alors
Fso.DeleteFile(chemin)
Fin si
Définir fso = Rien
Fin du sous
-collecte
Fonction GetHTTPPage(url)
'Http.setTimeouts 10 000,10 000,10 000,10 000
'En cas d'erreur, reprendre ensuite
Faible Http
Définir Http = Server.createobject("MSXML2.XMLHTTP")
Http.open "GET",url,false
Http.envoyer()
Si Http.Status <> 200 Alors
Fonction de sortie
Fin si
'Si Err alors Response.Write url : Response.End()
GetHTTPPage = octetsToBSTR(Http.ResponseBody,"GB2312")
'Http.Fermer()
'si err.number<>0 alors err.Clear
End Function
'Conversion d'encodage
Fonction BytesToBstr(corps,Cset)
DimStreamObj
Définir StreamObj = Server.CreateObject("Adodb.Stream")
StreamObj.Type = 1
StreamObj.Mode = 3
StreamObj.Open
Corps StreamObj.Write
StreamObj.Position = 0
StreamObj.Type = 2
StreamObj.Charset = Cset
BytesToBstr = StreamObj.ReadText
StreamObj.Fermer
Fonction de fin
'--------------------------------L'opération sur le fichier se termine
'------------- -------------------D'autres opérations commencent
'Afficher les informations
'message : le message à afficher
'url : URL vers laquelle accéder
'typeNum : mode d'affichage, 1 affiche les informations et revient à la page précédente ; 2 affiche les informations et accède à l'url.
Sous ShowMsg (message, URL, typeNum)
message = remplacer(message,"'","'")
Sélectionnez le type de casNum
Cas 1
echo ("<script language=javascript>alert('" & message & "');history.go(-1)</script>")
Cas 2
echo ("<script language=javascript>alert('" & message & "');location="" & Url &"'</script>")
Fin de la sélection
End Sub
'Afficher la liste et la position des options, par Xilou www.chinacms.org
'textArr : tableau de texte
'valueArr : tableau de valeurs
'curValue : valeur actuellement sélectionnée
Fonction ShowOpList (textArr, valueArr, curValue)
Dim str, style, je
style = "style=""couleur-de-fond:#FFCCCC"""
chaîne = ""
Si IsNull(curValue) Alors curValue = ""
Pour I = LBound (textArr) À UBound (valueArr)
Si Cstr(valueArr(I)) = Cstr(curValue) Alors
str = str&"<option value="""&valueArr(I)&""" selected=""selected"" "&style&" >"&textArr(I)&"</option>"&vbcrlf
Autre
str = str&"<option value="""&valueArr(I)&""" >"&textArr(I)&"</option>"&vbcrlf
Fin si
Suivant
ShowOpList = chaîne
End Function
'Liste de sélection multiple
'Remarque : vous devez utiliser la fonction InArray()
'textArr : tableau de texte
'valueArr : tableau de valeurs
'curValue : tableau de valeurs actuellement sélectionné
Fonction ShowMultiOpList(textArr,valueArr,curValueArr)
Style Dim, str, isCurr, I
style = "style=""couleur-de-fond:#FFCCCC"""
str = "" : isCurr = Faux
Si IsNull(curValue) Alors curValue = ""
Pour I = LBound (textArr) À UBound (valueArr)
Si InArray(curValueArr, valueArr(I)) Alors
str = str&"<option value="""&valueArr(I)&""" selected=""selected"" "&style&" >"&textArr(I)&"</option>"&vbcrlf
Autre
str = str&"<option value="""&valueArr(I)&""" >"&textArr(I)&"</option>"&vbcrlf
Fin si
Suivant
ShowMultiOpList = chaîne
Fonction de fin
Fonction GetIP()
Dim strIPAddr,actforip
Si Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" ou InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Alors
strIPAddr = Request.ServerVariables("REMOTE_ADDR")
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Alors
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1)
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Alors
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)
Autre
strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
Fin si
GetIP = strIPAddr
Fonction de fin
'Convertir le tableau en stockage d'objets de dictionnaire
'hashObj : objet dictionnaire
'ary : Array, le format doit être l'un des deux suivants, le premier ne peut stocker que des valeurs de chaîne
' : array("Id:12","UserName:xilou","Sex:1"), c'est-à-dire au format array("key:value",...)
' : array(array("Id","12"),array("UserName","xilou"),array("Sex","1"))
'Renvoyer l'objet du dictionnaire
'www.chinacms.org
Sub AryAddToHashTable (ByRef hashObj,ary)
Dim str,ht,i,k,v,pos
Pour i = 0 À UBound(ary)
Si IsArray(ary(i)) Alors
Si IsObject(ary(i)(0)) Alors
Response.Write "Erreur : AryToHashTable(ary), la valeur clé ne peut pas être un type d'objet",
Response.Write "Le type de valeur ary("& i &")(0) actuel est :" & TypeName(ary(i)(0))
Réponse.Fin()
Fin si
If IsObject(ary(i)(1)) Then 'Si la valeur est un objet
Définir hashObj(ary(i)(0)) = ary(i)(1)
Autre
hashObj(ary(i)(0)) = ary(i)(1)
Fin si
Autre
str = ary(i) & ""
pos = InStr(str,":")
'www.chinacms.org
Si pos < 1 Alors
Response.Write "Erreur : AryToHashTable(ary),"": " N'existe pas »
Réponse.Écrivez ", se produit à :" & ary(i)
Réponse.Fin()
Fin si
Si pos = 1 Alors
Response.Write "Erreur : AryToHashTable(ary), la valeur clé n'existe pas"
Réponse.Écrivez ", se produit à :" & ary(i)
Réponse.Fin()
Fin si
k = Gauche (str, pos-1)
v = Milieu (str, pos+1)
hachageObj(k) = v
Fin si
Suivant
End Sub
'Convertir le tableau en stockage d'objets de dictionnaire
'ary : Array, le format doit être l'un des deux suivants, le premier ne peut stocker que des valeurs de chaîne
' : array("Id:12","UserName:xilou","Sex:1"), c'est-à-dire au format array("key:value",...)
' : array(array("Id","12"),array("UserName","xilou"),array("Sex","1"))
'Renvoyer l'objet du dictionnaire
Fonction AryToHashTable(ary)
Dim str,ht,i,k,v,pos
Définir ht = Server.CreateObject("Scripting.Dictionary")
ht.CompareMode = 1
AryAddToHashTable ht , ary
Définir AryToHashTable = ht
End Function
'Convertir un tableau en chaîne, ce qui équivaut à sérialiser un tableau. Les seuls formats autorisés sont :
'array("p1:v1","p2:v2",array("p3",true))
'chaîne de retour
Fonction AryToVbsString(arr)
Dim str,i,c
If Not IsArray(arr) Then Response.Write "Erreur : erreur AryToString(arr), le paramètre arr n'est pas un tableau"
c = UBound(arr)
Pour i = 0 À c
Si IsArray(arr(i)) Alors
Sélectionnez Case LCase(TypeName(arr(i)(1)))
Cas "date", "chaîne", "vide"
str = str & ",array(""" & arr(i)(0) & ""","""& arr(i)(1) &""")"
Cas "entier", "long", "single", "double", "devise", "décimal", "booléen"
str = str & ",array(""" & arr(i)(0) & ""","& arr(i)(1) &")"
Cas "nul"
str = str & ",array(""" & arr(i)(0) & """,null)"
Autre cas
Response.Write "Erreur : AryToVbsString(arr), le paramètre contient des données illégales, index i="&i&", la valeur de la clé est : "&arr(i)(0)
Réponse.Fin()
Fin de la sélection
Autre
str = str & ",""" & arr(i) & """"
Fin si
Suivant
Si str <> "" Alors str = Mid(str, 2, Len(str) - 1)
str = "tableau(" & str & ")"
AryToVbsString = chaîne
Fonction de fin
'--------------------------------Fin des autres opérations
%>