código do programa
<%
'******************************
'Nome da classe:
'Nome: biblioteca geral
'Data: 28/10/2008
'Autor: por xilou
'Site: http://www.chinacms.org
'Descrição: Biblioteca geral
'Direitos autorais: Por favor, indique a fonte e o autor ao reimprimir
'******************************
'Última modificação: 20090108
'Número de modificações: 2
'Descrição da modificação:
'20090108 Adicione as seguintes funções:
'A2U(),U2A(),UrlEncode(),UrlDecode(),GBToUTF8(),Bytes2Str(),Str2Bytes()
'20090108 Adicione as seguintes funções:
'AryToVbsString(arr)
'Versão atual:
'******************************/
'Saída
Subeco(str)
Resposta.Write str
Finalizar Sub
'Ponto de Interrupção
Subparada()
Resposta.End()
End Sub
'Saída e quebra
SubBr(str)
Echo str & "<br />" & vbcrlf
End Sub
'Simplificar Request.Form()
'f: nome do formulário
Função P(f)
P = Substituir(Request.Form(f), Chr(0), "")
End Function
'Recebe o formulário e substitui aspas simples
Função Pr(f)
Pr = Substituir(Request.Form(f), Chr(0), "")
Pr = Substituir(Pr, "'", "''")
Função final
'Simplificar Request.Querystring()
'f: nome do formulário
FunçãoG(f)
G = Substituir(Request.QueryString(f), Chr(0), "")
End Function
'Recebe parâmetros de URL e substitui aspas simples
FunçãoGr(f)
Gr = Substituir(Request.QueryString(f), Chr(0), "")
Gr = Substituir(Gr, "'", "''")
Função final
'//Construction()?:Operação ternária por xilou www.chinacms.org
'ifThen retorna s1 para verdadeiro e s2 para falso
Função IfThen(ifTrue, s1, s2)
Escurecer
Se for verdadeiro então
t = s1
Outro
t = s2
Terminar se
SeEntão = t
Função final
'Exibir sim e não em cores diferentes
Função IfThenFont(ifTrue, s1, s2)
Dimstr
Se for verdadeiro então
str = "<font color=""#006600"">" & s1 & "</font>"
Outro
str = "<font color=""#FF0000"">" & s2 & "</font>"
Terminar se
IfThenFont = str
End Function
'Criar objeto Dicionário
Função NewHashTable()
Definir NewHashTable = Server.CreateObj("Scripting.Dictionary")
NewHashTable.CompareMode = 1 'Os valores-chave não diferenciam maiúsculas de minúsculas
Função final
'Criar XmlHttp
Função NewXmlHttp()
Definir NewXmlHttp = Server.createobject("MSXML2.XMLHTTP")
Função final
'Criar XmlDom
Função NewXmlDom()
Função final
'Criar AdoStream
Função NewAdoStream()
Definir NewAdoStream = Server.CreateObject("Adodb.Stream")
End Function
'Cria um array unidimensional
'Retorna um array vazio de n elementos
'n: número de elementos
FunçãoNovoArray(n)
Dimário: ary = array()
ReDimário(n-1)
NovaArray = ary
Função final
'Construir Try..Catch
SubTentar()
Em caso de erro, retomar o próximo
End Sub
'Construir Try..Catch
'msg: A mensagem de erro lançada, se estiver vazia, Err.Description é lançada
Subcaptura (mensagem)
Escurecer HTML
html = "<ul><li>$1</li></ul>"
Se errar então
Se mensagem <> "" Então
echo Substituir(html, "$1", mensagem)
Parar
Outro
echo Substituir(html, "$1", Err.Descrição)
Parar
Terminar se
Err.Limpar
Resposta.End()
Terminar se
End Sub
'--------------------------------operação do array começa
'Determina se existe um determinado valor no array
Função InArray(arr,s)
Se não for IsArray (arr) então InArray = False: função de saída
Escureça eu
Para i = LBound(arr) Para UBound(arr)
Se s = arr (i) Então InArray = True: função de saída
Próximo
InArray = Falso
End Function
'Substitua os espaços reservados em str pelos valores do array ary.
'Retorna a string substituída
'str: A string a ser substituída, os espaços reservados são $0, $1, $2...
'ary: Array usado para substituição, cada valor corresponde a $0, $1, $2... no espaço reservado.
'Por exemplo: ReplaceByAry("$0-$1-$2 $3:$4:$5",Array(y,m,d,h,i,s))
Função SubstituirByAry(str,ary)
Dim i, j, L1, L2 : j = 0
Se IsArray(ário) Então
L1 = LLimite(ário) : L2 = ULimite(ário)
Para i = L1 para L2
str = Substituir(str, "$"&j, ary(i))
j = j+1
Próximo
Terminar se
SubstituirByAry = str
Função final
'-----------------------------operação de matriz termina
'------------ --- --------------- A operação de número aleatório começa
'Obter números aleatórios
sou um número aleatório
Função RndNumber(m,n)
Randomizar
RndNumber = Int((n - m + 1) * Rnd + m)
End Function
'Obtém uma string aleatória
'n: comprimento gerado
Função RndText(n)
Dim str1, str2, i, x, L
str1 = "NOPQRSTUVWXYZ012ABCDEFGHIJKLM3456abcdefghijklm789nopqrstuvwxyz"
L = Len(str1)
Randomizar
Para i = 1 Para n
x = Int((L - 1 + 1) * Volta + 1)
str2 = str2 e meio (str1,x,1)
Próximo
RndText = str2
End Function
'Gera m a n strings aleatórias a partir da string str
'Se str estiver vazio, uma string aleatória será gerada a partir de números e letras por padrão
'str: Para gerar uma string aleatória a partir desta string
'm,n: gera n a m bits
Função RndByText(str, m, n)
Dim i, k, str2, L, x
Se str = "" Então str = "NOPQRSTUVWXYZ012ABCDEFGHIJKLM3456abcdefghijklm789nopqrstuvwxyz"
L = Len(str)
Se n = m Então
k = n
Outro
Randomizar
k = Int((n - m + 1) * Rnd + m)
Terminar se
Randomizar
Para eu = 1 Para k
x = Int((L - 1 + 1) * Volta + 1)
str2 = str2 e meio (str, x, 1)
Próximo
RndByText = str2
End Function
'Data e hora formam números aleatórios
'Retorna a combinação numérica da hora atual
Função RndByDateTime()
Dim dt : dt = Agora()
RndByDateTime = Ano (dt) e mês (dt) e dia (dt) e hora (dt) e minuto (dt) e segundo (dt)
Função final
'----------------------------Operação de número aleatório termina
'--------------- ------ --------------------A operação de string começa
'Determina o número de vezes que uma string str2 aparece em outra string str1
'Retorna o número de vezes, se não, retorna 0
'str1: expressão de string que aceita pesquisa
'str2: Expressão de string a ser pesquisada
'start: A posição inicial a ser pesquisada. Se estiver vazio, significa começar em 1 por padrão.
Função InStrTimes(str1, str2, início)
Dim a, c
Se início = "" Então início = 1
c = 0
a = InStr(início, str1, str2)
Faça enquanto a> 0
c = c + 1
uma = InStr(a+1, str1, str2)
Laço
InStrTimes = c
End Function
'Concatenação de strings
'Sem retorno
'strResult: Caracteres salvos após conexão
'str: caractere a ser concatenado
'partição: símbolo de separação entre caracteres de conexão
Sub JoinStr(byref strResult,str,partição)
Se strResult <> "" Então
strResult = strResult & partição & str
Outro
strResultado = str
Terminar se
End Sub
'Calcula o comprimento em bytes da string, um caracter chinês = 2 bytes
FunçãoStrLen(str)
Se isNull(str) ou Str = "" Então
StrLen = 0
Função de saída
Terminar se
Escurecer WINNT_CHINESE
WINNT_CHINESE = (len("exemplo")=2)
Se WINNT_CHINESE então
Dim l,t,c
Escureça eu
eu = len(str)
t = eu
Para eu = 1 Para eu
c = asc(meio(str,i,1))
Se c<0 Então c = c + 65536
Se c>255 Então t = t + 1
Próximo
StrLen = t
Outro
StrLen = len(str)
Terminar se
Função final
'Interceptar string
'str: a string a ser interceptada
'strlen: o comprimento a ser interceptado
' addStr: Use isto se exceder o comprimento, como:...
Função CutStr(str, strlen, addStr)
Dim eu, eu, t, c
Se Is_Empty (str) Then CutStr = "": Função de saída
eu = len(str) : t = 0
Para eu = 1 Para eu
c = Abs(Asc(Médio(str,i,1)))
Se c > 255 Então
t=t+2
Outro
t=t+1
Terminar se
Se t > strlen Então
CutStr = esquerda(str, i) & addStr
Sair para
Outro
CortarStr = str
Terminar se
Próximo
End Function
'Converte largura total em meia largura
Função SBCcaseConvert(str)
Dim b, c, eu
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, S, Z"
b = divisão (b, "")
c = divisão (c, "")
Para i = 0 para Ubound (b)
Se instr(str,b(i)) > 0 Então
str = Substituir(str, b(i), c(i))
Terminar se
Próximo
SBCcaseConvert=str
End Function
'é equivalente a escape() em javascript
Função VbsEscape(str)
dimi,s,c,a
s = ""
Para i=1 para Len(str)
c = Médio(str,i,1)
a = ASCW(c)
Se (a>=48 e a<=57) ou (a>=65 e a<=90) ou (a>=97 e a<=122) Então
s = s&c
ElseIf InStr("@*_+-./",c) > 0 Então
s = s&c
ElseIf a>0 e a<16 Then
s = s & "%0" & hexadecimal (a)
ElseIf a>=16 e a<256 Then
s = s & "%" & hexadecimal (a)
Outro
s = s & "%u" & hexadecimal (a)
Terminar se
Próximo
VbsEscape=s
End Function
'Decodifica dados codificados usando escape() em javascript, usado ao chamar ajax
Função VbsUnEscape(str)
Escurecer x
x = InStr(str,"%")
Faça enquanto x > 0
VbsUnEscape = VbsUnEscape & Mid(str,1,x-1)
Se LCase(Mid(str,x+1,1)) = "u" Então
VbsUnEscape = VbsUnEscape & ChrW(CLng("&H"&Mid(str,x+2,4)))
str = Médio(str,x+6)
Outro
VbsUnEscape = VbsUnEscape & Chr(CLng("&H"&Mid(str,x+1,2)))
str = Médio(str,x+3)
Terminar se
x = InStr(str,"%")
Laço
VbsUnEscape = VbsUnEscape & str
Função final
'Converte caracteres ascii para formato de codificação unicode
Função A2U(str)
Dim i,L,uText
L = Len(str)
Para i = 1 para L
uText = uText & "&#" & AscW(Mid(str,i,1)) & ";"
Próximo
A2U = uTexto
End Function
'Converter codificação unicode para ascii
'str: A string a ser transcodificada deve ser toda de caracteres Unicode, caso contrário ocorrerá um erro
Função U2A(str)
Dimário,i,L,newStr
ary = Dividir(str,";")
L = UBound(ário)
Para eu = 0 Para L - 1
newStr = newStr & ChrW(Replace(ary(i),"&#",""))
Próximo
U2A = novoStr
Função final
'codificação de URL
Função UrlEncode(str)
UrlEncode = Servidor.UrlEncode(str)
End Function
'decodificação de URL
FunçãoUrlDecode(str)
Dim newstr, havechar, lastchar, i, char_c, next_1_c, next_1_Num
newstr = ""
havechar = falso
últimochar = ""
Para i = 1 para Len(str)
char_c = Médio(str,i,1)
Se char_c = "+" Então
newstr = newstr & " "
ElseIf char_c = "%" Então
next_1_c = Médio(str, i+1, 2)
next_1_num = Cint("&H" & next_1_c)
Se tiverchar então
havechar = falso
newstr = newstr & Chr(CInt("&H" & lastchar & next_1_c))
Outro
Se Abs(next_1_num) <= 127 Então
newstr = newstr & Chr(próximo_1_num)
Outro
havechar = verdadeiro
último caracter = próximo_1_c
Terminar se
Terminar se
eu = eu + 2
Outro
newstr = newstr & char_c
Terminar se
Próximo
UrlDecode = newstr
Função final
'GB para UTF8 - Converte texto codificado em GB em texto codificado em UTF8
Função GBToUTF8(gbStr)
Dim wch,uch,szRet,szInput
Escurecer x
Dim nAsc, nAsc2, nAsc3
szInput = gbStr
'Se o parâmetro de entrada estiver vazio, saia da função
Se szInput = "" Então
toUTF8 = szInput
Função de saída
Terminar se
'Iniciar conversão
Para x = 1 para Len(szInput)
'Use a função mid para dividir o texto codificado em GB
wch = Médio (szInput, x, 1)
'Use a função ascW para retornar o código de caracteres Unicode de cada texto codificado em GB
'Nota: a função asc retorna código de caracteres ANSI, preste atenção na diferença
nAsc = AscW(que)
Se nAsc <0 Então nAsc = nAsc + 65536
Se (nAsc E &HFF80) = 0 Então
szRet = szRet & qual
Outro
Se (nAsc e &HF000) = 0 Então
uch = "%" & Hex(((nAsc 2 ^ 6)) ou &HC0) & Hex(nAsc E &H3F ou &H80)
szRet = szRet&uch
Outro
'O código de caracteres Unicode do texto codificado em GB adota um modelo de três bytes entre 0800 - FFFF
uch = "%" & Hex((nAsc 2 ^ 12) ou &HE0) & "%" & _
Hex((nAsc 2 ^ 6) E &H3F ou &H80) & "%" & _
Hexadecimal (nAsc e &H3F ou &H80)
szRet = szRet&uch
Terminar se
Terminar se
Próximo
GBToUTF8 = szRet
Função final
'Conversão de fluxo de bytes para fluxo de caracteres
Função Bytes2Str(vin,conjunto de caracteres)
Dim ms,strRet
Set ms = Server.CreateObject("ADODB.Stream") 'Cria um objeto de fluxo
ms.Type = 1 'Binário
ms.Abrir
ms.Write vin 'Escreve vin no objeto stream
ms.Position = 0 'Defina a posição inicial do objeto de fluxo como 0 para definir a propriedade Charset
ms.Type = 2 'Texto
ms.Charset = charset 'Define o modo de codificação do objeto de fluxo para charset
strRet = ms.ReadText 'Obtém o fluxo de caracteres
ms.close 'Fecha o objeto stream
Defina ms = nada
Bytes2Str = strRet
Função final
'Conversão de fluxo de Char para fluxo de Byte
Função Str2Bytes(str,conjunto de caracteres)
Dim ms,strRet
Set ms = CreateObject("ADODB.Stream") 'Cria um objeto de fluxo
ms.Type = 2 'Texto
ms.Charset = charset 'Defina o modo de codificação do objeto de fluxo para charset
ms.Abrir
ms.WriteText str 'Escreve str no objeto de fluxo
ms.Position = 0 'Defina a posição inicial do objeto de fluxo como 0 para definir a propriedade Charset
ms.Type = 1 'Binary
vout = ms.Read(ms.Size) 'Obter fluxo de caracteres
ms.close 'Fecha o objeto stream
Defina ms = nada
Str2Bytes = vout
Função final
'--------------------------------A operação de string termina
'------------ -------- --------------------Hora e data de início da operação
'Obtém o número correspondente de dias no mês com base no ano e mês
'Retorna o número de dias
'y: ano, como: 2008
'm: mês, como: 3
Função GetDayCount(y,m)
Escurecer c
Selecione Caso m
Caso 1, 3, 5, 7, 8, 10, 12
c=31
Caso 2
Se IsDate(y&"-"&m&"-"&"29") Então
c=29
Outro
c=28
Terminar se
Outro caso
c=30
Finalizar seleção
GetDayCount = c
End Function
'Determina se uma data e hora está entre um determinado período de tempo, incluindo a hora em ambas as extremidades da comparação
Função IsBetweenTime(fromTime,toTime,strTime)
Se DateDiff("s",fromTime,strTime) >= 0 E DateDiff("s",toTime,strTime) <= 0 Então
IsBetweenTime = Verdadeiro
Outro
IsBetweenTime = Falso
Terminar se
Função final
'--------------------------------A operação de hora e data termina
'----------- ---------- --------------------As operações relacionadas à criptografia de segurança começam
'--------------------------------------------Operações relacionadas à criptografia de segurança terminam
'---------- ---- -----------------A operação de verificação da legalidade dos dados começa
'Detecta string através de expressão regular e retorna verdadeiro|falso
Função RegExpTest(strPatrn,strText)
Dim objRegExp, corresponde
Definir objRegExp = Novo RegExp
objRegExp.Pattern = strPatrn
objRegExp.IgnoreCase = Falso
objRegExp.Global = Verdadeiro
RegExpTest = objRegExp.Test(strText)
'Definir correspondências = objRegExp.Execute(strText)
Definir objRegExp = nada
End Function
'É um número inteiro positivo?
FunçãoIsPint(str)
IsPint = RegExpTest("^[1-9]{1}d*$", str)
End Function
'Se é 0 ou um número inteiro positivo
FunçãoIsInt(str)
IsInt = RegExpTest("^0|([1-9]{1}d*)$", str)
Função final
'E-mail
FunçãoIsEmail(str)
Padrão escuro
patrn = "^w+((-w+)|(.w+))*@[A-Za-z0-9]+((.|-)[A-Za-z0-9]+ )*.[A-Za-z0-9]+$"
IsEmail = RegExpTest(patrn,str)
Função final
'telefone celular
FunçãoIsMobile(str)
Padrão escuro
padrão = "^(130|131|132|133|153|134|135|136|137|138|139|158|159){1}d{8}$"
IsMobile = RegExpTest(patrn,str)
Função final
'QQ
FunçãoIsQQ(str)
Padrão escuro
padrão = "^[1-9]d{4,8}$"
IsQQ = RegExpTest(patrn,str)
Função final
'carteira de identidade
FunçãoIsIdCard(e)
Dim arrVerifyCode,Wi,Checker
arrVerifyCode = Split("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", ",")
Se Len(e) <15 ou Len(e) = 16 ou Len(e) = 17 ou Len(e) > 18 Então
IsIdCard = Falso
Função de saída
Terminar se
Dim A
Se Len(e) = 18 Então
Ai = Médio (e, 1, 17)
ElseIf Len(e) = 15 Então
Ai = e
Ai = Esquerda (Ai, 6) e "19" e Meio (Ai, 7, 9)
Terminar se
Se não for numérico (Ai), então
IsIdCard = Falso
Função de saída
Terminar se
Dim strYear, strMonth, strDay, BirthDay
strAno = CInt(Médio(Ai, 7, 4))
strMês = CInt(Médio(Ai, 11, 2))
strDia = CInt(Médio(Ai, 13, 2))
Aniversário = Trim(strAno) + "-" + Trim(strMês) + "-" + Trim(strDia)
Se forData(Aniversário) então
If DateDiff("yyyy",Now,BirthDay)<-140 ou cdate(BirthDay)>date() Then
IsIdCard = Falso
Função de saída
Terminar se
Se strMonth > 12 ou strDay > 31 Então
IsIdCard = Falso
Função de saída
Terminar se
Outro
IsIdCard = Falso
Função de saída
Terminar se
Dim i,TotalmulAiWi
Para i = 0 a 16
TotalmulAiWi = TotalmulAiWi + CInt(Mid(Ai, i + 1, 1)) * Wi(i)
Próximo
Dim modValue
modValue = TotalmulAiWi Mod 11
Dim strVerifyCode
strVerifyCode = arrVerifyCode(modValue)
Ai = Ai & strVerifyCode
IsIdCard = Ai
Se Len(e) = 18 E e <> Ai Então
IsIdCard = Falso
Função de saída
Terminar se
IsIdCard = Verdadeiro
Função final
'código postal
Função ÉZipCode(str)
Padrão escuro
padrão = "^[1-9]d{2,5}$"
IsZipCode = RegExpTest(patrn,str)
Função final
'Se está vazio, incluindo as funções de IsEmpty(), IsNull(), ""
Função Is_Empty(str)
Se IsNull(str) ou IsEmpty(str) ou str="" Então
Está_Vazio = Verdadeiro
Outro
Está_Vazio=Falso
Terminar se
Função final
'--------------------------------A operação de verificação de validade dos dados termina
'--------- -- ---------------------A operação do arquivo é iniciada
'Obtém o sufixo do arquivo, como jpg
Função GetFileExt(f)
GetFileExt = Lcase(Mid(f,InStrRev(f,".") + 1))
Função final
'Gerar pasta
'path: o caminho para a pasta a ser gerada, use um caminho relativo
SubCFpasta(caminho)
Escurecer fso
Definir fso = Server.CreateObject("Scripting.FileSystemObject")
Se não for fso.FolderExists(caminho) então
fso.CreateFolder(caminho)
Terminar se
Definir fso = Nada
End Sub
'Excluir pasta
'caminho: caminho da pasta, use caminho relativo
SubDpasta(caminho)
Escurecer fso
Definir fso = Server.CreateObject("Scripting.FileSystemObject")
Se fso.FolderExists(caminho) Então
caminho fso.DeleteFolder, verdadeiro
Outro
echo "Caminho não existe:" & caminho
Terminar se
Definir fso = Nada
End Sub
'Gerar arquivo
'path: Gera o caminho do arquivo, incluindo o nome
'strText: conteúdo do arquivo
Sub CFile(caminho,strText)
Dim f,fso
Definir fso = Server.CreateObject("Scripting.FileSystemObject")
Definir f = fso.CreateTextFile (caminho)
f.Escrever strText
Definir f = Nada
Definir fso = Nada
End Sub
'Excluir arquivo
'path: caminho do arquivo, incluindo nome
SubDFarquivo(caminho)
Escurecer fso
Definir fso = Server.CreateObject("Scripting.FileSystemObject")
Se fso.FileExists(caminho) Então
Fso.DeleteFile(caminho)
Terminar se
Definir fso = Nada
End Sub
'Coletar
Função GetHTTPPage(url)
'Http.setTimeouts 10000,10000,10000,10000
'Em caso de erro, retomar próximo
Dim HTTP
Definir Http = Server.createobject("MSXML2.XMLHTTP")
Http.open "GET",url,falso
http.send()
Se Http.Status <> 200 Então
Função de saída
Terminar se
'Se errar, então Response.Write url: Response.End()
GetHTTPPage = bytesToBSTR(Http.ResponseBody,"GB2312")
'Http.Fechar()
'se err.número<>0 então err.Clear
Função final
'Conversão de codificação
Função BytesToBstr(corpo,Cset)
DimStreamObj
Definir StreamObj = Server.CreateObject("Adodb.Stream")
StreamObj.Type = 1
StreamObj.Mode = 3
StreamObj.Open
Corpo StreamObj.Write
StreamObj.Position = 0
StreamObj.Type = 2
StreamObj.Charset = Cset
BytesToBstr = StreamObj.ReadText
StreamObj.Fechar
Função final
'--------------------------------A operação do arquivo termina
'------------ ------------------Outras operações começam
'Exibir informações
'mensagem: a mensagem a ser exibida
'url: URL para onde ir
'typeNum: modo de exibição, 1 exibe informações e retorna para a página anterior; 2 exibe informações e vai para a url;
Sub ShowMsg(mensagem,url,tipoNum)
mensagem = substituir(mensagem,"'","'")
Selecione o tipo de casoNum
Caso 1
echo ("<script language=javascript>alert('" & mensagem & "');history.go(-1)</script>")
Caso 2
echo ("<script language=javascript>alert('" & mensagem & "');location='" & Url &"'</script>")
Finalizar seleção
End Sub
'Exibir lista de opções e posição, por xilou www.chinacms.org
'textArr: matriz de texto
'valueArr: matriz de valores
'curValue: valor atualmente selecionado
Função ShowOpList(textArr, valueArr, curValue)
Dim str, estilo, eu
style = "style=""cor de fundo:#FFCCCC"""
str = ""
Se IsNull(curValue) Então curValue = ""
Para I = LBound(textArr) Para UBound(valueArr)
Se Cstr(valorArr(I)) = Cstr(curValue) Então
str = str&"<option value="""&valueArr(I)&""" selected=""selected"" "&style&" >"&textArr(I)&"</option>"&vbcrlf
Outro
str = str&"<option value="""&valueArr(I)&""" >"&textArr(I)&"</option>"&vbcrlf
Terminar se
Próximo
ShowOpList=str
End Function
'Lista de seleção múltipla
'Nota: Você precisa usar a função InArray()
'textArr: matriz de texto
'valueArr: matriz de valores
'curValue: array de valores atualmente selecionado
Função ShowMultiOpList(textArr,valueArr,curValueArr)
Estilo escuro, str, isCurr, I
style = "style=""cor de fundo:#FFCCCC"""
str = "": isCurr = False
Se IsNull(curValue) Então curValue = ""
Para I = LBound(textArr) Para UBound(valueArr)
Se InArray(curValueArr, valueArr(I)) Então
str = str&"<option value="""&valueArr(I)&""" selected=""selected"" "&style&" >"&textArr(I)&"</option>"&vbcrlf
Outro
str = str&"<option value="""&valueArr(I)&""" >"&textArr(I)&"</option>"&vbcrlf
Terminar se
Próximo
ShowMultiOpList=str
Função final
Função GetIP()
Dim strIPAddr,actforip
Se Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" ou InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Então
strIPAddr = Request.ServerVariables("REMOTE_ADDR")
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Então
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 Então
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)
Outro
strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
Terminar se
GetIP = strIPAddr
Função final
'Converte o array em armazenamento de objetos de dicionário
'hashObj: objeto de dicionário
'ary: Array, o formato deve ser um dos dois seguintes, o primeiro só pode armazenar valores de string
' : array("Id:12","UserName:xilou","Sex:1"), ou seja, formato array("key:value",...)
' : array(array("Id","12"),array("NomeUsuário","xilou"),array("Sexo","1"))
'Retorna objeto de dicionário
'www.chinacms.org
Sub AryAddToHashTable(ByRef hashObj,ary)
Dim str,ht,i,k,v,pos
Para i = 0 para UBound (ário)
Se IsArray(ary(i)) Então
Se IsObject(ary(i)(0)) Então
Response.Write "Erro: AryToHashTable (ary), o valor da chave não pode ser um tipo de objeto,"
Response.Write "O tipo de valor atual ary("& i &")(0) é:" & TypeName(ary(i)(0))
Resposta.End()
Terminar se
If IsObject(ary(i)(1)) Then 'Se o valor for um objeto
Definir hashObj(ary(i)(0)) = ary(i)(1)
Outro
hashObj(ário(i)(0)) = ary(i)(1)
Terminar se
Outro
str = ary(i) & ""
pos = InStr(str,":")
'www.chinacms.org
Se pos < 1 Então
Response.Write "Erro:AryToHashTable(ary),"":""Não existe"
Response.Write ",Ocorre em:" & ary(i)
Resposta.End()
Terminar se
Se pos = 1 Então
Response.Write "Erro: AryToHashTable (ary), o valor da chave não existe"
Response.Write ",Ocorre em:" & ary(i)
Resposta.End()
Terminar se
k = Esquerda(str,pos-1)
v = Meio(str,pos+1)
hashObj(k) = v
Terminar se
Próximo
End Sub
'Converta o array em armazenamento de objetos de dicionário
'ary: Array, o formato deve ser um dos dois seguintes, o primeiro só pode armazenar valores de string
' : array("Id:12","UserName:xilou","Sex:1"), ou seja, formato array("key:value",...)
' : array(array("Id","12"),array("NomeUsuário","xilou"),array("Sexo","1"))
'Retorna objeto de dicionário
Função AryToHashTable(ary)
Dim str,ht,i,k,v,pos
Definir ht = Server.CreateObject("Scripting.Dictionary")
ht.CompareMode = 1
AryAddToHashTable ht, ary
Definir AryToHashTable = ht
End Function
'Converte array em string, que é equivalente a serializar array. Os únicos formatos permitidos são:
'array("p1:v1","p2:v2",array("p3",verdadeiro))
'string de retorno
Função AryToVbsString(arr)
Dim str,i,c
If Not IsArray (arr) Then Response.Write "Erro: erro AryToString (arr), o parâmetro arr não é uma matriz"
c = UBound(arr)
Para eu = 0 Para c
Se IsArray(arr(i)) Então
Selecione Caso LCase(TypeName(arr(i)(1)))
Caso "data","string","vazio"
str = str & ",array(""" & arr(i)(0) & ""","""& arr(i)(1) &""")"
Caso "inteiro","longo","único","duplo","moeda","decimal","booleano"
str = str & ",array(""" & arr(i)(0) & ""","& arr(i)(1) &")"
Caso "nulo"
str = str & ",array(""" & arr(i)(0) & """,null)"
Outro caso
Response.Write "Erro: AryToVbsString(arr), o parâmetro contém dados ilegais, índice i="&i&", o valor da chave é: "&arr(i)(0)
Resposta.End()
Finalizar seleção
Outro
str = str & ",""" & arr(i) & """"
Terminar se
Próximo
Se str <> "" Então str = Mid(str, 2, Len(str) - 1)
str = "array("&str& ")"
AryToVbsString=str
Função final
'--------------------------------Outras operações terminam
%>