código de programa
<%
'******************************
'Nombre de clase:
'Nombre: biblioteca general
'Fecha: 28/10/2008
'Autor: por xilou
'Sitio web: http://www.chinacms.org
'Descripción: Biblioteca general
'Copyright: indique la fuente y el autor al reimprimir
'******************************
'Última modificación: 20090108
'Número de modificaciones: 2
'Descripción de la modificación:
'20090108 Agregue las siguientes funciones:
' A2U(),U2A(),UrlEncode(),UrlDecode(),GBToUTF8(),Bytes2Str(),Str2Bytes()
'20090108 Agregue las siguientes funciones:
'AryToVbsString(arr)
'Versión actual:
'******************************/
'Producción
Sub eco (cadena)
Respuesta.Escribir str
Fin del subpunto
de interrupción
Subdetener()
Respuesta.Fin()
End Sub
'Salida y ajuste
SubBr(cadena)
Cadena de eco & "<br />" & vbcrlf
End Sub
'Simplificar Solicitud.Form()
'f: nombre del formulario
Función P(f)
P = Reemplazar(Solicitud.Form(f), Chr(0), "")
Función final
'Recibir el formulario y reemplazar comillas simples
Función Pr(f)
Pr = Reemplazar(Solicitud.Form(f), Chr(0), "")
Pr = Reemplazar(Pr, "'", "''")
Función final
'Simplificar solicitud.Querystring()
'f: nombre del formulario
FunciónG(f)
G = Reemplazar(Request.QueryString(f), Chr(0), "")
Función final
'Recibir parámetros de URL y reemplazar comillas simples
FunciónGr(f)
Gr = Reemplazar(Request.QueryString(f), Chr(0), "")
Gr = Reemplazar(Gr, "'", "''")
Función final
'//Construcción()?:Operación ternaria por xilou www.chinacms.org
'ifThen devuelve s1 para verdadero y s2 para falso
Función IfThen(ifTrue, s1, s2)
tenue
Si es cierto entonces
t = s1
Demás
t = s2
Terminar si
Si entonces = t
Función final
'Mostrar sí y no en diferentes colores
Función IfThenFont(ifTrue, s1, s2)
Dimstr
Si es cierto entonces
cadena = "<font color=""#006600"">" & s1 & "</font>"
Demás
cadena = "<font color=""#FF0000"">" & s2 & "</font>"
Terminar si
IfThenFont = cadena
Función final
'Crear objeto de diccionario
Función NuevaHashTable()
Establecer NewHashTable = Server.CreateObj("Scripting.Dictionary")
NewHashTable.CompareMode = 1 'Los valores clave no distinguen entre mayúsculas y minúsculas
Función final
'Crear XmlHttp
Función NuevoXmlHttp()
Establecer NewXmlHttp = Server.createobject("MSXML2.XMLHTTP")
Función final
'Crear XmlDom
Función NuevoXmlDom()
Función final
'Crear AdoStream
Función NewAdoStream()
Establecer NewAdoStream = Server.CreateObject("Adodb.Stream")
Función final
'Crear una matriz unidimensional
'Devuelve una matriz vacía de n elementos
'n: número de elementos
FunciónNuevaMatriz(n)
Dim ary: ary = matriz()
ReDim ario(n-1)
NewArray = aria
Función final
'Construir prueba...Catch
Subintento()
En caso de error Continuar siguiente
End Sub
'Construct Try..Catch
'msg: Se arroja el mensaje de error, si está vacío, se arroja Err.Description
Captura secundaria (mensaje)
html oscuro
html = "<ul><li>$1</li></ul>"
Si se equivoca entonces
Si mensaje <> "" Entonces
echo Reemplazar(html, "$1", mensaje)
Detener
Demás
echo Reemplazar(html, "$1", Err.Descripción)
Detener
Terminar si
Err.Borrar
Respuesta.Fin()
Terminar si
End Sub
'--------------------------------comienza la operación de matriz
'Determinar si existe un determinado valor en la matriz
Función en matriz (arr, s)
Si no es IsArray (arr) entonces InArray = False: Salir de la función
Yo tenue
Para i = LBound(arr) A UBound(arr)
Si s = arr(i) Entonces InArray = True: Salir de la función
Próximo
En matriz = falso
Función final
'Reemplace los marcadores de posición en str con los valores en la matriz ary.
'Devuelve la cadena reemplazada
'str: La cadena que se va a reemplazar, los marcadores de posición son $0, $1, $2...
'ary: Matriz utilizada para reemplazo, cada valor corresponde a $0, $1, $2... en el marcador de posición.
'Por ejemplo: ReemplazarPorAry("$0-$1-$2 $3:$4:$5",Array(y,m,d,h,i,s))
Función ReemplazarPorAria(cadena,aria)
Atenuar i, j, L1, L2: j = 0
Si IsArray(ario) entonces
L1 = LBound(ario) : L2 = UBound(ario)
Para i = L1 a L2
cadena = Reemplazar(cadena, "$"&j, ary(i))
j = j+1
Próximo
Terminar si
Reemplazar por variable = cadena
Función final
'-------------------------------la operación de matriz finaliza
'------------- --- ---------------Comienza la operación de números aleatorios
'Obtener números aleatorios
'mn número aleatorio
Función RndNumber(m,n)
Aleatorizar
RndNúmero = Int((n - m + 1) * Rnd + m)
Función final
'Obtener una cadena aleatoria
'n: longitud generada
Función RndText(n)
Dim str1, str2, i, x, L
str1 = "NOPQRSTUVWXYZ012ABCDEFGHIJKLM3456abcdefghijklm789nopqrstuvwxyz"
L = Len(cadena1)
Aleatorizar
Para i = 1 tonelada
x = Int((L - 1 + 1) * Rnd + 1)
cadena2 = cadena2 y medio(cadena1,x,1)
Próximo
RndTexto = str2
Función final
'Generar m an cadenas aleatorias a partir de la cadena str
'Si str está vacío, se generará una cadena aleatoria a partir de números y letras de forma predeterminada
'str: Para generar una cadena aleatoria a partir de esta cadena
'm,n: genera n a m bits
Función RndByText(cadena, m, n)
Atenuar i, k, str2, L, x
Si str = "" Entonces str = "NOPQRSTUVWXYZ012ABCDEFGHIJKLM3456abcdefghijklm789nopqrstuvwxyz"
L = Len(cadena)
Si n = m Entonces
k = norte
Demás
Aleatorizar
k = Int((n - m + 1) * Rnd + m)
Terminar si
Aleatorizar
Para i = 1 Para k
x = Int((L - 1 + 1) * Rnd + 1)
cadena2 = cadena2 y medio (cadena, x, 1)
Próximo
RndByText = str2
Función final
'Fecha y hora forman números aleatorios
'Devuelve la combinación numérica de la hora actual
Función RndByDateTime()
Dim dt: dt = Ahora()
RndByDateTime = Año(dt) y Mes(dt) y Día(dt) y Hora(dt) y Minuto(dt) y Segundo(dt)
Función final
'-------------------------------La operación de número aleatorio finaliza
'----------------------- ------ --------------------Comienza la operación de cadena
'Determinar el número de veces que aparece una cadena str2 en otra cadena str1
'Devuelve el número de veces, si no, devuelve 0
'str1: expresión de cadena que acepta búsqueda
'str2: expresión de cadena a buscar
'inicio: la posición inicial que se buscará. Si está vacía, significa comenzar desde 1 de forma predeterminada.
Función InStrTimes(str1, str2, inicio)
aire acondicionado tenue
Si inicio = "" Entonces inicio = 1
c = 0
a = InStr(inicio, cadena1, cadena2)
Hacer mientras a > 0
c = c + 1
a = InStr(a+1, cadena1, cadena2)
Bucle
InStrTimes = c
Función final
'Concatenación de cadenas
'Sin retorno
'strResult: Caracteres guardados después de la conexión
'str: carácter a concatenar
'partición: símbolo de separación entre caracteres conectados
Sub JoinStr(byref strResult,str,partición)
Si strResult <> "" Entonces
strResult = strResult & partición & str
Demás
strResult = str
Terminar si
End Sub
'Calcula la longitud en bytes de la cadena, un carácter chino = 2 bytes
FunciónStrLen(cadena)
Si esNull(str) o Str = "" Entonces
StrLen = 0
Función de salida
Terminar si
Atenuado WINNT_CHINESE
WINNT_CHINESE = (len("ejemplo")=2)
Si WINNT_CHINESE Entonces
tenue l,t,c
Yo tenue
l = len(cadena)
t = l
Para i = 1 a l
c = asc(medio(cadena,i,1))
Si c<0 Entonces c = c + 65536
Si c>255 Entonces t = t + 1
Próximo
StrLen = t
Demás
StrLen = len(cadena)
Terminar si
Función final
'Interceptar cadena
'str: la cadena a ser interceptada
'strlen: la longitud a ser interceptada
' addStr: Utilice esto en su lugar si excede la longitud, como por ejemplo:...
Función CortarCadena(cadena, strlen, agregarCadena)
Atenuado i,l,t,c
Si Is_Empty(str) Entonces CutStr = "": Salir de la función
l = len(cadena): t = 0
Para i = 1 a l
c = Abs(Asc(Medio(str,i,1)))
Si c > 255 entonces
t=t+2
Demás
t=t+1
Terminar si
Si t > strlen Entonces
CortarCadena = izquierda(cadena, i) & agregarCadena
Salir por
Demás
Cortarcadena = cadena
Terminar si
Próximo
Función final
'Convertir ancho completo a medio ancho
Función SBCcaseConvert(cadena)
tenue b, c, i
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 = dividir(b,",")
c = dividir(c,",")
Para i = 0 a Ubound(b)
Si instr(str,b(i)) > 0 Entonces
cadena = Reemplazar (cadena, b(i), c(i))
Terminar si
Próximo
SBCcaseConvert = cadena
La función final
'es equivalente a escapar() en javascript
Función VbsEscape(cadena)
dimi,s,c,a
s = ""
Para i=1 a Len(cadena)
c = Medio(cadena,i,1)
a = ASCW(c)
Si (a>=48 y a<=57) o (a>=65 y a<=90) o (a>=97 y a<=122) Entonces
s = s&c
ElseIf InStr("@*_+-./",c) > 0 Entonces
s = s&c
De lo contrario, si a>0 y a<16, entonces
s = s y "%0" y hexadecimal(a)
De lo contrario, si a>=16 y a<256, entonces
s = s y "%" y hexadecimal(a)
Demás
s = s y "%u" y hexadecimal(a)
Terminar si
Próximo
VbsEscape=s
Función final
'Decodificar datos codificados usando escape() en javascript, usados al llamar a ajax
Función VbsUnEscape(cadena)
tenue x
x = InStr(cadena,"%")
Hacer mientras x > 0
VbsUnEscape = VbsUnEscape y Medio(cadena,1,x-1)
Si LCase(Mid(str,x+1,1)) = "u" Entonces
VbsUnEscape = VbsUnEscape & ChrW(CLng("&H"&Mid(str,x+2,4)))
cadena = Medio(cadena,x+6)
Demás
VbsUnEscape = VbsUnEscape & Chr(CLng("&H"&Mid(str,x+1,2)))
cadena = Medio(cadena,x+3)
Terminar si
x = InStr(cadena,"%")
Bucle
VbsUnEscape = VbsUnEscape & str
Función final
'Convierte caracteres ascii al formato de codificación Unicode
Función A2U(cadena)
Dim i,L,uTexto
L = Len(cadena)
Para i = 1 a L
uText = uText & "&#" & AscW(Mid(str,i,1)) & ";"
Próximo
A2U = uTexto
Función final
'Convertir codificación Unicode a ASCII
'str: La cadena a transcodificar debe tener todos caracteres Unicode; de lo contrario, se producirá un error.
Función U2A(cadena)
Dim ary,i,L,newStr
aria = Dividir(cadena,";")
L = UBound(ario)
Para i = 0 a L - 1
newStr = newStr & ChrW(Reemplazar(ario(i),"&#",""))
Próximo
U2A = nueva cadena
Función final
'codificación de URL
Función UrlEncode(cadena)
UrlEncode = Servidor.UrlEncode(cadena)
Funcion final
'decodificacion de URL
FunciónUrlDecode(cadena)
Dim newstr, havechar, lastchar, i, char_c, next_1_c, next_1_Num
noticiastr = ""
havechar = falso
último carácter = ""
Para i = 1 a Len(str)
char_c = Medio(cadena,i,1)
Si char_c = "+" Entonces
noticiastr = noticiastr & " "
De lo contrario, char_c = "%" Entonces
next_1_c = Medio(cadena, i+1, 2)
next_1_num = Cint("&H" & next_1_c)
Si havechar Entonces
havechar = falso
noticiastr = noticiastr & Chr(CInt("&H" & lastchar & next_1_c))
Demás
Si Abs(next_1_num) <= 127 Entonces
noticiastr = noticiastr & Chr(next_1_num)
Demás
havechar = verdadero
último carácter = siguiente_1_c
Terminar si
Terminar si
yo = yo + 2
Demás
noticiastr = noticiastr & char_c
Terminar si
Próximo
UrlDecode = noticiastr
Función final
'GB a UTF8: convierte texto codificado en GB a texto codificado en UTF8
Función GBToUTF8(gbStr)
Atenuar wch,uch,szRet,szInput
tenue x
Atenuado nAsc, nAsc2, nAsc3
szEntrada = gbStr
'Si el parámetro de entrada está vacío, salga de la función
Si szInput = "" Entonces
toUTF8 = szEntrada
Función de salida
Terminar si
'Iniciar conversión
Para x = 1 a Len(szInput)
'Usa la función mid para dividir texto codificado en GB
wch = Medio(szEntrada, x, 1)
'Utilice la función ascW para devolver el código de carácter Unicode de cada texto codificado en GB
'Nota: la función asc devuelve código de caracteres ANSI, preste atención a la diferencia
nAsc = AscW(wch)
Si nAsc < 0 Entonces nAsc = nAsc + 65536
Si (nAsc y &HFF80) = 0 Entonces
szRet = szRet & qué
Demás
Si (nAsc y &HF000) = 0 entonces
uch = "%" & Hex(((nAsc 2 ^ 6)) o &HC0) & Hex(nAsc y &H3F o &H80)
szRet = szRet&uch
Demás
'El código de caracteres Unicode del texto codificado en GB adopta una plantilla de tres bytes entre 0800 y FFFF
uch = "%" & Hex((nAsc 2 ^ 12) o &HE0) & "%" & _
Hex((nAsc 2 ^ 6) y &H3F o &H80) & "%" & _
Hex (nAsc y &H3F o &H80)
szRet = szRet&uch
Terminar si
Terminar si
Próximo
GBToUTF8 = szRet
Función final
'Conversión de flujo de bytes a flujo de caracteres
Función Bytes2Str(vin,juego de caracteres)
Dim ms, strRet
Establecer ms = Server.CreateObject("ADODB.Stream") 'Crear un objeto de secuencia
ms.Tipo = 1 'Binario
ms.abierto
ms.Write vin 'Escribe vin en el objeto de flujo
ms.Position = 0 'Establece la posición inicial del objeto de flujo en 0 para establecer la propiedad Charset
ms.Type = 2 'Texto
ms.Charset = charset 'Establece el modo de codificación del objeto de flujo en charset
strRet = ms.ReadText 'Obtiene el flujo de caracteres
ms.close 'Cerrar el objeto de flujo
Establecer ms = nada
Bytes2Str = strRet
Función final
'Conversión de flujo de caracteres a flujo de bytes
Función Str2Bytes(cadena,juego de caracteres)
Dim ms, strRet
Set ms = CreateObject("ADODB.Stream") 'Crear un objeto de secuencia
ms.Type = 2 'Texto
ms.Charset = charset 'Establece el modo de codificación del objeto de flujo en charset
ms.abierto
ms.WriteText str 'Escribe str en el objeto de flujo
ms.Position = 0 'Establece la posición inicial del objeto de flujo en 0 para establecer la propiedad Charset
ms.Type = 1 'Binary
vout = ms.Read(ms.Size) 'Obtener flujo de caracteres
ms.close 'Cerrar el objeto de flujo
Establecer ms = nada
Str2Bytes = vout
Función final
'--------------------------------La operación de cadena finaliza
'--------------------- -------- --------------------Se inicia la operación de fecha y hora
'Obtiene el número correspondiente de días en el mes según el año y el mes
'Devuelve el número de días
'y: año, como por ejemplo: 2008
'm: mes, como por ejemplo: 3
Función GetDayCount(y,m)
tenue c
Seleccionar caso m
Caso 1, 3, 5, 7, 8, 10, 12
c=31
Caso 2
Si IsDate(y&"-"&m&"-"&"29") Entonces
c=29
Demás
c=28
Terminar si
Caso más
c=30
Finalizar selección
GetDayCount = c
Función final
'Determina si una fecha y una hora se encuentran entre un cierto período de tiempo, incluido el tiempo en ambos extremos de la comparación
Función IsBetweenTime(fromTime,toTime,strTime)
Si DateDiff("s",fromTime,strTime) >= 0 y DateDiff("s",toTime,strTime) <= 0 Entonces
IsBetweenTime = Verdadero
Demás
IsBetweenTime = Falso
Terminar si
Función final
'-------------------------------- Finaliza la operación de fecha y hora
'----------- ---------- --------------------Comienzan las operaciones relacionadas con el cifrado de seguridad
'-------------------------------Las operaciones relacionadas con el cifrado de seguridad finalizan
'---------- ---- -----------------Comienza operación de verificación de legalidad de datos
'Detecta cadena mediante expresión regular y devuelve verdadero|falso
Función RegExpTest(strPatrn,strText)
Dim objRegExp, coincidencias
Establecer objRegExp = Nueva RegExp
objRegExp.Pattern = strPatrn
objRegExp.IgnoreCase = Falso
objRegExp.Global = Verdadero
RegExpTest = objRegExp.Test(strText)
'Establecer coincidencias = objRegExp.Execute(strText)
Establecer objRegExp = nada
Función final
'¿Es un número entero positivo?
FunciónIsPint(cadena)
IsPint = RegExpTest("^[1-9]{1}d*$", cadena)
Función final
'Si es 0 o un entero positivo
FunciónIsInt(cadena)
IsInt = RegExpTest("^0|([1-9]{1}d*)$", cadena)
Función final
'Correo electrónico
FunciónIsEmail(cadena)
patrón tenue
patrón = "^w+((-w+)|(.w+))*@[A-Za-z0-9]+((.|-)[A-Za-z0-9]+ )*.[A-Za-z0-9]+$"
IsEmail = RegExpTest(patrón,cadena)
Función final
'Teléfono móvil
FunciónIsMobile(cadena)
patrón tenue
patrón = "^(130|131|132|133|153|134|135|136|137|138|139|158|159){1}d{8}$"
IsMobile = RegExpTest(patrón,cadena)
Función final
'QQ
FunciónIsQQ(cadena)
patrón tenue
patrón = "^[1-9]d{4,8}$"
IsQQ = PruebaExpReg(patrón,cadena)
Función final
'Tarjeta de identificación
FunciónIsIdCard(e)
Dim arrVerifyCode,Wi,Checker
arrVerifyCode = Dividir("1,0,x,9,8,7,6,5,4,3,2", ","")
Wi = Dividir("7,9,10,5,8,4,2,1,6,3,7,9,10,5,8,4,2", ","")
Verificador = Dividir ("1,9,8,7,6,5,4,3,2,1,1", ",")
Si Len(e) < 15 o Len(e) = 16 o Len(e) = 17 o Len(e) > 18 Entonces
IsIdCard = Falso
Función de salida
Terminar si
tenue A
Si Len(e) = 18 Entonces
Ai = Medio(e, 1, 17)
De lo contrario, si Len(e) = 15, entonces
ai=e
Ai = Izquierda(Ai, 6) y "19" y Medio(Ai, 7, 9)
Terminar si
Si no es numérico (Ai) entonces
IsIdCard= Falso
Función de salida
Terminar si
Dim strAño, strMes, strDía, Día de nacimiento
strAño = CInt(Medio(Ai, 7, 4))
strMes = CInt(Medio(Ai, 11, 2))
strDay = CInt(Medio(Ai, 13, 2))
Día de nacimiento = Trim(strAño) + "-" + Trim(strMes) + "-" + Trim(strDía)
Si es fecha (cumpleaños) entonces
Si DateDiff("yyyy",Now,BirthDay)<-140 o cdate(BirthDay)>date() Entonces
IsIdCard= Falso
Función de salida
Terminar si
Si strMonth > 12 o strDay > 31 Entonces
IsIdCard= Falso
Función de salida
Terminar si
Demás
IsIdCard= Falso
Función de salida
Terminar si
Dim i,TotalmulAiWi
Para i = 0 a 16
TotalmulAiWi = TotalmulAiWi + CInt(Medio(Ai, i + 1, 1)) * Wi(i)
Próximo
Valor mod tenue
modValue = TotalmulAiWi Mod 11
Dim strVerifyCode
strVerifyCode = arrVerifyCode(modValue)
Ai = Ai y strVerifyCode
IsIdCard = Ai
Si Len(e) = 18 y e <> Ai entonces
IsIdCard= Falso
Función de salida
Terminar si
IsIdCard=Verdadero
Función final
'Código Postal
Función IsZipCode(cadena)
patrón tenue
patrón = "^[1-9]d{2,5}$"
IsZipCode = RegExpTest(patrón,cadena)
Función final
'Si está vacío, incluidas las funciones de IsEmpty(), IsNull(), ""
Función Está_Vacía(cadena)
Si IsNull(str) o IsEmpty(str) o str="" Entonces
Está_Vacío=Verdadero
Demás
Está_Vacío=Falso
Terminar si
Función final
'--------------------------------La operación de verificación de validez de datos finaliza
'--------- -- ---------------------Se inicia la operación de archivo
'Obtiene el sufijo del archivo, como jpg
Función ObtenerExtArchivo(f)
GetFileExt = Lcase(Mid(f,InStrRev(f,".") + 1))
Función final
'Generar carpeta
'ruta: la ruta a la carpeta que se generará, use una ruta relativa
Subcarpeta(ruta)
fso tenue
Establecer fso = Server.CreateObject("Scripting.FileSystemObject")
Si no es fso.FolderExists (ruta) entonces
fso.CreateFolder(ruta)
Terminar si
Establecer fso = Nada
End Sub
'Eliminar carpeta
'ruta: ruta de la carpeta, use la ruta relativa
Subcarpeta (ruta)
fso tenue
Establecer fso = Server.CreateObject("Scripting.FileSystemObject")
Si fso.FolderExists (ruta) Entonces
fso.DeleteRuta de la carpeta, verdadero
Demás
echo "La ruta no existe:" & ruta
Terminar si
Establecer fso = Nada
End Sub
'Generar archivo
'ruta: genera la ruta del archivo, incluido el nombre
'strText: contenido del archivo
SubCFile(ruta,strText)
tenue f,fso
Establecer fso = Server.CreateObject("Scripting.FileSystemObject")
Establecer f = fso.CreateTextFile(ruta)
f.Escribir strText
Establecer f = Nada
Establecer fso = Nada
End Sub
'Eliminar archivo
'ruta: ruta del archivo, incluido el nombre
SubDFile(ruta)
fso tenue
Establecer fso = Server.CreateObject("Scripting.FileSystemObject")
Si fso.FileExists (ruta) Entonces
Fso.DeleteFile(ruta)
Terminar si
Establecer fso = Nada
Fin Sub
'Recoger
Función GetHTTPPage(url)
'Http.setTimeouts 10000,10000,10000,10000
'En caso de error, reanudar siguiente
HTTP tenue
Establecer Http = Server.createobject ("MSXML2.XMLHTTP")
Http.open "OBTENER", URL, falso
http.enviar()
Si Http.Status <> 200 Entonces
Función de salida
Terminar si
'Si Err, entonces Response.Write URL: Response.End()
GetHTTPPage = bytesToBSTR(Http.ResponseBody,"GB2312")
'Http.Cerrar()
'si número.err<>0 entonces err.Borrar
Función final
'Conversión de codificación
Función BytesToBstr(cuerpo,Cset)
DimStreamObj
Establecer StreamObj = Server.CreateObject ("Adodb.Stream")
StreamObj.Tipo = 1
StreamObj.Modo = 3
StreamObj.Open
StreamObj.Escribir cuerpo
StreamObj.Posición = 0
StreamObj.Tipo = 2
StreamObj.Charset = Cset
BytesToBstr = StreamObj.ReadText
StreamObj.Cerrar
Función final
'--------------------------------La operación de archivo finaliza
'-------------------- ------------------Comienzan otras operaciones
'Mostrar información
'mensaje: el mensaje que se mostrará
'url: URL a la que saltar
'typeNum: modo de visualización, 1 muestra información y regresa a la página anterior 2 muestra información y va a la URL;
Sub ShowMsg(mensaje,url,tipoNum)
mensaje = reemplazar(mensaje,"'","'")
Seleccione Número de tipo de caso
Caso 1
echo ("<script language=javascript>alert('" & mensaje & "');history.go(-1)</script>")
Caso 2
echo ("<script language=javascript>alert('" & mensaje & "');ubicación='" & Url &"'</script>")
Finalizar selección
End Sub
'Mostrar lista de opciones y posición, por xilou www.chinacms.org
'textArr: matriz de texto
'valueArr: matriz de valores
'curValue: valor seleccionado actualmente
Función ShowOpList(textArr, valueArr, curValue)
Dim str, estilo, yo
estilo = "estilo=""color-de fondo:#FFCCCC"""
cadena = ""
Si IsNull(curValue) Entonces curValue = ""
Para I = LBound(textArr) a UBound(valueArr)
Si Cstr(valueArr(I)) = Cstr(curValue) Entonces
str = str&"<option value="""&valueArr(I)&""" seleccionado=""seleccionado"" "&style&" >"&textArr(I)&"</option>"&vbcrlf
Demás
cadena = cadena&"<opción valor="""&valueArr(I)&""" >"&textArr(I)&"</option>"&vbcrlf
Terminar si
Próximo
MostrarListaOp = cadena
Función final
'Lista de selección múltiple
'Nota: necesitas usar la función InArray()
'textArr: matriz de texto
'valueArr: matriz de valores
'curValue: matriz de valores actualmente seleccionada
Función MostrarMultiOpList(textArr,valueArr,curValueArr)
Estilo tenue, str, isCurr, I
estilo = "estilo=""color-de fondo:#FFCCCC"""
str = "" : isCurr = Falso
Si IsNull(curValue) Entonces curValue = ""
Para I = LBound(textArr) a UBound(valueArr)
Si InArray (curValueArr, valueArr (I)) Entonces
str = str&"<option value="""&valueArr(I)&""" seleccionado=""seleccionado"" "&style&" >"&textArr(I)&"</option>"&vbcrlf
Demás
cadena = cadena&"<opción valor="""&valueArr(I)&""" >"&textArr(I)&"</option>"&vbcrlf
Terminar si
Próximo
ShowMultiOpList = cadena
Función final
Función ObtenerIP()
Dim strIPAddr, actforip
Si Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" o InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "desconocido") > 0 Entonces
strIPAddr = Solicitud.ServerVariables("REMOTE_ADDR")
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ","") > 0 Entonces
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 Entonces
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)
Demás
strIPAddr = Solicitud.ServerVariables("HTTP_X_FORWARDED_FOR")
Terminar si
ObtenerIP = strIPAddr
Función final
'Convierte la matriz en almacenamiento de objetos de diccionario
'hashObj: objeto de diccionario
'ary: Matriz, el formato debe ser uno de los dos siguientes, el primero solo puede almacenar valores de cadena
' : matriz("Id:12","Nombre de usuario:xilou","Sexo:1"), es decir, formato matriz("clave:valor",...)
' : matriz(matriz("Id","12"),matriz("Nombre de usuario","xilou"),matriz("Sexo","1"))
'Devolver objeto de diccionario
'www.chinacms.org
Sub AryAddToHashTable(ByRef hashObj,ary)
Dim str,ht,i,k,v,pos
Para i = 0 a UBound(ary)
Si IsArray(ario(i)) Entonces
Si IsObject(ario(i)(0)) Entonces
Response.Write "Error: AryToHashTable (ary), el valor clave no puede ser un tipo de objeto".
Response.Write "El tipo de valor ary("& i &")(0) actual es:" & TypeName(ary(i)(0))
Respuesta.Fin()
Terminar si
Si IsObject(ary(i)(1)) Then 'Si el valor es un objeto
Establecer hashObj(ario(i)(0)) = ario(i)(1)
Demás
hashObj(ario(i)(0)) = ario(i)(1)
Terminar si
Demás
cadena = aria(i) & ""
pos = InStr(cadena,":")
'www.chinacms.org
Si pos < 1 entonces
Response.Write "Error:AryToHashTable(ary),"":""No existe"
Respuesta.Escribir ",Ocurre en:" & ary(i)
Respuesta.Fin()
Terminar si
Si pos = 1 entonces
Response.Write "Error: AryToHashTable (ary), el valor clave no existe"
Respuesta.Escribir ",Ocurre en:" & ary(i)
Respuesta.Fin()
Terminar si
k = Izquierda(cadena,pos-1)
v = Medio(cadena,pos+1)
hashObj(k) = v
Terminar si
Próximo
End Sub
'Convierte la matriz en almacenamiento de objetos de diccionario
'ary: Matriz, el formato debe ser uno de los dos siguientes, el primero solo puede almacenar valores de cadena
' : matriz("Id:12","Nombre de usuario:xilou","Sexo:1"), es decir, formato matriz("clave:valor",...)
' : matriz(matriz("Id","12"),matriz("Nombre de usuario","xilou"),matriz("Sexo","1"))
'Devolver objeto de diccionario
Función AryToHashTable(aria)
Dim str,ht,i,k,v,pos
Establecer ht = Server.CreateObject("Scripting.Dictionary")
ht.CompareMode = 1
AryAddToHashTable ht, ary
Establecer AryToHashTable = ht
Función final
'Convertir matriz en cadena, lo que equivale a serializar una matriz. Los únicos formatos permitidos son:
'matriz("p1:v1","p2:v2",matriz("p3",verdadero))
'cadena de retorno
Función AryToVbsString(arr)
Dim str,i,c
Si no es IsArray(arr), entonces Response.Write "Error: error de AryToString(arr), el parámetro arr no es una matriz"
c = UBound(arr)
Para i = 0 A c
Si IsArray(arr(i)) Entonces
Seleccione Caso LCase(TypeName(arr(i)(1)))
Caso "fecha", "cadena", "vacío"
cadena = cadena & ",matriz(""" & arr(i)(0) & ""","""& arr(i)(1) &""")"
Caso "entero", "largo", "simple", "doble", "moneda", "decimal", "booleano"
cadena = cadena & ",matriz(""" & arr(i)(0) & ""","& arr(i)(1) &")"
Caso "nulo"
cadena = cadena & ",matriz(""" & arr(i)(0) & """,nulo)"
Caso más
Response.Write "Error: AryToVbsString(arr), el parámetro contiene datos ilegales, índice i="&i&", el valor clave es: "&arr(i)(0)
Respuesta.Fin()
Finalizar selección
Demás
cadena = cadena & ",""" & arreglo(i) & """"
Terminar si
Próximo
Si str <> "" Entonces str = Mid(str, 2, Len(str) - 1)
cadena = "matriz(" & cadena & ")"
AryToVbsString = cadena
Función final
'-------------------------------- Otras operaciones finalizan
%>