20/01/06, 05:41:21
|
#91 (permalink)
|
Registrado: nov 2002
Ubicación: Hangar 18
Mensajes: 1.189
|
Funcion para normalizar decimales
Haciendo una mantencion de un sistema de 1999, encontré esta funcion ... 
Código:
Function Recoge_Decimales(str)
On Error resume next
if CStr(1/10) = "0,1" then
Recoge_Decimales = CDbl(Replace(str, ".", ","))
exit function
end if
if CStr(1/10) = "0.1" then
Recoge_Decimales = CDbl(Replace(str, ",", "."))
exit function
end if
Recoge_Decimales = CDbl(str)
end function
__________________
On Error Resume Thinking
|
|
|
|
|
30/01/06, 12:47:07
|
#92 (permalink)
|
Registrado: ene 2006
Ubicación: Torroles (Costa der Só)
Mensajes: 917
|
Copiar una imagen desde una dirección web externa
Copia desde una dirección web cualquiera una imagen a nuestro servidor y luego nos devuelve el path de la imagen.
Código:
<%@ Language=VBScript %>
<% Option Explicit
'***********************************************
'* Copia una Imagen desde una direccion,
'* la graba en un directorio de nuestro equipo
'* y devuelve su direccion
'***********************************************
Function CopiaImagenDesde(URL)
On Error Resume Next
Err.Clear
'*
'* Toma la imagen
'*
Dim objXML
'Set objXML = Server.CreateObject("Msxml2.ServerXMLHTTP")
Set objXML = Server.CreateObject("Microsoft.XMLHTTP")
objXML.Open "GET",URL,False
objXML.Send
Dim binXML
binXML = objXML.ResponseBody
If Err.Number <> 0 Or objXML.Status <> 200 Then
CopiaImagenDesde = False
Exit Function
End If
Set objXML = Nothing
'*
'* Graba Imagen en images\ o en donde se quiera
'*
Dim strIMG
strIMG = "images\" & Mid(URL,InStrRev(URL,"/")+1)
Dim objADO
Set objADO = CreateObject("ADODB.Stream")
objADO.Type = 1
objADO.Open
objADO.Write binXML
objADO.SaveToFile Server.MapPath(strIMG),2
Set objADO = Nothing
CopiaImagenDesde = strIMG
End Function
%>
Y esta es su forma de utilizarlo
Código:
<html>
<body>
<img src="<%=CopiaImagenDesde("http://www.undominio.com/dir/imageness/archivo.gif")%>"
border="0" alt="">
</body>
</html>
Un saludo |
|
|
|
|
29/03/06, 07:50:59
|
#93 (permalink)
|
Registrado: nov 2002
Ubicación: Hangar 18
Mensajes: 1.189
|
Funcion super util 
Código HTML:
<%
REM INC_FUNCIONES_FORMATO.ASP
REM VERSION 1.0
REM 20030328
REM formatea(entrada,formato_esperado,valor_por_defecto,arreglo_de_parseos)
REM ENTRADA Contiene la variable a formatear
REM FORMATO_ESPERADO Indica el formato en el que deberia venir la variable
REM VALOR_POR_DEFECTO En caso de que la variable no cumpla el formato, asigna este valor
REM ARREGLO_DE_PARSEOS Contiene un string separado por comas que contiene las tranformaciones deseadas a una misma variable.
REM EJEMPLO DE EJECUCCION: FORMATEA("holas",3,false,"1,0,4,6,10,13")
REM FORMATO ESPERADO 1 NUMERICO
REM FORMATO ESPERADO 2 FECHA
REM FORMATO ESPERADO 3 CADENA
REM Parseo 0 FIX COMILLAS SIMPLES
REM Parseo 1 FIX TAG HTML
REM Parseo 2 FIX PUNTOS Y COMA EXEL
REM Parseo 3 FIX SQL INJECTION
REM Parseo 4 FIX BLANK SPACE / UNDERSCORE
REM Parseo 5 TRANSFORMACION CSNG
REM Parseo 6 TRANSFORMACION CINT
REM Parseo 7 TRANSFORMACION Cdate
REM Parseo 8 TRANSFORMACION trim
REM Parseo 9 TRANSFORMACION lcase
REM Parseo 10 TRANSFORMACION ucase
REM Parseo 11 TRANSFORMACION CSTR
REM Parseo 12 TRANSFORMACION CDBL
REM Parseo 13 ENCOMILLADO
REM Parseo 14 DESCOMILLADO
function checa_formato_xp(entrada,formato)
on error resume next
err.Clear ()
checa_formato_xp = false
Select Case formato
Case 1
if isnumeric(entrada) = true then
checa_formato_xp = true
end if
Case 2
if isdate(entrada) = true then
checa_formato_xp = true
end if
Case 3
if len(entrada) <> 0 then
checa_formato_xp = true
end if
Case Else
checa_formato_xp = true
End Select
if err.number <> 0 then
err.Clear ()
checa_formato_xp = false
end if
end function
function fix_multiple_xp(cadena,parseo)
on error resume next
err.Clear ()
dim aux
aux = cadena
Select Case parseo
Case 0 ' FIX COMILLAS SIMPLES
aux = replace(aux,"'","''")
Case 1 ' FIX TAG HTML
aux = replace(aux,"<","<")
aux = replace(aux,">",">")
Case 2 ' FIX PUNTOS Y COMA EXEL
aux = replace(aux,";","")
Case 3 ' FIX SQL INJECTION
aux = replace(aux,"--","")
aux = replace(aux,"'","")
aux = replace(aux,"=","")
aux = replace(aux,"&","")
Case 4 'FIX BLANK SPACE / UNDERSCORE
aux = replace(trim(aux)," ","_")
Case 5 'TRANSFORMACION CSNG
aux = csng(aux)
Case 6 'TRANSFORMACION CINT
aux = cint(aux)
Case 7 'TRANSFORMACION Cdate
aux = cdate(aux)
Case 8 'TRANSFORMACION trim
aux = trim(aux)
Case 9 'TRANSFORMACION lcase
aux = lcase(aux)
Case 10 'TRANSFORMACION ucase
aux = ucase(aux)
Case 11 'TRANSFORMACION CSTR
aux = cstr(aux)
Case 12 'TRANSFORMACION CDBL
aux = cdbl(aux)
Case 13 'ENCOMILLADO
aux = "'" & aux & "'"
Case 14 'DESCOMILLADO
aux = replace(aux,"'","")
Case Else
aux = aux
End Select
if err.number <> 0 then
err.Clear ()
fix_multiple_xp = cadena
else
fix_multiple_xp = aux
end if
end function
function formatea(entrada,formato_esperado,valor_por_defecto,arreglo_de_parseos)
on error resume next
dim salida
DIM arreglo
formatea = valor_por_defecto
salida = entrada
if checa_formato_xp(salida,formato_esperado) = false then
exit function
end if
if arreglo_de_parseos <> false then
arreglo = split(arreglo_de_parseos,",")
for y = 0 to ubound(arreglo)
salida = fix_multiple_xp(salida,cint(arreglo(y)))
next
end if
if err.number <> 0 then
err.Clear ()
exit function
else
formatea = salida
end if
end function
%>
__________________
On Error Resume Thinking
|
|
|
|
|
02/06/06, 15:42:14
|
#94 (permalink)
|
Registrado: nov 2004
Mensajes: 173
|
Funciones para calcular ancho y alto de una imagen.
Código:
Private Function GetImageWidth(byVal strPath)
dim myImg, fs
Set fs= CreateObject("Scripting.FileSystemObject")
if not fs.fileExists(strPath) then Exit Function
set myImg = loadpicture(strPath)
GetImageWidth = round(myImg.width / 26.4583)
set myImg = nothing
End Function
Private Function GetImageHeight(byVal strPath)
dim myImg, fs
Set fs= CreateObject("Scripting.FileSystemObject")
if not fs.fileExists(strPath) then Exit Function
set myImg = loadpicture(strPath)
GetImageHeight = round(myImg.height / 26.4583)
set myImg = nothing
End Function
|
|
|
|
|
29/06/06, 06:55:44
|
#95 (permalink)
|
Registrado: sep 2004
Mensajes: 2.095
|
MD5 1ª parte
Pasar cadena por Md5.
Código:
'HASH MD5
Private Const S11 = &H007
Private Const S12 = &H00C
Private Const S13 = &H011
Private Const S14 = &H016
Private Const S21 = &H005
Private Const S22 = &H009
Private Const S23 = &H00E
Private Const S24 = &H014
Private Const S31 = &H004
Private Const S32 = &H00B
Private Const S33 = &H010
Private Const S34 = &H017
Private Const S41 = &H006
Private Const S42 = &H00A
Private Const S43 = &H00F
Private Const S44 = &H015
Class MD5
' Public methods and properties
' Text property
Public Text
' Text value in Hex, read-only
Public Property Get HEXMD5()
Dim lArray
Dim lIndex
Dim AA
Dim BB
Dim CC
Dim DD
Dim lStatus0
Dim lStatus1
Dim lStatus2
Dim lStatus3
lArray = ConvertToWordArray(Text)
lStatus0 = &H67452301
lStatus1 = &HEFCDAB89
lStatus2 = &H98BADCFE
lStatus3 = &H10325476
For lIndex = 0 To UBound(lArray) Step 16
AA = lStatus0
BB = lStatus1
CC = lStatus2
DD = lStatus3
FF lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 0), S11,&HD76AA478
FF lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 1), S12,&HE8C7B756
FF lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 2), S13,&H242070DB
FF lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 3), S14,&HC1BDCEEE
FF lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 4), S11,&HF57C0FAF
FF lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 5), S12,&H4787C62A
FF lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 6), S13,&HA8304613
FF lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 7), S14,&HFD469501
FF lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 8), S11,&H698098D8
FF lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 9), S12,&H8B44F7AF
FF lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 10), S13,&HFFFF5BB1
FF lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 11), S14,&H895CD7BE
FF lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 12), S11,&H6B901122
FF lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 13), S12,&HFD987193
FF lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 14), S13,&HA679438E
FF lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 15), S14,&H49B40821
GG lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 1), S21,&HF61E2562
GG lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 6), S22,&HC040B340
GG lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 11), S23,&H265E5A51
GG lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 0), S24,&HE9B6C7AA
GG lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 5), S21,&HD62F105D
GG lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 10), S22,&H2441453
GG lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 15), S23,&HD8A1E681
GG lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 4), S24,&HE7D3FBC8
GG lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 9), S21,&H21E1CDE6
GG lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 14), S22,&HC33707D6
GG lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 3), S23,&HF4D50D87
GG lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 8), S24,&H455A14ED
GG lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 13), S21,&HA9E3E905
GG lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 2), S22,&HFCEFA3F8
GG lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 7), S23,&H676F02D9
GG lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 12), S24,&H8D2A4C8A
HH lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 5), S31,&HFFFA3942
HH lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 8), S32,&H8771F681
HH lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 11), S33,&H6D9D6122
HH lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 14), S34,&HFDE5380C
HH lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 1), S31,&HA4BEEA44
HH lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 4), S32,&H4BDECFA9
HH lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 7), S33,&HF6BB4B60
HH lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 10), S34,&HBEBFBC70
HH lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 13), S31,&H289B7EC6
HH lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 0), S32,&HEAA127FA
HH lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 3), S33,&HD4EF3085
HH lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 6), S34,&H4881D05
HH lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 9), S31,&HD9D4D039
HH lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 12), S32,&HE6DB99E5
HH lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 15), S33,&H1FA27CF8
HH lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 2), S34,&HC4AC5665
II lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 0), S41,&HF4292244
II lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 7), S42,&H432AFF97
II lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 14), S43,&HAB9423A7
II lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 5), S44,&HFC93A039
II lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 12), S41,&H655B59C3
II lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 3), S42,&H8F0CCC92
II lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 10), S43,&HFFEFF47D
II lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 1), S44,&H85845DD1
II lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 8), S41,&H6FA87E4F
II lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 15), S42,&HFE2CE6E0
II lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 6), S43,&HA3014314
II lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 13), S44,&H4E0811A1
II lStatus0,lStatus1,lStatus2,lStatus3,lArray(lIndex + 4), S41,&HF7537E82
II lStatus3,lStatus0,lStatus1,lStatus2,lArray(lIndex + 11), S42,&HBD3AF235
II lStatus2,lStatus3,lStatus0,lStatus1,lArray(lIndex + 2), S43,&H2AD7D2BB
II lStatus1,lStatus2,lStatus3,lStatus0,lArray(lIndex + 9), S44,&HEB86D391
lStatus0 = Add32(lStatus0,AA)
lStatus1 = Add32(lStatus1,BB)
lStatus2 = Add32(lStatus2,CC)
lStatus3 = Add32(lStatus3,DD)
Next
HEXMD5 = LCase(WordToHex(lStatus0) & WordToHex(lStatus1) & WordToHex(lStatus2) & WordToHex(lStatus3))
End Property
|
|
|
|
|
29/06/06, 07:00:06
|
#96 (permalink)
|
Registrado: sep 2004
Mensajes: 2.095
|
MD5 (y 2)
Código:
' Private methods and properties
Private m_lMask()
Private m_lPow()
Private Function F(lX, lY, lZ)
F = (lX And lY) Or ((Not lX) And lZ)
End Function
Private Function G(lX, lY, lZ)
G = (lX And lZ) Or (lY And (Not lZ))
End Function
Private Function H(lX, lY, lZ)
H = lX Xor lY Xor lZ
End Function
Private Function I(lX, lY, lZ)
I = lY Xor (lX Or (Not lZ))
End Function
Private Sub FF(lA, lB, lC, lD, lX, lS, lAC)
lA = Add32(lA,Add32(Add32(F(lB,lC,lD),lX),lAC))
lA = RotateLeft32(lA,lS)
lA = Add32(lA,lB)
End Sub
Private Sub GG(lA, lB, lC, lD, lX, lS, lAC)
lA = Add32(lA,Add32(Add32(G(lB,lC,lD),lX),lAC))
lA = RotateLeft32(lA,lS)
lA = Add32(lA,lB)
End Sub
Private Sub HH(lA, lB, lC, lD, lX, lS, lAC)
lA = Add32(lA,Add32(Add32(H(lB,lC,lD),lX),lAC))
lA = RotateLeft32(lA,lS)
lA = Add32(lA,lB)
End Sub
Private Sub II(lA, lB, lC, lD, lX, lS, lAC)
lA = Add32(lA,Add32(Add32(I(lB,lC,lD),lX),lAC))
lA = RotateLeft32(lA,lS)
lA = Add32(lA,lB)
End Sub
Private Function ConvertToWordArray(sText)
Dim lTextLength
Dim lNumberOfWords
Dim lWordArray()
Dim lBytePosition
Dim lByteCount
Dim lWordCount
lTextLength = Len(sText)
lNumberOfWords = (((lTextLength + 8) \ 64) + 1) * 16
ReDim lWordArray(lNumberOfWords - 1)
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lTextLength
lWordCount = lByteCount \ 4
lBytePosition = (lByteCount Mod 4) * 8
lWordArray(lWordCount) = lWordArray(lWordCount) Or ShiftLeft(Asc(Mid(sText,lByteCount + 1,1)),lBytePosition)
lByteCount = lByteCount + 1
Loop
lWordCount = lByteCount \ 4
lBytePosition = (lByteCount Mod 4) * 8
lWordArray(lWordCount) = lWordArray(lWordCount) Or ShiftLeft(&H80,lBytePosition)
lWordArray(lNumberOfWords - 2) = ShiftLeft(lTextLength,3)
lWordArray(lNumberOfWords - 1) = ShiftRight(lTextLength,29)
ConvertToWordArray = lWordArray
End Function
Private Function WordToHex(lValue)
Dim lTemp
For lTemp = 0 To 3
WordToHex = WordToHex & Right("00" & Hex(ShiftRight(lValue,lTemp * 8) And m_lMask(7)),2)
Next
End Function
' Unsigned value arithmetic functions for rotating, shifting and adding
Private Function ShiftLeft(lValue,iBits)
' Guilty until proven innocent
ShiftLeft = 0
If iBits = 0 then
ShiftLeft = lValue ' No shifting to do
ElseIf iBits = 31 Then ' Quickly shift left if there is a value, being aware of the sign
If lValue And 1 Then
ShiftLeft = &H80000000
End If
Else ' Shift left x bits, being careful with the sign
If (lValue And m_lPow(31 - iBits)) Then
ShiftLeft = ((lValue And m_lMask(31 - (iBits + 1))) * m_lPow(iBits)) Or &H80000000
Else
ShiftLeft = ((lValue And m_lMask(31 - iBits)) * m_lPow(iBits))
End If
End If
End Function
Private Function ShiftRight(lValue,iBits)
' Guilty until proven innocent
ShiftRight = 0
If iBits = 0 then
ShiftRight = lValue ' No shifting to do
ElseIf iBits = 31 Then ' Quickly shift to the right if there is a value in the sign
If lValue And &H80000000 Then
ShiftRight = 1
End If
Else
ShiftRight = (lValue And &H7FFFFFFE) \ m_lPow(iBits)
If (lValue And &H80000000) Then
ShiftRight = (ShiftRight Or (&H40000000 \ m_lPow(iBits - 1)))
End If
End If
End Function
Private Function RotateLeft32(lValue,iBits)
RotateLeft32 = ShiftLeft(lValue,iBits) Or ShiftRight(lValue,(32 - iBits))
End Function
Private Function Add32(lA,lB)
Dim lA4
Dim lB4
Dim lA8
Dim lB8
Dim lA32
Dim lB32
Dim lA31
Dim lB31
Dim lTemp
lA32 = lA And &H80000000
lB32 = lB And &H80000000
lA31 = lA And &H40000000
lB31 = lB And &H40000000
lTemp = (lA And &H3FFFFFFF) + (lB And &H3FFFFFFF)
If lA31 And lB31 Then
lTemp = lTemp Xor &H80000000 Xor lA32 Xor lB32
ElseIf lA31 Or lB31 Then
If lTemp And &H40000000 Then
lTemp = lTemp Xor &HC0000000 Xor lA32 Xor lB32
Else
lTemp = lTemp Xor &H40000000 Xor lA32 Xor lB32
End If
Else
lTemp = lTemp Xor lA32 Xor lB32
End If
Add32 = lTemp
End Function
' Class initialization
Private Sub Class_Initialize()
Text = ""
Redim m_lMask(30)
Redim m_lPow(30)
' Make arrays of these values to save some time during the calculation
m_lMask(0) = CLng(&H00000001&)
m_lMask(1) = CLng(&H00000003&)
m_lMask(2) = CLng(&H00000007&)
m_lMask(3) = CLng(&H0000000F&)
m_lMask(4) = CLng(&H0000001F&)
m_lMask(5) = CLng(&H0000003F&)
m_lMask(6) = CLng(&H0000007F&)
m_lMask(7) = CLng(&H000000FF&)
m_lMask(8) = CLng(&H000001FF&)
m_lMask(9) = CLng(&H000003FF&)
m_lMask(10) = CLng(&H000007FF&)
m_lMask(11) = CLng(&H00000FFF&)
m_lMask(12) = CLng(&H00001FFF&)
m_lMask(13) = CLng(&H00003FFF&)
m_lMask(14) = CLng(&H00007FFF&)
m_lMask(15) = CLng(&H0000FFFF&)
m_lMask(16) = CLng(&H0001FFFF&)
m_lMask(17) = CLng(&H0003FFFF&)
m_lMask(18) = CLng(&H0007FFFF&)
m_lMask(19) = CLng(&H000FFFFF&)
m_lMask(20) = CLng(&H001FFFFF&)
m_lMask(21) = CLng(&H003FFFFF&)
m_lMask(22) = CLng(&H007FFFFF&)
m_lMask(23) = CLng(&H00FFFFFF&)
m_lMask(24) = CLng(&H01FFFFFF&)
m_lMask(25) = CLng(&H03FFFFFF&)
m_lMask(26) = CLng(&H07FFFFFF&)
m_lMask(27) = CLng(&H0FFFFFFF&)
m_lMask(28) = CLng(&H1FFFFFFF&)
m_lMask(29) = CLng(&H3FFFFFFF&)
m_lMask(30) = CLng(&H7FFFFFFF&)
' Power operations always take time to calculate
m_lPow(0) = CLng(&H00000001&)
m_lPow(1) = CLng(&H00000002&)
m_lPow(2) = CLng(&H00000004&)
m_lPow(3) = CLng(&H00000008&)
m_lPow(4) = CLng(&H00000010&)
m_lPow(5) = CLng(&H00000020&)
m_lPow(6) = CLng(&H00000040&)
m_lPow(7) = CLng(&H00000080&)
m_lPow(8) = CLng(&H00000100&)
m_lPow(9) = CLng(&H00000200&)
m_lPow(10) = CLng(&H00000400&)
m_lPow(11) = CLng(&H00000800&)
m_lPow(12) = CLng(&H00001000&)
m_lPow(13) = CLng(&H00002000&)
m_lPow(14) = CLng(&H00004000&)
m_lPow(15) = CLng(&H00008000&)
m_lPow(16) = CLng(&H00010000&)
m_lPow(17) = CLng(&H00020000&)
m_lPow(18) = CLng(&H00040000&)
m_lPow(19) = CLng(&H00080000&)
m_lPow(20) = CLng(&H00100000&)
m_lPow(21) = CLng(&H00200000&)
m_lPow(22) = CLng(&H00400000&)
m_lPow(23) = CLng(&H00800000&)
m_lPow(24) = CLng(&H01000000&)
m_lPow(25) = CLng(&H02000000&)
m_lPow(26) = CLng(&H04000000&)
m_lPow(27) = CLng(&H08000000&)
m_lPow(28) = CLng(&H10000000&)
m_lPow(29) = CLng(&H20000000&)
m_lPow(30) = CLng(&H40000000&)
End Sub
End Class
Y para llamarlo
Código:
cadena="cadena a pasar"
Dim objMD5
Set objMD5 = New MD5
objMD5.Text = cadena
response.write objMD5.HEXMD5
|
|
|
|
|
27/08/06, 13:12:59
|
#97 (permalink)
|
Registrado: may 2003
Ubicación: Panamá
Mensajes: 1.144
|
Arbol de elementos
Hola... esta función es para generar un árbol de elementos, ideal para la creación de menú con opciones infinitas. Espero les sirva.
pd. Este script es original de mi amigo Vaalegk (gracias  )
Utilizacion:
call CrearArbol(0, "|","")
Resultado:
|categoria1
||categoira2
|categoria3
||categoria4
|||categoria5
Código:
function CrearArbol(byVal ParentId, byVal Prefijo, byVal Current)
sSQL = "select * from tabña where parentid=" & ParentId
set RS = Master.Execute(sSQL)
if RS.bof=false and RS.eof=false then
while not RS.eof
tmp_id = RS("codigo")
nombre_menu = ucase(RS("nombre"))
cadena = vbtab & vbtab & Current & nombre_menu & vbcrlf
response.Write(cadena)
call CrearArbol(tmp_id, Prefijo, Current & Prefijo)
RS.movenext
wend
end if
end function
call CrearArbol(0, "|","")
saludos
__________________
Saruman
One Ring to rule them all, One Ring to find them, One Ring to bring them all and in the darkness bind them.
|
|
|
|
|
19/10/06, 08:39:33
|
#98 (permalink)
|
Registrado: jun 2005
Mensajes: 307
|
Redireccionar a un frame
para redireccionar a un frame
ventana principal
Código:
Response.Write("<script>window.open('index.asp','_top');<" & chr(47) & "script>")
a un frame en especial
Código:
Response.Write("<script>window.open('index.asp','miframe');<" & chr(47) & "script>")
__________________
Sigue al indio desnudo... Pero con precaución, atendiendo las señales de transito y comentando todo lo que haces.
REM Hay que encontrar el camino de regreso y no siempre es facil....
|
|
|
|
|
14/02/07, 10:12:33
|
#99 (permalink)
|
Registrado: nov 2002
Ubicación: Hangar 18
Mensajes: 1.189
|
Re: Biblioteca de Clases,Funciones y Sub-rutinas.
MONTON DE FUNCIONES!
Código PHP:
<%
REM INC_FUNCIONES_BASICAS.ASP
REM VERSION 1.1
REM 20051212
REM 20061017
REM escribe(str)
REM imprime(str)
REM mensaje(txt)
REM imprime_xml(xml_str)
REM termina()
REM cierra_y_recarga()
REM cierra_ventana()
REM redirecciona(url,target)
REM imprime_variables_del_form()
REM Imprime_Variables_servidor()
REM impide_almacenamiento_en_cache()
REM abre_xhtml(titulo,estilo)
REM cierra_xhtml()
REM configuracion_regional(region)
REM checa_error()
REM ruta_fisica_actual()
REM nombre_archivo_actual()
REM hola()
REM fuerza_dos_digitos(numero)
sub escribe(str)
response.write str & chr(10)
end sub
sub imprime(str)
escribe str & "<br>"
end sub
sub mensaje(txt)
dim aux
aux = txt
aux = replace(aux,"'","")
aux = replace(aux,"""","")
escribe "<script>"
escribe "alert(""" & aux & """)"
escribe "</script>"
end sub
sub imprime_xml(xml_str)
imprime "<textarea rows=""7"" name=""test"" cols=""70"">"& xml_str &"</textarea>"
end sub
sub termina()
response.end
end sub
sub cierra_y_recarga()
escribe "<script>" & chr(10)
escribe "window.opener.location.reload();"
escribe "window.close();"
escribe "</script>" & chr(10)
end sub
sub cierra_ventana()
escribe "<script>" & chr(10)
escribe "window.close();"
escribe "</script>" & chr(10)
end sub
sub redirecciona(url,target)
escribe "<script>"
escribe "window.open("""& url &""", """& target &""");"
escribe "</script>"
end sub
sub imprime_variables_del_form()
for each x in Request.Form
imprime "<strong>" & x & "</strong> = " & Request.Form(x)
Next
end sub
Sub Imprime_Variables_servidor()
escribe "<TABLE border=""1""><TR><TD><B>Nombre Varaible de servidor</B></TD><TD><B>Valor</B></TD></TR>"
For Each name In Request.ServerVariables
escribe "<TR><TD>" & name & "</TD><TD>" & Request.ServerVariables(name) & "</TD></TR>"
Next
escribe "</TABLE>"
end sub
sub impide_almacenamiento_en_cache()
response.buffer = true
response.expires = 0
response.expiresabsolute = now() - 1
response.addheader "pragma","no-cache"
response.addheader "cache-control","private"
response.cachecontrol = "no-cache"
end sub
sub abre_xhtml(titulo,estilo)
escribe "<meta http-equiv=""Content-Type"" content=""text/html; charset=ISO-8859-1"" />"
escribe "<html>"
escribe "<title>"& titulo &"</title>"
escribe "<link href="""& estilo &""" type=""text/css"" rel=""stylesheet"">"
escribe "<body leftmargin=""0"" rightmargin=""0"" topmargin=""0"" marginheight=""0"" marginwidth=""0"" onload=""window.defaultStatus='MP-NETWORK'"">"
end sub
sub cierra_xhtml()
escribe "</body>"
escribe "</html>"
end sub
Sub configuracion_regional(region)
Select Case region
Case 0
execute("session.lcid=1034") 'CL
Case 1
execute("session.lcid=1033") 'US
Case Else
execute("session.lcid=1034") CL
End Select
end Sub
sub checa_error()
if err.number <> 0 then
call mensaje("Error en tiempo de ejecucion")
call imprime("<b>Codigo Error: </b>" & err.number)
call imprime("<b>Glosa Error: </b>" & err.description)
termina
end if
end sub
function ruta_fisica_actual()
dim aux
dim arreglo
dim nombre_pagina
dim ruta_fisica
aux = Request.ServerVariables("PATH_TRANSLATED")
arreglo = split(aux,"\")
nombre_pagina = arreglo(ubound(arreglo))
ruta_fisica = replace(aux,nombre_pagina,"")
ruta_fisica_actual = ruta_fisica
end function
function nombre_archivo_actual()
dim aux
dim arreglo
dim nombre_pagina
aux = Request.ServerVariables("PATH_TRANSLATED")
arreglo = split(aux,"")
nombre_pagina = arreglo(ubound(arreglo))
nombre_archivo_actual = nombre_pagina
end function
sub hola()
call imprime("hola mundo!")
call termina
end sub
function fuerza_dos_digitos(numero)
aux = "00000" & cstr(numero)
aux = right(aux,2)
fuerza_dos_digitos = aux
end function
%>
FELIZ DIA DEL 
__________________
On Error Resume Thinking
|
|
|
|
|
15/06/07, 15:12:10
|
#100 (permalink)
|
|
Colaborador
Registrado: feb 2007
Ubicación: Localhost/Pruebas....
Mensajes: 1.916
|
Re: Biblioteca de Clases,Funciones y Sub-rutinas.
Amigos, encontre esta funcion(realmente no se donde  ), pero creo que aki deberia estar
Funcion para reparar/compactar una base de datos
El codigo:
Código PHP:
Private Sub dbCompact(StrBaseDeDatos)
Const DriverConexion = "Provider=Microsoft.Jet.OLEDB.4.0; Data source="
Dim strDatabase, strFolder, strFileName
'en caso de que requieras cambiar el PATH a la base de datos,
'modifica esta linea
StrCarpeta = server.mappath("./")
if right(StrCarpeta,1) <> "\" then StrCarpeta = StrCarpeta & ""
Dim SourceConn, DestConn, oJetEngine, oFSO
SourceConn = DriverConexion & StrCarpeta & StrBaseDeDatos
DestConn = DriverConexion & StrCarpeta & "Temp" & StrBaseDeDatos
Set oFSO = Server.CreateObject("Scripting.FileSystemObject")
Set oJetEngine = Server.CreateObject("JRO.JetEngine")
If Not oFSO.FileExists(StrCarpeta & StrBaseDeDatos) Then
Response.Write ("Base no encontrada: " & StrCarpeta & StrBaseDeDatos)
else
If oFSO.FileExists(StrCarpeta & "Temp" & StrBaseDeDatos) Then
Response.Write ("Error. Intente Nuevamente.")
oFSO.DeleteFile (StrCarpeta & "Temp" & StrBaseDeDatos)
else
oJetEngine.CompactDatabase SourceConn, DestConn
oFSO.DeleteFile StrCarpeta & StrBaseDeDatos
oFSO.MoveFile StrCarpeta & "Temp"& StrBaseDeDatos, StrCarpeta& StrBaseDeDatos
Response.Write ("* La base de datos <B'>" & Request.form("DBFileName") & "</B'> fue compactada con exito.")
End If
End If
Set oFSO = Nothing
Set oJetEngine = Nothing
End Sub
la forma de llamado sera la siguiente
Código PHP:
dbCompact(nombre)
logicamente donde Nombre, se nuestra base de datos
suerte
__________________
"Eres parte del problema, parte de la solucion o parte del paisaje"
Un Saludo desde Desierto de Altar, Sonora, MX.
Shiryu_libra
|
|
|
|
|
25/08/07, 03:50:08
|
#101 (permalink)
|
Registrado: may 2005
Mensajes: 33
|
Tuve que hacer esto cuando al extraer los mensajes nuevos de un foro para hacer un "boletín" me encontré con que varios de ellos traían su "musiquilla de fondo". Cuando se ponían a sonar todos al tiempo... .
Con pequeñas modificaciones puede servir para quitar cualquier otra cosa.
Código:
Function QuitaRuidos(Mensaje)
Dim m1, m2, r1, r2
r1 = Instr(Mensaje, "<BGSOUND")
If r1 = 0 then
QuitaRuidos = Mensaje
else
m1 = Mid(Mensaje, 1, r1-1)
m2 = Mid(Mensaje, r1)
r2 = Instr(m2, ">")
m2 = Mid(m2, r2+1)
QuitaRuidos = m1 & m2
end if
End Function
Modo de empleo...
Código:
Response.Write(QuitaRuidos(MensajeRuidoso))
...o similar. |
|
|
|
|
26/09/07, 05:37:39
|
#102 (permalink)
|
Registrado: ene 2006
Ubicación: Torroles (Costa der Só)
Mensajes: 917
|
Hacer un captcher en ASP
Lo primero es hacer unas imágenes del 0 al 9 y llamarlas de forma extraña (o sea, nada de 1.gif ni uno.gif, hjree.gif es una buena solución )
Luego, en el archivo donde queremos verlo:
Código:
<form action="getData.asp">
<%
Dim des, num_captcher, arr_captcher(9)
' Yo les he puesto estos nombres :D
arr_captcher(0) = "mk_cer.gif"
arr_captcher(1) = "mk_un.gif"
arr_captcher(2) = "mk_do.gif"
arr_captcher(3) = "mk_tre.gif"
arr_captcher(4) = "mk_cua.gif"
arr_captcher(5) = "mk_cin.gif"
arr_captcher(6) = "mk_se.gif"
arr_captcher(7) = "mk_sie.gif"
arr_captcher(8) = "mk_och.gif"
arr_captcher(9) = "mk_nue.gif"
randomize()
' Esto para sacar numeros entre 10000 y 99999
num_captcher = Cstr(Int((99999 - 10000 + 1) * Rnd + 10000))
for des = 1 to len(num_captcher)
if isNumeric(mid(num_captcher,des,1)) then
response.Write("<img src='images/" & arr_captcher(mid(num_captcher,des,1)) & "' />")
end if
next
session("captcher") = num_captcher
%>
<input type="text" name="captcher" />
</form>
En la página getData.asp, solo tendremos que comprobar si todo es ok
Código:
if request.form("captcher") = session("captcher") then
' Todo OK
else
' Marditos robots!! XD
end if
Un saludo
__________________
"Tus pecados son el estiércol sobre el que florecerán las flores de tus virtudes" - Gerald Messadié -
|
|
|
|
|
02/03/08, 02:14:46
|
#103 (permalink)
|
Registrado: ene 2006
Ubicación: Chile
Mensajes: 178
|
Funcion Redireccionar
Esta funcion me ayudo a solucionar un error de carga de encabezados que se me producia con response.redirect
FUNCION SALVADORA:
<%Function redirecciona(url_redireccion)
err.clear
%>
<script LANGUAGE="JavaScript">
var pagina="<%=url_redireccion%>"
function redireccionar(){
location.href=pagina
}
document.write("<br><br><br><br><br><center><font size=1 face=tahoma><b>Cargando Página</b></font><br><img src='<%=ruteador(1)%>programa/img/cargando.gif' width='200' height='20'></center>")
setTimeout ("redireccionar()", 100);
</script>
<%
End Function
%>
es sensillo es un javascripts que se llama con un delay
setTimeout ("redireccionar()", 100);
y redirecciona a la pagina que necesitas bueno bonito y barato.
espero que les sirva como le sirve todavia a mi.
__________________
Atte, :arriba:
A n g e l u s
Concepción - Chile
no hay preguntas tontas, solo respuestas inteligentes.
|
|
|
|
|
