Foros del Web » Programando para Internet » ASP Clásico »

Biblioteca de Clases,Funciones y Sub-rutinas.

 Estas en el tema de Biblioteca de Clases,Funciones y Sub-rutinas. en el foro de ASP Clásico en Foros del Web. 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 ...
Página 4 de 5 123 4 5

  #91 (permalink)  
Antiguo 20/01/2006, 06:41
Avatar de Muzztein  
Fecha de Ingreso: agosto-2002
Ubicación: Hangar 18
Mensajes: 1.703
Antigüedad: 22 años, 2 meses
Puntos: 16
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
  #92 (permalink)  
Antiguo 30/01/2006, 13:47
 
Fecha de Ingreso: enero-2006
Ubicación: Torroles (Costa der Só)
Mensajes: 1.017
Antigüedad: 18 años, 10 meses
Puntos: 7
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
  #93 (permalink)  
Antiguo 29/03/2006, 08:50
Avatar de Muzztein  
Fecha de Ingreso: agosto-2002
Ubicación: Hangar 18
Mensajes: 1.703
Antigüedad: 22 años, 2 meses
Puntos: 16
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,"<","&lt;")
			aux = replace(aux,">","&gt;")
	    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
%>
  #94 (permalink)  
Antiguo 02/06/2006, 15:42
Avatar de cokete  
Fecha de Ingreso: noviembre-2004
Mensajes: 224
Antigüedad: 20 años
Puntos: 0
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
  #95 (permalink)  
Antiguo 29/06/2006, 06:55
Avatar de trasgukabi  
Fecha de Ingreso: septiembre-2004
Mensajes: 2.749
Antigüedad: 20 años, 2 meses
Puntos: 18
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
  #96 (permalink)  
Antiguo 29/06/2006, 07:00
Avatar de trasgukabi  
Fecha de Ingreso: septiembre-2004
Mensajes: 2.749
Antigüedad: 20 años, 2 meses
Puntos: 18
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
  #97 (permalink)  
Antiguo 27/08/2006, 13:12
Avatar de Saruman  
Fecha de Ingreso: mayo-2003
Ubicación: Panama city, Panama, Panama
Mensajes: 1.154
Antigüedad: 21 años, 5 meses
Puntos: 5
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.
  #98 (permalink)  
Antiguo 19/10/2006, 08:39
Avatar de biffly  
Fecha de Ingreso: junio-2005
Mensajes: 315
Antigüedad: 19 años, 5 meses
Puntos: 0
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....
  #99 (permalink)  
Antiguo 14/02/2007, 11:12
Avatar de Muzztein  
Fecha de Ingreso: agosto-2002
Ubicación: Hangar 18
Mensajes: 1.703
Antigüedad: 22 años, 2 meses
Puntos: 16
Exclamación 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



  #100 (permalink)  
Antiguo 15/06/2007, 15:12
Avatar de Shiryu_Libra
Colaborador
  
Fecha de Ingreso: febrero-2007
Ubicación: Cantando "Screenager" en "Kirafa Kaput"
Mensajes: 3.614
Antigüedad: 17 años, 8 meses
Puntos: 88
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
  #101 (permalink)  
Antiguo 25/08/2007, 03:50
Avatar de TonyG  
Fecha de Ingreso: mayo-2005
Mensajes: 34
Antigüedad: 19 años, 5 meses
Puntos: 1
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.
  #102 (permalink)  
Antiguo 26/09/2007, 05:37
 
Fecha de Ingreso: enero-2006
Ubicación: Torroles (Costa der Só)
Mensajes: 1.017
Antigüedad: 18 años, 10 meses
Puntos: 7
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é -
  #103 (permalink)  
Antiguo 02/03/2008, 03:14
Avatar de a n g e l u s  
Fecha de Ingreso: enero-2006
Ubicación: Chile
Mensajes: 237
Antigüedad: 18 años, 10 meses
Puntos: 1
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&aacute;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,
A n g e l u s
Concepción - Chile
más vale respuestas bien pensadas, que 7000 post
  #104 (permalink)  
Antiguo 14/05/2008, 08:42
 
Fecha de Ingreso: septiembre-2005
Mensajes: 135
Antigüedad: 19 años, 1 mes
Puntos: 1
Re: Biblioteca de Clases,Funciones y Sub-rutinas.
No se si os gustará y no os pongais críticos que es la primera vez que escribo aquí

Función en ASP que devuelve un objeto Recordset con los valores de una determinada consulta. De esta forma te ahorras el tener que declararlo siempre.

Función:
Cita:
Function AbrirConsulta(Query,Conexion)
'************************************************* ************************************************
'FUNCION QUE RECIBE LOS SIGUIENTES PARAMETROS:
' 1. QUERY.- VARIABLE DE TIPO STRING QUE RECIBE LA CONSULTA QUE SE DESEA REALIZAR SOBRE LA BBDD
' 2. CONEXION.- OBJETO CONEXIÓN A LA BASE DE DATOS.
'************************************************* ************************************************
'ESTA FUNCIÓN SE ENCARGA DE REALIZAR CONSULTAS A LAS BASES DE DATOS PUDIENDO DAR DOS RESULTADOS DISTINTOS:
' 1. NOTHING.- ENVIARA ESTE VALOR CUANDO LA CONSULTA NO MUESTRE RESULTADOS O BIEN CUANDO SE HAYA GENERADO ALGÚN
' ERROR. POR LO TANTO, EN CASO DE QUE EL VALOR SEA NOTHING SE DEBERÁ DE COMPROBAR SI
' HA EXISTIDO ALGÚN ERROR EN LA FUNCIÓN.
' 2. OBJETO RECORDSET.- DEVOLVERÁ EL OBJETO RECORDSET QUE TENDRÁ LOS RESULTADOS DE LA CONSULTA.
'************************************************* ************************************************
'EN RESUMEN, ESTA FUNCIÓN RECIBIENDO UNA CONEXIÓN Y UNA CONSULTA DESEADA DEVUELVE EL OBJETO RECORDSET CON
'LOS VALORES DE ESA CONSULTA.

Err.Clear 'LIMPIAMOS LOS POSIBLES ERRORES QUE PUEDAN HABERSE ORIGINADO ANTERIORMENTE
On Error Resume Next 'EN CASO DE QUE EXISTA ALGÚN ERROR DEJAMOS QUE SE SIGA EJECUTANDO EL CÓDIGO

Set RecGeneral = Server.CreateObject("ADODB.Recordset")
RecGeneral.Open Query,Conexion
If Err.Number <> 0 Then
'SE HA GENERADO UN ERROR Y POR TANTO DEVOLVEREMOS NOTHING
Set AbrirConsulta = Nothing
ElseIf RecGeneral.Eof And RecGeneral.Bof Then
'LA CONSULTA NO DEVUELVE NINGÚN RESULTADO
Set AbrirConsulta = Nothing
Else
'HEMOS RECUPERADO VALORES Y MANDAMOS EL RECORDSET
Set AbrirConsulta = RecGeneral
End If
End Function

Modo de utilización :

Cita:

Set RecDetalle= AbrirConsulta(Query,ConnIntranet)

If RecDetalle Is Nothing And Err.Number <> 0 Then
'HA OCURRIDO UN ERROR Y DEBEMOS DE COMPROBAR
ElseIf RecDetalle Is Nothing Then
'NO DEVUELVE RESULTADOS
Else
'HACEMOS LO QUE TENGAMOS QUE HACER
RecDetalle.Close
Set RecDetalle = Nothing
'ACORDARSE DE ESTO QUE SIEMPRE VIENE BIEN.
End If
  #105 (permalink)  
Antiguo 30/06/2008, 14:37
Avatar de Adler
Colaborador
  
Fecha de Ingreso: diciembre-2006
Mensajes: 4.671
Antigüedad: 17 años, 10 meses
Puntos: 126
Respuesta: Validar E-Mail
Es una adaptación de un código PHP que podeis encontrar aquí

Este mismo código en javascript


Código: 
Function vMail(correo)
Dim email_array, local_array, dominio_array, i
Dim esOK
Dim localOK, ipOK, dominoOK

set localOK = new RegExp
set ipOK = new RegExp
set dominoOK = new RegExp

localOK.pattern = ("^(([A-Za-z0-9!#$%&'*+/=?^_`{|}~-][A-Za-z0-9!#$%&'*+/=?^_`{|}~\.-]{0,63})|(\'[^(\\|\')]{0,62}\'))$")
ipOK.pattern = ("^\[?[0-9\.]+\]?$")
dominoOK.pattern = ("^(([A-Za-z0-9][A-Za-z0-9-]{0,61}[A-Za-z0-9])|([A-Za-z0-9]+))$")

'Por defecto el email es valido
esOK = True

' Ninguna cuenta de email puede tener menos de 5 caracteres "[email protected]"
If Len(correo) < 5 Then
esOK = False
Else

' El email consta de dos partes dividas por @
email_array = split(correo, "@")
If (ubound(email_array)+1) < 2 or (ubound(email_array)+1) > 2 Then
esOK = False
Else

' Incorrecto número de caracteres en alguna de las dos partes
If Len(email_array(0)) < 1 or Len(email_array(1)) < 1 Then
esOK = False
Else

If Instr(1, correo, " ") <> 0 Then 
'Buscamos que el email no tenga espacios en blancos "a @b.c"
esOK = False
Else

local_array = split(email_array(0), ".")
For i = 0 to (ubound(local_array)) 
If (Not localOK.Test(local_array(i))) Then
esOK = False
End If
Next 'i

' Se revisa si el dominio es una IP. Si no, debe ser un nombre de dominio válido
If (Not ipOK.Test(correo)) Then

dominio_array = split(email_array(1), ".")
' Incorrecto número de secciones por exceso o defecto para ser un dominio
If (ubound(dominio_array)+1) < 2 or (ubound(dominio_array)+1) > 3 Then 
esOK = False
End If

For i = 0 to (ubound(dominio_array)) 
If (Not dominoOK.Test(dominio_array(i))) Then
esOK = False
End If
Next 'i
End If
End If
End If
End If
End If
vMail = esOK

End Function


USO

Código: 
if Not vMail(Request.Form("email")) then
response.write "email NO válido"
else
response.write "email válido"
end if
__________________
Los formularios se envían/validan con un botón Submit
<input type="submit" value="Enviar" style="background-color:#0B5795; font:bold 10px verdana; color:#FFF;" />
Última edición por Adler; 30/06/2008 a las 14:53
  #106 (permalink)  
Antiguo 09/07/2008, 14:02
Avatar de JuanRAPerez
Colaborador
  
Fecha de Ingreso: octubre-2003
Mensajes: 2.393
Antigüedad: 21 años
Puntos: 27
Respuesta: Biblioteca de Clases,Funciones y Sub-rutinas.
Contar Variables de Sesión Activas

Este pequeño código muestra todas las variables de session activas en la aplicación en la que estás trabajando. Se puede abrir en una ventana nueva -o pestaña- y en otra ir ejecutando la página ASP. Al actualizar, verás los valores de las variables que se han ido incorporando.

Código PHP:
<%
dim i
dim j
j=Session.Contents.Count
Response.Write("Variables de Session: " & j&"<br/>")
For i=1 to j
    Response.Write(Session.Contents(i) & "<br/>")
Next
%> 
Este código lo encostre por ahí
y espero le sirva a alguien

para ser exacto en : http://www.webintenta.com/category/ASP

suerte
__________________
JuanRa Pérez
San Salvador, El Salvador
  #107 (permalink)  
Antiguo 16/07/2008, 15:09
Avatar de JuanRAPerez
Colaborador
  
Fecha de Ingreso: octubre-2003
Mensajes: 2.393
Antigüedad: 21 años
Puntos: 27
Respuesta: Biblioteca de Clases,Funciones y Sub-rutinas.
filtrar datos recibiendo el valor de el numero de la semana de el año

buscar valores en tabla recibiendo semana 10 y semana 13 como parametros

Cita:
select * from TUTABLA where DatePart(ww,Columna_fecha) >= 10 and DatePart(ww,Columna_fecha) <= 13
espero que a alguien le sirva
__________________
JuanRa Pérez
San Salvador, El Salvador
  #108 (permalink)  
Antiguo 09/09/2008, 05:47
 
Fecha de Ingreso: enero-2006
Ubicación: Torroles (Costa der Só)
Mensajes: 1.017
Antigüedad: 18 años, 10 meses
Puntos: 7
Codificación JSON para asp
Hice esta función para condificar información usando JSON para AJAX. Es similar a la función json_encode de PHP. No esta del todo depurada pero hace su función :P

Se le puede pasar tanto arrays de dos dimensiones que emulen los arrays asociativos de php:

$data["nombre"] = "Antonio" se pasaria asi: data(0,0) = "Nombre", data(0,1) = "Antonio"

Como arrays simples con separacion interna mediante dos puntos (:) :

data(0) = "Nombre: Antonio"

asi como listas

data(0) = Array("Antonio", "Juan", "Pedro")

La forma de usarlo:

response.write(json_encode(data))

Código: 
' ***************************
' Codifica para lectura json
' ***************************

' Valores a tener en cuenta de VarType
'vbEmpty 0 Empty (sin inicializar) 
'vbNull 1 Null (datos no válidos) 
'vbInteger 2 Entero 
'vbLong 3 Número entero largo 
'vbSingle 4 Número de punto flotante de precisión simple 
'vbDouble 5 Número de punto flotante de precisión doble 
'vbCurrency 6 Moneda 
'vbDate 7 Fecha 
'vbString 8 Cadena 
'vbObject 9 Objeto de automatización 
'vbError 10 Error 
'vbBoolean 11 Booleano
'vbByte 17 Byte 
'vbArray 8192 o 8204 Matriz 

' Estos dos para TODO 

'vbVariant 12 Variant (usada sólo con matrices de tipo Variant) 
'vbDataObject 13 Un objeto de acceso de datos 

dim pasa 

function json_encode(Arrstr)
    dim n, s, a, campo, valor
    dim tmp, dimen, esLista, final
    
    'on error resume next
    
    final = """"""

    ' Es null
    if (VarType(Arrstr)=1) then 
        final = null
    ' es boolean
    elseif VarType(Arrstr) = 11 then 
        final = false
        if Arrstr = true then final = true
    ' Es array
    elseif VarType(Arrstr) = 8192 or isArray(ArrStr) then
        dimen = 1
        ' Chequeamos las dimensiones del array
        on error resume next
        if ubound(Arrstr,2) > 1 then 
            if err = 0 then dimen = 2
        end if
        on error goto 0
        
        'chequeamos si es un objeto o una lista
        s = ""
        for n = 0 to Ubound(Arrstr, 1)
            
            ' Tomamos el valor de la fila
            ' Es un array multidimensional o simula uno asociativo
            if dimen > 1 then
                campo = json_encode(Arrstr(n,0))
                if Trim(campo) <> "" then
                    valor = json_encode(Arrstr(n,1))
                    s = s & campo & ":" & valor & ","
                end if
                esLista = false
                
            elseif instr(Arrstr(n),":") > 0 then
                tmp = split(a,":")
                campo = json_encode(tmp(0))
                if Trim(campo) <> "" then
                    valor = json_encode(tmp(1))
                    s = s & campo & ":" & valor & ","
                end if
                esLista = false
                
            else ' Es una lista
                if Trim(Arrstr(n)) <> "" then    s = s & json_encode(Arrstr(n)) & ","
                esLista = true
                
            end if
        next    
        if not esLista then final = "{" else final = "[" end if
        if len(s) > 1 then final = final & left(s, len(s)-1)
        if not esLista then final = final & "}" else final = final & "]" end if
    ' Es escalar
    elseif VarType(Arrstr) > 1 and VarType(Arrstr) < 9 then
        valor = Arrstr
        valor = cstr(valor)
        ' Float Type (must be .)
        valor = replace(valor, ",", ".")
        valor = replace(valor, vbCrLf, "\\n")
        valor = replace(valor, vbCr, "\\n")
        valor = replace(valor, vbLf, "\\n")
        valor = replace(valor, "\\", "\\\")
        valor = replace(valor, "/", "\\/")
        valor = replace(valor, "\n", "\\n")
        valor = replace(valor, "\t", "\\t")
        valor = replace(valor, "\r", "\\r")
        valor = replace(valor, "\b", "\\b")
        valor = replace(valor, "\f", "\\f")
        valor = replace(valor, """", "\""")
                
        valor = """" & Trim(valor) & """"

        final = valor
    end if
    'on error goto 0
    json_encode = final
end function
__________________
"Tus pecados son el estiércol sobre el que florecerán las flores de tus virtudes" - Gerald Messadié -
  #109 (permalink)  
Antiguo 21/09/2008, 21:20
 
Fecha de Ingreso: junio-2004
Mensajes: 72
Antigüedad: 20 años, 4 meses
Puntos: 2
Respuesta: Biblioteca de Clases,Funciones y Sub-rutinas.
Include Dinamico en ASP
Simple , facil y rapido....

La idea de este post es mostrar como generar un include dinamico de la siguiente forma...
Código asp: 
Ver original
  1. <%
  2. Inc_File "mi_archivo_a_incluir.asp"
  3. 'Puede ser cualquier tipo de archivo
  4. 'Asp, Inc, Tpl, etc....
  5. %>

Ahora lo bueno de esta clase es que permite la ejecusion de codigo incluido en los archivos..
si por el caso yo tengo en un archivo X , una funsion donde apunto a la DB para mostrar/modificar datos en la misma.. al generar el Inlucde , trabaja de la misma forma que si estubieras en esa pagina en concreto.

Ademas funsiona tanto para los 2 casos de Include FILE y VIRTUAL

La clase Provee un sistema de Error en caso de no encontrar el archivo a incluir. (Aclaro que esta en fase beta esta parte)
Genera el error de inclusion y continua la ejecusion de la pagina.
estoy implementando un sistema mejorado para esta seccion

Codigo de la calse.
Class.asp
Código asp: 
Ver original
  1. <%
  2. Public Inc_File, Include_Vars, Include_Vars_Count
  3. Dim ObjFsChk
  4.  
  5. Set Inc_File = New Csl_Include
  6. Set ObjFsChk = Server.CreateObject("Scripting.FileSystemObject")
  7. Set RegFltr = New regexp
  8. Set RegFltr2 = New regexp
  9.  
  10. Class Csl_Include
  11.     
  12.     Private Sub Class_Initialize()
  13.         Set Include_Vars = Server.CreateObject("Scripting.Dictionary")
  14.         Include_Vars_Count = 0
  15.     End Sub
  16.     
  17.     Private Sub Class_Deactivate()
  18.         Include_Vars.RemoveAll
  19.         Set Include_Vars = Nothing
  20.         Set Include = Nothing
  21.     End Sub
  22.     
  23.     Public Default Function Inc_File(ByVal Str_Path)
  24.         Dim Str_Source
  25.         IF Str_Path <> "" Then
  26.             Init_Path = Str_Path
  27.             Str_Source = ReadFile(Str_Path)
  28.             IF Str_Source <> "" Then
  29.                 Str_Source = ProcessIncludes (Str_Source, Init_Path, 0)
  30.                 ConvertToCode Str_Source
  31.                 FormatCode Str_Source
  32.                 IF Str_Source <> "" Then
  33.                     ExecuteGlobal Str_Source
  34.                 End IF
  35.             End IF
  36.             'Esto es simplemente una variante al mostrar el error de include
  37.             IF Not ObjFsChk.FileExists(Str_Path) Then
  38.                 Response.Write "<table border='1' cellspacing='0' cellpadding='0' align='center'><tr><td>" & VbCrLf
  39.                 Response.Write "<font color=""Red"">Error:<BR></font>" & VbCrLF
  40.                 Response.Write "El archivo <font color=""Red"">" & Str_Path & "</font> No se pudo Incluir"
  41.                 Response.Write "</td></tr></table>"
  42.             End IF
  43.         End IF
  44.     End Function
  45.     
  46.     Private Sub ConvertToCode(Str_Source)
  47.         Dim i, Str_Temp, Arr_Temp, Int_Len, BaseCount
  48.         BaseCount = Include_Vars_Count
  49.         IF Str_Source <> "" Then
  50.             Str_Temp = Replace(Str_Source,"<" & "%","¿%")
  51.             Str_Temp = Replace(Str_Temp,"%" & ">","¿")
  52.             IF Left(Str_Temp,1) = "¿" Then Str_Temp = Right(Str_Temp,Len(Str_Temp) - 1)
  53.             IF Right(Str_Temp,1) = "¿" then Str_Temp = Left(Str_Temp,Len(Str_Temp) - 1)
  54.             Arr_Temp = Split(Str_Temp,"¿")
  55.             Int_Len = Ubound(Arr_Temp)
  56.             IF (Int_Len + 1) > 0 Then
  57.                 For i = 0 To Int_Len
  58.                     Str_Temp = Arr_Temp(i)
  59.                     Str_Temp = Replace(Str_Temp,VbCrLf & VbCrLf,VbCrLf)
  60.                     IF Left(Str_Temp,2) = VbCrLf Then Str_Temp = Right(Str_Temp,Len(Str_Temp) - 2)
  61.                     IF Right(Str_Temp,2) = VbCrLf Then Str_Temp = Left(Str_Temp,Len(Str_Temp) - 2)
  62.                     IF Left(Str_Temp,1) = "%" Then
  63.                         Str_Temp = Right(Str_Temp,Len(Str_Temp) - 1)
  64.                         IF Left(Str_Temp,1) = "=" Then
  65.                             Str_Temp = Right(Str_Temp,Len(Str_Temp) - 1)
  66.                             Str_Temp = "Response.Write " & Str_Temp
  67.                         End IF
  68.                     Else
  69.                         IF Str_Temp <> "" Then
  70.                             Include_Vars_Count = Include_Vars_Count + 1
  71.                             Include_Vars.Add Include_Vars_Count, Str_Temp
  72.                             Str_Temp = "Response.Write Include_Vars.Item(" & Include_Vars_Count & ")"
  73.                         End IF
  74.                     End IF
  75.                     IF Right(Str_Temp,2) <> VbCrLf Then Str_Temp = Str_Temp
  76.                     Arr_Temp(i) = Str_Temp
  77.                 Next
  78.                     Str_Source = Join(Arr_Temp,VbCrLf)
  79.             End IF
  80.         End IF
  81.     End Sub
  82.     
  83.     Private Function ProcessIncludes(Tmp_Source, CurDir, CurDepth)
  84.         Dim Int_Start, Str_Path, Str_Mid, Str_Temp, LocalDir
  85.         IF (CurDepth < 20) Then
  86.             LocalDir = Left(CurDir, Len(CurDir)-Len(ObjFsChk.GetFileName(CurDir)))
  87.             Tmp_Source = Replace(Tmp_Source,"<!-- #","<!--#")
  88.             Int_Start = InStr(Tmp_Source,"<!--#Include")
  89.             Str_Mid = Lcase(GetBetween(Tmp_Source,"<!--#Include","-->"))
  90.             Do Until Int_Start = 0
  91.                 Str_Mid = Lcase(GetBetween(Tmp_Source,"<!--#Include","-->"))
  92.                 IF (Str_Mid <> "") Then Int_Start = 1
  93.                 IF Int_Start >  0 Then
  94.                     Str_Method = Lcase(Trim(GetBetween(Str_Mid," ","=")))
  95.                     Str_Temp = Lcase(GetBetween(Str_Mid,chr(34),Chr(34)))
  96.                     Str_Temp = Trim(Str_Temp)
  97.                     IF (Str_Method = "File") Then
  98.                         Newdir = ObjFsChk.BuildPath(LocalDir,Replace(Str_Temp,"/","\"))
  99.                         Str_Path = ProcessIncludes(ReadFile(Newdir), Newdir, CurDepth+1)
  100.                         Tmp_Source = Replace(Tmp_Source,"<!--#Include" & Str_Mid & "-->",Str_Path & VbCrLf)
  101.                     ElseIF (Str_Method = "Virtual") Then
  102.                         Newdir = Server.MapPath(Str_Temp)
  103.                         Str_Path = ProcessIncludes(ReadFile(Newdir), Newdir)
  104.                         Tmp_Source = Replace(Tmp_Source,"<!--#Include" & Str_Mid & "-->",Str_Path & VbCrLf)
  105.                     Else
  106.                         Tmp_Source = Replace(Tmp_Source,"<!--#Include" & Str_Mid & "-->","" & VbCrLf)
  107.                     End IF
  108.                 End IF
  109.                 Int_Start = InStr(Tmp_Source,"<!--#Include")
  110.             Loop
  111.             ProcessIncludes = Tmp_Source
  112.         Else
  113.             ProcessIncludes = ""
  114.         End IF
  115.     End Function
  116.     
  117.     Private Sub FormatCode(Str_Code)
  118.         Dim i, Arr_Temp, Int_Len
  119.         Str_Code = Replace(Str_Code,VbCrLf & VbCrLf,VbCrLf)
  120.         IF Left(Str_Code,2) = VbCrLf Then Str_Code = Right(Str_Code,Len(Str_Code) - 2)
  121.         Str_Code = Trim(Str_Code)
  122.         IF InStr(Str_Code,VbCrLf) > 0 Then
  123.             Arr_Temp = Split(Str_Code,VbCrLf)
  124.             For i = 0 To Ubound(Arr_Temp)
  125.                 Arr_Temp(i) = ltrim(Arr_Temp(i))
  126.                 IF Arr_Temp(i) <> "" Then Arr_Temp(i) = Arr_Temp(i) & VbCrLf
  127.             Next
  128.             Str_Code = Join(Arr_Temp,"")
  129.             Arr_Temp = VbNull
  130.         End IF
  131.     End Sub
  132.     
  133.     Private Function ReadFile(Str_Path)
  134.         Dim ObjFile
  135.         IF Str_Path <> "" Then
  136.             IF InStr(Str_Path,":") = 0 Then Str_Path = Server.MapPath(Str_Path)
  137.             IF ObjFsChk.FileExists(Str_Path) Then
  138.                 Set ObjFile = ObjFsChk.OpenTextFile(Str_Path, 1, False)
  139.                 IF Err.Number = 0 Then
  140.                     IF (Not ObjFile.AtEndOfStream) Then
  141.                         ReadFile = ObjFile.ReadAll
  142.                         RegFltr.Global = True
  143.                         RegFltr.IgnoreCase = True
  144.                         RegFltr.Pattern = "<%[^=](.|\n)*?%" & ">"
  145.                         RegFltr2.Global = True
  146.                         RegFltr2.IgnoreCase = True
  147.                         RegFltr2.Pattern = """.*?"""
  148.                         Set Matches = RegFltr.Execute(ReadFile)
  149.                         pEnd = 0
  150.                         pStart = 1
  151.                         Str_Temp_New = ""
  152.                         For Each Match In Matches
  153.                             pEnd = Match.FirstIndex + 1
  154.                             IF (pEnd <> pStart) Then
  155.                                 Str_Temp_New = Str_Temp_New & Mid(ReadFile, pStart, pEnd - pStart)
  156.                                 pStart = pEnd
  157.                             End IF
  158.                             Set Matches2 = RegFltr2.Execute(Match.Value)
  159.                             pEnd2 = 0
  160.                             pStart2 = 1
  161.                             cpystr = ""
  162.                             For Each Match2 in Matches2
  163.                                 pEnd2 = Match2.FirstIndex + 1
  164.                                 IF (pEnd2 <> pStart2) Then
  165.                                     cpystr = cpystr & Mid(Match.Value, pStart2, pEnd2 - pStart2)
  166.                                     pStart2 = pEnd2
  167.                                 End IF
  168.                                 cpystr = cpystr & Replace(Match2.value,"'","æ")
  169.                                 pEnd2 = pStart2 + Match2.length
  170.                                 pStart2 = pEnd2
  171.                             Next
  172.                             IF (pEnd2 < Len(Match.Value)) Then
  173.                                 pEnd2 = Len(Match.Value) + 1
  174.                                 cpystr = cpystr & Mid(Match.Value, pStart2, pEnd2 - pStart2)
  175.                             End IF
  176.                             Set Matches2 = Nothing
  177.                             RegFltr.Pattern = "'.*?\n"
  178.                             Str_Temp_New = Str_Temp_New & RegFltr.Replace(cpystr,vbcr)
  179.                             pEnd = pStart + Match.length
  180.                             pStart = pEnd
  181.                         Next
  182.                         IF (pEnd < len(ReadFile)) Then
  183.                             pEnd = len(ReadFile) + 1
  184.                             Str_Temp_New = Str_Temp_New & Mid(ReadFile, pStart, pEnd - pStart)
  185.                         End IF
  186.                         ReadFile = Replace(Str_Temp_New,"æ","'")
  187.                     Else
  188.                         ReadFile = ""
  189.                     End IF
  190.                     ObjFile.close
  191.                 End IF
  192.                 Set ObjFile = Nothing
  193.             End IF
  194.         End IF
  195.     End Function
  196.     
  197.     Private Function GetBetween(StrData, StrStart, StrEnd)
  198.         Dim IngStart, IngEnd
  199.         IngStart = InStr(StrData, StrStart) + Len(StrStart)
  200.         IF (IngStart <> 0) Then
  201.             IngEnd = InStr(IngStart, StrData, StrEnd)
  202.             IF (IngEnd <> 0) Then
  203.                 GetBetween = Mid(StrData, IngStart, IngEnd - IngStart)
  204.             End IF
  205.         End IF
  206.     End Function
  207. End Class
  208. %>

Y por ultimo quedaria generar una pagin Supongamos Index.asp donde hacemos la llamada a nuestra clase.
Código asp: 
Ver original
  1. <!--#INCLUDE FILE = "Class.asp" -->
  2. <%
  3. Inc_File "Include/Funsiones.asp"
  4. Inc_File "Configuracion.asp"
  5. 'y asi con todos los archivos que necesitemos incluir
  6. %>

Espero que les sea de utilidad para todos y aquel que quiera modificar el codigo tiene todo el derecho....para que es el Codigo Libre sino???

Este es mi pequeño aporte (Tarde pero seguro) jajaja
  #110 (permalink)  
Antiguo 04/11/2008, 12:11
Avatar de Muzztein  
Fecha de Ingreso: agosto-2002
Ubicación: Hangar 18
Mensajes: 1.703
Antigüedad: 22 años, 2 meses
Puntos: 16
Respuesta: Biblioteca de Clases,Funciones y Sub-rutinas.
Funcion para envio de correo electronico.
lo he probado en IIS 5 y funciona siempre

Código asp: 
Ver original
  1. function enviaEmail(para,cc,desde,asunto,mensaje,servidor)
  2.     on error resume next
  3.  
  4.     enviaEmail = false
  5.     
  6.     dim objCDO,objCDOConfig,objFields
  7.     Set objCDO      = CreateObject("CDO.Message")
  8.     Set objCDOConfig  = CreateObject("CDO.Configuration")
  9.     Set objFields    = objCDOConfig.Fields
  10.         
  11.     With objFields
  12.       .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = servidor
  13.       .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
  14.       .Item("http://schemas.microsoft.com/cdo/configuration/SendUsing") = 2
  15.       .Update
  16.     End With
  17.     
  18.     With objCDO
  19.       .Configuration  = objCDOConfig
  20.       .To          = para
  21.     
  22.     if cc <> false then 
  23.       .cc          = cc
  24.     end if   
  25.     
  26.       .From        = desde
  27.       .Subject     = asunto
  28.       .TextBody    = mensaje
  29.       .Send
  30.     End With
  31.     
  32.     Set objFields = Nothing
  33.     Set objCDO = Nothing
  34.     Set objCDOConfig = Nothing 
  35.     
  36.     if err.number = 0 then
  37.         enviaEmail = true
  38.     else 
  39.         enviaEmail = err.description
  40.     end if
  41.     on error goto 0
  42.  
  43. end function
  #111 (permalink)  
Antiguo 12/12/2008, 08:35
Avatar de Adler
Colaborador
  
Fecha de Ingreso: diciembre-2006
Mensajes: 4.671
Antigüedad: 17 años, 10 meses
Puntos: 126
Respuesta: Biblioteca de Clases,Funciones y Sub-rutinas.
Ordenar elementos de una cadena
En un campo de texto se introduce la cadena: vaca león águila y queremos mostrarla ordenada alfabéticamente

Código asp: 
Ver original
  1. Sub Ordenar_Array(arr)
  2.  
  3. Dim hilera, i, pos, p_valor, n_valor, arrDivision
  4. For hilera = 0 To UBound(arr) - 1
  5. p_valor = arr(hilera)
  6. n_valor = arr(hilera)
  7. pos = hilera
  8.             
  9. For i = hilera + 1 to UBound(arr)
  10. If arr(i) < n_valor Then
  11. pos = i
  12. n_valor = arr(i)
  13. End If
  14. Next
  15.         
  16. If pos <> hilera Then
  17. arr(pos) = p_valor
  18. arr(hilera) = n_valor
  19. End If    
  20. Next
  21.  
  22. End Sub

Uso

Código asp: 
Ver original
  1. arrDivision = split(Request.Form("elementos"), " ")
  2. Response.Write "Desordenado -- " & join(arrDivision, ", ") & "<br />"
  3. Call Ordenar_Array(arrDivision)
  4. Response.Write "Ordenado -- " & join(arrDivision, ", ")
__________________
Los formularios se envían/validan con un botón Submit
<input type="submit" value="Enviar" style="background-color:#0B5795; font:bold 10px verdana; color:#FFF;" />
  #112 (permalink)  
Antiguo 13/12/2008, 08:27
Avatar de Adler
Colaborador
  
Fecha de Ingreso: diciembre-2006
Mensajes: 4.671
Antigüedad: 17 años, 10 meses
Puntos: 126
Respuesta: Biblioteca de Clases,Funciones y Sub-rutinas.
Contar variables de sesión activas, ver sus valores y que variables contienen esos valores

Para cerrar el script de JuanRa

Código asp: 
Ver original
  1. dim i
  2. Response.Write("Variables de Session: " & Session.Contents.Count & "<br/>")
  3. For Each i in Session.Contents
  4. Response.Write(i & ": " & Session.Contents(i) & "<br />")
  5. Next
__________________
Los formularios se envían/validan con un botón Submit
<input type="submit" value="Enviar" style="background-color:#0B5795; font:bold 10px verdana; color:#FFF;" />
  #113 (permalink)  
Antiguo 13/12/2008, 08:43
Avatar de Adler
Colaborador
  
Fecha de Ingreso: diciembre-2006
Mensajes: 4.671
Antigüedad: 17 años, 10 meses
Puntos: 126
Respuesta: Biblioteca de Clases,Funciones y Sub-rutinas.
Leer cookies de un usuario

Código asp: 
Ver original
  1. dim i,j
  2. For Each i in Request.Cookies
  3. If Request.Cookies(i).HasKeys then
  4. For Each j in Request.Cookies(i)
  5. Response.Write(i & ": " & j & " --> " & Request.Cookies(i)(j) & "<br />")
  6. Next
  7. Else
  8. Response.Write(i & " --> " & Request.Cookies(i) & "<br />")
  9. End If
  10. Next
__________________
Los formularios se envían/validan con un botón Submit
<input type="submit" value="Enviar" style="background-color:#0B5795; font:bold 10px verdana; color:#FFF;" />
  #114 (permalink)  
Antiguo 23/12/2008, 06:17
Avatar de Muzztein  
Fecha de Ingreso: agosto-2002
Ubicación: Hangar 18
Mensajes: 1.703
Antigüedad: 22 años, 2 meses
Puntos: 16
Respuesta: Biblioteca de Clases,Funciones y Sub-rutinas.
DE RECORDSET A XML


EsTA ES una funcion muy util que lo que hace es tomar una consulta SQL, ejecutarla contra el servidor y el resultado lo transforma en un XML.

el unico requisito de esta funcion es que asume una coneccion llamada CONEXION


se ejecuta asi

Código PHP:
dim xml ,str

str = "select * from tabla"
xml = setQueryToXml(str) 
y listo, en la variable xml estan tus datitos.


Código asp: 
Ver original
  1. Function setQueryToXml(strSQL)
  2.     
  3.  
  4.  
  5.     Dim strXMLTemplate
  6.     Dim xCount
  7.     Dim strXml
  8.     DIM dbcRec
  9.     DIM XMLOBJ
  10.     DIM XMLTEMPLATE
  11.     DIM XMLRESULT
  12.                 on error resume next
  13.                 
  14.                 Const adCmdText = &H0001 ' ADDED PARA PODER CONTAR
  15.                 Const adOpenStatic = 3   ' ADDED PARA PODER CONTAR
  16.  
  17.  
  18.                 Set dbcRec = Server.CreateObject("ADODB.RecordSet")
  19.                 dbcRec.Open strSQL,ConEXION,adopenstatic,adcmdtext  ' ADDED PARA PODER CONTAR
  20.                 
  21.                 If Err.Number <> 0 OR dbcRec.RecordCount <= 0 Then
  22.                 setQueryToXml = FALSE
  23.                 Else
  24.                     Set xmlObj = Server.CreateObject("MSXML2.DOMDocument")
  25.                     Set XmlTemplate =  Server.CreateObject("MSXML2.DOMDocument")
  26.                     strXMLTemplate = "<?xml version=""1.0""?>"
  27.                     strXMLTemplate = strXMLTemplate & "<xsl:stylesheet version=""1.0"" xmlns:xsl=""http://www.w3.org/1999/XSL/Transform"" xmlns:z=""#RowsetSchema"" xmlns:rs=""urn:schemas-microsoft-com:rowset"">"  & vbCrLf
  28.                     strXMLTemplate = strXMLTemplate & "<xsl:output method=""xml"" cdata-section-elements=""id_objeto"" indent=""yes"" omit-xml-declaration=""yes""/>"  & vbCrLf
  29.                     strXMLTemplate = strXMLTemplate & "<xsl:template match=""/"">"  & vbCrLf
  30.                     strXMLTemplate = strXMLTemplate & "<xsl:element name=""cryptic_writings"">"  & vbCrLf
  31.                     strXMLTemplate = strXMLTemplate & "<xsl:for-each select=""/xml/rs:data/z:row"">"  & vbCrLf
  32.                     strXMLTemplate = strXMLTemplate & "<xsl:element name=""reg"">"  & vbCrLf
  33.                     For xCount = 0 To dbcRec.Fields.Count - 1
  34.                     strXMLTemplate = strXMLTemplate & "<xsl:element name=""" & lcase(dbcRec(xCount).Name) & """>" & vbCrLf
  35.                     strXMLTemplate = strXMLTemplate & "<xsl:value-of select=""@" & dbcRec(xCount).Name & """/>" & vbCrLf
  36.                     strXMLTemplate = strXMLTemplate & "</xsl:element>" & vbCrLf
  37.                     Next
  38.                     strXMLTemplate = strXMLTemplate & "</xsl:element>"  & vbCrLf
  39.                     strXMLTemplate = strXMLTemplate & "</xsl:for-each>"  & vbCrLf
  40.                     strXMLTemplate = strXMLTemplate & "</xsl:element>"  & vbCrLf
  41.                     strXMLTemplate = strXMLTemplate & "</xsl:template>"  & vbCrLf
  42.                     strXMLTemplate = strXMLTemplate & "</xsl:stylesheet>"  & vbCrLf
  43.                     XmlTemplate.loadXML (strXMLTemplate)
  44.                     dbcRec.Save xmlObj, 1
  45.                     strXml = xmlObj.transformNode(XmlTemplate)
  46.                     Set XmlTemplate = Nothing
  47.                     Set xmlObj = Nothing
  48.                     dbcRec.Close
  49.                     Set dbcRec = Nothing
  50.                     setQueryToXml = strXMLTemplate
  51.                     setQueryToXml = strXml
  52.                 End If
  53.                 on error goto 0
  54. End Function

  #115 (permalink)  
Antiguo 26/03/2009, 08:12
Avatar de TonyChile  
Fecha de Ingreso: marzo-2009
Ubicación: Maipú, Santiago
Mensajes: 422
Antigüedad: 15 años, 7 meses
Puntos: 7
Respuesta: Biblioteca de Clases,Funciones y Sub-rutinas.
validacion de email

Este codigo es el mejor que e visto para poder validar un correo (email) no me acuerdo donde lo vi pero el que lo hizo se merece

Código: 
<%

' EMailOK.inc
' --------- Funcion que comprueba si un e-mail es valido. Autómata finito de 8 estados (inic:0 - finales: 6, 7 y 8)

' La función devolverá:

' vbEMailNulo = 0 - si es nulo o esta vacio

' vbEMailNoOK = 1 - Si el e-mail es incorrecto

' vbEMailOK = 2 - Si el e-mail es valido

Const vbEMailNulo = 0

Const vbEMailNoOK = 1

Const vbEMailOK = 2

Function ValidarEMAIL(EMAIL)

Dim Indice

Dim Caracter

Dim Largo

Dim Estado


ValidarEMAIL = vbEMailNulo ' Inicialmente lo suponemos vacío


If EMAIL <> "" Then

Largo = Len(EMAIL)

Estado = 0 ' Estado inicial del autómata
For Indice = 1 To Largo ' Comenzamos a recorrer la cadena

Caracter = Mid(EMAIL, Indice, 1) ' Vamos tomando carácter a carácter


' Con lo que sigue comprobamos si el caracter está

' en el rango A-Z , a-z , 0-9 (caracter aceptable tipo A - Alfanumerico)


If (Caracter>="a" AND Caracter<="z") OR _ 

(Caracter>="A" AND Caracter<="Z") OR _

(Caracter>="0" AND Caracter<="9") Then

Caracter = "A"

End If


' Con lo que sigue comprobamos si el caracter es

' _ ó - (caracter aceptable tipo - : Guion alto o bajo)


If Caracter = "-" Or Caracter = "_" Then 

Caracter = "-"

End If


Select Case Caracter

Case "A": ' Es un caracter aceptable tipo A

Select Case Estado 

Case 0:

Estado = 1 ' Era el primer caracter del EMAIL: pasamos a estado 1
Case 1:

Estado = 1 ' Caracter intermedio ..x.. antes de arroba. Seguimos en 1

Case 2:

Estado = 3 ' Caracter después de arroba. Pasamos a estado 3

Case 3:

Estado = 3 ' Caracter en dominio. Seguimos en estado 3

Case 4:

Estado = 5 ' 1er caracter en extension de dominio/subdominio. Pasamos a estado 5

Case 5:

Estado = 6 ' 2º caracter en extension de dominio/subdominio. Pasamos a estado 6 

Case 6:

Estado = 7 ' 3er caracter en extension de dominio/sudominio. Pasamos a estado 7

Case 7:

Estado = 8 ' 4º caracter en extension de dominio/subdominio. Pasamos a estado 8

Case 8:

ValidarEMAIL = vbEMailNoOK ' La longitud de la extensión .XXXX mayor que 4 caracteres

Exit Function ' Estado de error

End Select

Case "-": ' Es un caracter aceptable tipo "-" 
Select Case Estado 

Case 1:

Estado = 1 ' Caracter intermedio ..-.. antes de arroba. Seguimos en 1

Case 3:

Estado = 3 ' Caracter en dominio. Seguimos en estado 3

Case Else:

ValidarEMAIL = vbEMailNoOK ' 

Exit Function ' Estado de error

End Select 


Case "." : '-----> Encuentra un punto

Select Case Estado

Case 1: ' Como lo anterior eran caracteres y puntos

Estado = 0 ' pasamos a estado inicial (espera un caracter)

Case 3: ' Lo anterior era una arroba y texto

Estado = 4 ' Pasamos a estado 4 (extension .com, .net, .shop, .info ...)

Case Else: ' Encontró un punto después de la arroba o al comienzo de la cadena

ValidarEMAIL = vbEMailNoOK ' o antes de la arroba

Exit Function ' Estado de error

End Select


Case "@": '-----> Encuentra una arroba

Select Case Estado

Case 1: ' Si lo anterior eran caracteres y puntos,

Estado = 2 ' pasamos a estado 2

Case Else: ' Si lo anterior era algo distinto

ValidarEMAIL = vbEMailNoOK ' Estado de error

Exit Function

End Select


' -----> Encuentra un caracter "raro"

Case Else: ' Caracter inaceptable para email. Ej: * : !

ValidarEMAIL = vbEMailNoOK ' Estado de error

Exit Function

End Select


Next ' -----> Fin de comprobación de cadena


If (Estado = 6) or (Estado = 7) or (Estado = 8) Then ' El autómata terminó en un estado final

ValidarEMAIL = vbEMailOK ' Estado final: email correcto

Else

ValidarEMail = vbEMailNoOK ' No era un estado final: email incorrecto

End If

End If 

End Function

%>
__________________
Chilenos 100% Chilenos de Corazón
"Nuestra mayor gloria no está en no caer jamás, sino en levantarnos cada vez que caigamos"
Última edición por TonyChile; 28/04/2009 a las 08:36
  #116 (permalink)  
Antiguo 23/09/2009, 15:35
Avatar de Adler
Colaborador
  
Fecha de Ingreso: diciembre-2006
Mensajes: 4.671
Antigüedad: 17 años, 10 meses
Puntos: 126
Respuesta: Biblioteca de Clases,Funciones y Sub-rutinas.
Trabajando con vectores. ¿Como eliminar elementos duplicados, mostrar esos elementos duplicados y contar el número de veces que está duplicado cada elemento?

Código asp: 
Ver original
  1. <&#37;
  2. Dim array_origen, contador_limpio, contador_duplicados, x, p
  3. contador_limpio = 0
  4. contador_duplicados = 0
  5. array_origen = Array("oso","perro","león","gato","tigre","perro","león","gato","elefante","gato","perro") 
  6. Dim array_limpio()
  7. Dim array_duplicados()
  8. Dim veces_repetidos()
  9.  
  10. Redim preserve array_limpio(1)
  11. Redim preserve array_duplicados(0)
  12.  
  13. Dim Res
  14.     For x = 0 to (UBound(array_origen))
  15.  
  16. Res = 0
  17.         For p = 0 to UBound(array_limpio)
  18.             Res = StrComp(array_origen(x),array_limpio(p),1)
  19.             IF (Res = 0) then 
  20.                 Redim preserve array_duplicados(contador_duplicados)
  21.                 array_duplicados(contador_duplicados) = array_origen(x)
  22.                 contador_duplicados = contador_duplicados +1
  23.             Exit For 'p
  24.             END IF
  25.         Next 'p
  26.  
  27.             IF (Res <> 0) then
  28.                 Redim preserve array_limpio(contador_limpio)
  29.                 array_limpio(contador_limpio) = array_origen(x)
  30.                 contador_limpio = contador_limpio +1
  31.             END IF
  32.  
  33.     Next 'x
  34.  
  35.  
  36.  
  37. Dim valoresSOBREbuscar
  38. valoresSOBREbuscar = ""    
  39. Response.write "<b>Este es el vector</b><br />" & Join(array_origen, ", ")
  40. valoresSOBREbuscar = Join(array_origen, ",")
  41.  
  42. Dim valoresAbuscar
  43. valoresAbuscar = ""    
  44. Response.write "<br /><br /><b>Este es el vector una vez eliminando los elemento duplicados</b><br />"  & Join(array_limpio, ", ")
  45. valoresAbuscar = Join(array_limpio, ",")
  46.  
  47. Response.write "<br /><br /><b>Estos son los elemento eliminados</b><br />" & Join(array_duplicados, ", ")
  48.  
  49. Response.write "<br /><br /><b>Número de veces que se repite cada elemento</b><br />"
  50. Dim n, objRegExp, strClave, Coincidencia, cadena, array_cadena, i
  51. Function Encuentra (plbraClave)
  52. array_cadena = Split(plbraClave,",")
  53. For n=0 to UBound(array_cadena)
  54. i = -1
  55. Response.Write "El elemento " & array_cadena(n)
  56. Set objRegExp = new RegExp
  57. With objRegExp
  58.     .Pattern = "\b("&array_cadena(n)&")+\b"
  59.     .IgnoreCase = True
  60.     .Global = True
  61. End With
  62. Set strClave = objRegExp.Execute(valoresSOBREbuscar)
  63. For Each Coincidencia in strClave
  64. i = i +1
  65. Next
  66. Response.Write " se repite : " & i & " veces<br />"
  67. Set strClave = nothing
  68. Set objRegExp = nothing
  69. Next 'n
  70. End Function
  71.  
  72. Response.Write Encuentra(valoresAbuscar)
  73. %>

Suerte
__________________
Los formularios se envían/validan con un botón Submit
<input type="submit" value="Enviar" style="background-color:#0B5795; font:bold 10px verdana; color:#FFF;" />
Última edición por Adler; 23/01/2010 a las 15:14 Razón: compactar código
  #117 (permalink)  
Antiguo 04/11/2009, 16:38
 
Fecha de Ingreso: octubre-2009
Mensajes: 97
Antigüedad: 15 años
Puntos: 4
Sonrisa Respuesta: Biblioteca de Clases,Funciones y Sub-rutinas.
Yo colaboro con el siguiente código.
Es un arhivo con muchas funciones útiles:
Código asp: 
Ver original
  1. <%
  2. function bajar_archivo(ruta,nombre,donde)
  3. select case donde
  4. case "web":path=ruta
  5. case "servidor":path="ht"&"tp://"&request.servervariables("server_name")&"/"&ruta
  6. end select
  7. set ajax=server.createobject("msxml2.XMLHTTP")
  8. ajax.open"GET",path,false
  9. ajax.send
  10. binarios=ajax.responsebody
  11. set stream=server.createobject("adodb.stream")
  12. stream.type=1
  13. stream.open
  14. stream.write binarios
  15. stream.savetofile server.mappath(nombre)
  16. end function
  17. function variables_servidor()
  18. variables_servidor="<table border=1>"
  19. for each item in request.servervariables
  20. variables_servidor=variables_servidor&"<tr><td><b>"&item&"</b></td><td>"&replace(request.servervariables(item),vbcrlf,"<br>")&"</td></tr>"&vbcrlf
  21. next
  22. variables_servidor=variables_servidor&"</table>"
  23. end function
  24. function generar_clave(tamano)
  25. todo=array(0,1,2,3,4,5,6,7,8,9,"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")
  26. randomize
  27. for i=1 to tamano
  28. generar_clave=generar_clave&todo(int(ubound(todo)*rnd))
  29. next
  30. end function
  31. function calculadora(numero1,operacion,numero2)
  32. numerico1=isnumeric(numero1)
  33. numerico2=isnumeric(numero2)
  34. select case numerico1
  35. case false:calculadora="Los valores deben ser numéricos."
  36. case else:select case numerico2
  37. case false:calculadora="Los valores deben ser numéricos."
  38. case else:select case operacion
  39. case "+":calculadora=numero1+numero2
  40. case "-":calculadora=numero1-numero2
  41. case "*":calculadora=numero1*numero2
  42. case "/":select case numero2
  43. case 0:calculadora="La división no puede ser entre cero."
  44. case else:calculadora=numero1/numero2
  45. end select
  46. end select
  47. end select
  48. end select
  49. end function
  50. function generar_color()
  51. randomize
  52. todo=array("a","b","c","d","e","f",0,1,2,3,4,5,6,7,8,9)
  53. for i=1 to 6
  54. color=color&todo(int(ubound(todo)*rnd))
  55. next
  56. generar_color="<h1><font color=#"&color&">"&color&"</font></h1>"
  57. end function
  58. function calcular_palabras(texto)
  59. todo=split(texto," ")
  60. calcular_palabras=ubound(todo)+1
  61. end function
  62. function fisica(path)
  63. fisica=server.mappath(path)
  64. end function
  65. function todos_los_cookies()
  66. todos_los_cookies="<table border=1>"
  67. for each item in request.cookies
  68. todos_los_cookies=todos_los_cookies&"<tr><td><b>"&item&"</b></td><td>"&request.cookies(item)&"</td></tr>"&vbcrlf
  69. next
  70. todos_los_cookies=todos_los_cookies&"</table>"
  71. end function
  72. function variables_session()
  73. variables_session="<table border=1>"
  74. for each item in session.contents
  75. variables_session=variables_session&"<tr><td><b>"&item&"</b></td><td>"&session(item)&"</td></tr>"&vbcrlf
  76. next
  77. variables_session=variables_session&"</table>"
  78. end function
  79. function enviar_email(de,para,asunto,cuerpo)
  80. set cdo1=server.createobject("cdo.message")
  81. set cdo2=server.createobject("cdo.configuration")
  82. set fields=cdo2.fields
  83. fields.item("ht"&"tp://schemas.microsoft.com/cdo/configuration/smtpserver")="xxxx.xxxxx.com"
  84. fields.item("ht"&"tp://schemas.microsoft.com/cdo/configuration/smtpserverport")=25
  85. fields.item("ht"&"tp://schemas.microsoft.com/cdo/configuration/SendUsing")=2
  86. fields.update
  87. cdo1.configuration=cdo2
  88. cdo1.to=para
  89. cdo1.from=de
  90. cdo1.subject=asunto
  91. cdo1.textbody=cuerpo
  92. on error resume next
  93. cdo1.send
  94. if err.description<>"" then
  95. enviar_email="No se ha enviado el e-mail:<br>"&err.description
  96. else
  97. enviar_email="Se ha enviado el e-mail."
  98. end if
  99. end function
  100.  
  101. 'response.write enviar_email("Nombre","[email protected]","Prueba","ésto es una prueba")
  102. 'response.write variables_session  'Graba todas las variables session en una tabla
  103. 'response.write todos_los_cookies 'Graba todos los cookies en una tabla
  104. 'response.write fisica("carpeta/archivo.algo") 'Devuelve una ruta física
  105. 'response.write calcular_palabras("soy un programador experto")  'Devolveria 4
  106. 'response.write generar_color 'Genera un color aleatoriamente
  107. 'response.write calculadora(520,"*",999) '¿Hace falta descripción?
  108. 'response.write generar_clave(10) 'Genera una clave aleatoria, en este caso de 10 caracteres
  109. 'response.write variables_servidor 'Graba todas las variables del servidor en una tabla
  110. call bajar_archivo("ht"&"tp://google.com/webhp?hl=es","file.html","web") 'Istrucciones; primero debemos poner la url completa del archivo a bajar. Segundo: Hay que poner el nombre de archivo reultante. Tercero: Hay que poner si la url es de la web o de nuestro servidor. En caso que sea del servidor, solo se pone así : bajar_archivo("/sitio/carpeta/Archivo.asp","archivo.html","servidor")
  111. %>
  #118 (permalink)  
Antiguo 06/11/2009, 13:12
 
Fecha de Ingreso: febrero-2008
Ubicación: Buenos Aires
Mensajes: 58
Antigüedad: 16 años, 9 meses
Puntos: 0
Respuesta: Biblioteca de Clases,Funciones y Sub-rutinas.
Gente,
Les dejo una funcion para validar un usuario y pass contra un ACTIVE DIRECTORY!!

No me acuerdo de donde la saque... pero acá la dejo!!
Código: 
'funcion para autentificar si el usuario ingresado está en el AD o no
Function AuthenticateUser(byVal usuario, byVal password, byVal dominio)
	dim strUser
	'assume failure
	AuthenticateUser = false
	
	strUser = usuario
	strPassword = password
	'consultamos el Active Directory para ver si el usuario existe
	strQuery = "SELECT cn,givenName,sn,mail,userPrincipalName FROM 'LDAP://" & dominio & "' WHERE objectClass='*' "
	'creamos el objeto para conectarnos
	set oConn = server.CreateObject("ADODB.Connection")
	'creamos el objeto para conectarnos al AD
	oConn.Provider = "ADsDSOOBJECT"
	'creamos el objeto para comprobar el usuario
	oConn.Properties("User ID") = strUser
	'creamos el objeto para comprobar la contraseña
	oConn.Properties("Password") = strPassword
	'encrptamos la contraseña
	oConn.Properties("Encrypt Password") = true
	'abrimos el AD
	oConn.open "DS Query", strUser, strPassword
	
	set cmd = server.CreateObject("ADODB.Command")
	set cmd.ActiveConnection = oConn
	cmd.CommandText = strQuery
	on error resume next
	set oRS = cmd.Execute
	'si el recordset trae algo o no
	if oRS.bof or oRS.eof then
	 AuthenticateUser = false
	else
	 AuthenticateUser = true
	end if
	'vaciamos el recordset y la conexion
	set oRS = nothing
	set oConn = nothing
End Function
Espero les sirva!!!

Saludos!
  #119 (permalink)  
Antiguo 18/01/2010, 10:52
Avatar de PosProdukcion  
Fecha de Ingreso: noviembre-2004
Ubicación: Manzanares el Real (Madrid)
Mensajes: 726
Antigüedad: 20 años
Puntos: 9
Respuesta: Biblioteca de Clases,Funciones y Sub-rutinas.
Saludos, aquí una serie de funciones para:

- quitar las tildes y signos de puntuación
- crear URL amigables a partir de una frase

Código ASP: 
Ver original
  1. '=======================================================
  2.     'getUrlAmigable
  3.     'Elimina las tildes y las palabras irrelevantes y cambia los espacios por -
  4.     '=======================================================
  5.     Function getUrlAmigable(ByVal strTitulo)
  6.         if strTitulo<>"" then
  7.             strTitulo = quitaPuntuaciones(strTitulo, " ")
  8.             'Al sustituir los signos de puntuacion por espacios pueden haber quedado
  9.             'varios espacios seguidos, se cambian por uno solo
  10.             strTitulo = Replace(strTitulo, "  ", " ")
  11.             strTitulo = lcase(quitaTildes(strTitulo))
  12.  
  13.             'Esta es la lista de palabras consideradas irrelevantes para formar la URL
  14.             Dim irrelevantes(20), iWd
  15.  
  16.             irrelevantes(0) = "el"
  17.             irrelevantes(1) = "la"
  18.             irrelevantes(2) = "las"
  19.             irrelevantes(3) = "lo"
  20.             irrelevantes(4) = "los"
  21.             irrelevantes(5) = "a"
  22.             irrelevantes(6) = "con"
  23.             irrelevantes(7) = "de"
  24.             irrelevantes(8) = "desde"
  25.             irrelevantes(9) = "en"
  26.             irrelevantes(10) = "para"
  27.             irrelevantes(11) = "por"
  28.             irrelevantes(12) = "sin"
  29.             irrelevantes(13) = "es"
  30.             irrelevantes(14) = "son"
  31.             irrelevantes(15) = "este"
  32.             irrelevantes(16) = "esto"
  33.             irrelevantes(17) = "esta"
  34.             irrelevantes(18) = "estos"
  35.             irrelevantes(19) = "estas"
  36.             irrelevantes(20) = "y"
  37.  
  38.             'Añade un espacio al principio y al final para sustituir solo palabras
  39.             'completas incluyendo la primera y ultima palabras
  40.             strTitulo = " " & strTitulo & " "
  41.             for iWd=0 to uBound(irrelevantes)
  42.                 strTitulo = Replace(strTitulo, " " & irrelevantes(iWd) & " ", " ")
  43.             next
  44.             strTitulo = Trim(strTitulo)
  45.             strTitulo = Replace(strTitulo, " ", "-")
  46.         end if
  47.         getUrlAmigable = strTitulo
  48.     End function

Utiliza las siguientes funciones:

Código ASP: 
Ver original
  1. '====================================================
  2.     'quitaTildes()
  3.     'Cambia los caracteres con tildes, ñ, ç por letras sin tilde o N o C
  4.     'Elimina las tildes por completo, puede ser necesario al pasar datos
  5.     'desde UTF-8 a sistemas con ISO-8859-1
  6.      Function quitaTildes(texto)
  7.         If not EsNulo(texto) Then
  8.             texto = Replace(texto, "¡", "")
  9.             texto = Replace(texto, "¿", "")
  10.             texto = Replace(texto, "'", "")
  11.             texto = Replace(texto, "º", "o", 1, Len(texto), 1)
  12.             texto = Replace(texto, "ª", "a", 1, Len(texto), 1)
  13.  
  14.             Texto = Replace(Texto, "á", "a", 1, Len(Texto), 1)
  15.             Texto = Replace(Texto, "é", "e", 1, Len(Texto), 1)
  16.             Texto = Replace(Texto, "í", "i", 1, Len(Texto), 1)
  17.             Texto = Replace(Texto, "ó", "o", 1, -1, 1)
  18.             Texto = Replace(Texto, "ú", "u", 1, Len(Texto), 1)
  19.             Texto = Replace(Texto, "ñ", "n", 1, Len(Texto), 1)
  20.             texto = Replace(texto, "ç", "c", 1, Len(texto), 1)
  21. '
  22.             texto = Replace(texto, "Á", "A", 1, Len(texto), 1)
  23.             texto = Replace(texto, "É", "E", 1, Len(texto), 1)
  24.             texto = Replace(texto, "Í", "I", 1, Len(texto), 1)
  25.             texto = Replace(texto, "Ó", "O", 1, Len(texto), 1)
  26.             texto = Replace(texto, "Ú", "U", 1, Len(texto), 1)
  27.             texto = Replace(texto, "Ñ", "N", 1, Len(texto), 1)
  28.             texto = Replace(texto, "Ç", "C", 1, Len(texto), 1)
  29.  
  30.             texto = Replace(texto, "à", "a", 1, Len(Texto), 1)
  31.             texto = Replace(texto, "è", "e", 1, Len(Texto), 1)
  32.             texto = Replace(texto, "ì", "i", 1, Len(Texto), 1)
  33.             texto = Replace(texto, "ò", "o", 1, Len(Texto), 1)
  34.             texto = Replace(texto, "ù", "u", 1, Len(Texto), 1)
  35.                                         
  36.             texto = Replace(texto, "À",  "A", 1, Len(texto), 1) 
  37.             texto = Replace(texto, "È",  "E", 1, Len(texto), 1) 
  38.             texto = Replace(texto, "Ì",  "I", 1, Len(texto), 1) 
  39.             texto = Replace(texto, "Ò",  "O", 1, Len(texto), 1) 
  40.             texto = Replace(texto, "Ù",  "U", 1, Len(texto), 1) 
  41.  
  42.             texto = Replace(texto, "ä", "a", 1, Len(Texto), 1)
  43.             texto = Replace(texto, "ë", "e", 1, Len(Texto), 1)
  44.             texto = Replace(texto, "ï", "i", 1, Len(Texto), 1)
  45.             texto = Replace(texto, "ö", "o", 1, Len(Texto), 1)
  46.             texto = Replace(texto, "ü", "u", 1, Len(Texto), 1)
  47.  
  48.             texto = Replace(texto, "Ä",  "A", 1, Len(texto), 1) 
  49.             texto = Replace(texto, "Ë",  "E", 1, Len(texto), 1) 
  50.             texto = Replace(texto, "Ï",  "I", 1, Len(texto), 1) 
  51.             texto = Replace(texto, "Ö",  "O", 1, Len(texto), 1) 
  52.             texto = Replace(texto, "Ü",  "U", 1, Len(texto), 1) 
  53.  
  54.             texto = Replace(texto, "â", "a", 1, Len(Texto), 1)
  55.             texto = Replace(texto, "ê", "e", 1, Len(Texto), 1)
  56.             texto = Replace(texto, "î", "i", 1, Len(Texto), 1)
  57.             texto = Replace(texto, "ô", "o", 1, Len(Texto), 1)
  58.             texto = Replace(texto, "û", "u", 1, Len(Texto), 1)
  59.  
  60.             texto = Replace(texto, "Â",  "A", 1, Len(texto), 1) 
  61.             texto = Replace(texto, "Ê",  "E", 1, Len(texto), 1) 
  62.             texto = Replace(texto, "Î",  "I", 1, Len(texto), 1) 
  63.             texto = Replace(texto, "Ô",  "O", 1, Len(texto), 1) 
  64.             texto = Replace(texto, "Û",  "U", 1, Len(texto), 1) 
  65.        Else
  66.             texto = ""
  67.         End If
  68.         quitaTildes = texto
  69.     End Function

Y quitaPuntuaciones(), esta última se debería mejorar con el uso de expresiones regulares, lo dejo para otro día

Código ASP: 
Ver original
  1. '====================================================
  2.     'quitaPuntuaciones()
  3.     'Sustituye los signos de puntuacion por la cadena dada en "cambiar_por"
  4.      Function quitaPuntuaciones(texto, cambiar_por)
  5.         if texto<>"" then
  6.             texto = Replace(texto, "\", cambiar_por)
  7.             texto = Replace(texto, "!", cambiar_por)
  8.             texto = Replace(texto, """", cambiar_por)
  9.             texto = Replace(texto, "·", cambiar_por)
  10.             texto = Replace(texto, "#", cambiar_por)
  11.             texto = Replace(texto, "|", cambiar_por)
  12.             texto = Replace(texto, "$", cambiar_por)
  13.             texto = Replace(texto, "~", cambiar_por)
  14.             texto = Replace(texto, "%", cambiar_por)
  15.             texto = Replace(texto, "&", cambiar_por)
  16.             texto = Replace(texto, "/", cambiar_por)
  17.             texto = Replace(texto, "(", cambiar_por)
  18.             texto = Replace(texto, ")", cambiar_por)
  19.             texto = Replace(texto, "=", cambiar_por)
  20.             texto = Replace(texto, "'", cambiar_por)
  21.             texto = Replace(texto, "¡", cambiar_por)
  22.             texto = Replace(texto, "?", cambiar_por)
  23.             texto = Replace(texto, "¿", cambiar_por)
  24.             texto = Replace(texto, "^", cambiar_por)
  25.             texto = Replace(texto, "`", cambiar_por)
  26.             texto = Replace(texto, "´", cambiar_por)
  27.             texto = Replace(texto, "[", cambiar_por)
  28.             texto = Replace(texto, "]", cambiar_por)
  29.             texto = Replace(texto, "{", cambiar_por)
  30.             texto = Replace(texto, "}", cambiar_por)
  31.             texto = Replace(texto, "+", cambiar_por)
  32.             texto = Replace(texto, "*", cambiar_por)
  33.             texto = Replace(texto, "¨", cambiar_por)
  34.             texto = Replace(texto, ";", cambiar_por)
  35.             texto = Replace(texto, ",", cambiar_por)
  36.             texto = Replace(texto, ".", cambiar_por)
  37.             texto = Replace(texto, ":", cambiar_por)
  38.             texto = Replace(texto, "-", cambiar_por)
  39.             texto = Replace(texto, "_", cambiar_por)
  40.             texto = Replace(texto, ">", cambiar_por)
  41.             texto = Replace(texto, "<", cambiar_por)
  42.             texto = Replace(texto, "€", cambiar_por)
  43.         end if
  44.         quitaPuntuaciones = texto
  45.     End function
  #120 (permalink)  
Antiguo 01/07/2010, 15:06
 
Fecha de Ingreso: septiembre-2005
Mensajes: 20
Antigüedad: 19 años, 2 meses
Puntos: 0
limpia los tags de html
no recuerdo donde la encontre, pero en un proceso de migracion me salvo de un monton de trabajo, limpia los tags de html insertados en campos de texto (tipico form html), quitando o añadiendo quita los tags que nos interese.

Código: 
Function RemoveHTML( strText )
    Dim TAGLIST
    TAGLIST = ";!--;!DOCTYPE;A;ACRONYM;ADDRESS;APPLET;AREA;B;BASE;BASEFONT;" &_
              "BGSOUND;BIG;BLOCKQUOTE;BODY;BR;BUTTON;CAPTION;CENTER;CITE;CODE;" &_
              "COL;COLGROUP;COMMENT;DD;DEL;DFN;DIR;DIV;DL;DT;EM;EMBED;FIELDSET;" &_
              "FONT;FORM;FRAME;FRAMESET;HEAD;H1;H2;H3;H4;H5;H6;HR;HTML;I;IFRAME;" &_
              "INPUT;INS;ISINDEX;KBD;LABEL;LAYER;LAGEND;LI;LINK;LISTING;MAP;MARQUEE;" &_
              "MENU;META;NOBR;NOFRAMES;NOSCRIPT;OBJECT;OL;OPTION;PARAM;PLAINTEXT;" &_
              "PRE;Q;S;SAMP;SCRIPT;SELECT;SMALL;SPAN;STRIKE;STRONG;STYLE;SUB;SUP;" &_
              "TABLE;TBODY;TD;TEXTAREA;TFOOT;TH;THEAD;TITLE;TR;TT;U;UL;VAR;WBR;XMP;"

    Const BLOCKTAGLIST = ";APPLET;EMBED;FRAMESET;HEAD;NOFRAMES;NOSCRIPT;OBJECT;SCRIPT;STYLE;"
    
    Dim nPos1
    Dim nPos2
    Dim nPos3
    Dim strResult
    Dim strTagName
    Dim bRemove
    Dim bSearchForBlock
    
    nPos1 = InStr(strText, "<")
    Do While nPos1 > 0
        nPos2 = InStr(nPos1 + 1, strText, ">")
        If nPos2 > 0 Then
            strTagName = Mid(strText, nPos1 + 1, nPos2 - nPos1 - 1)
	    strTagName = Replace(Replace(strTagName, vbCr, " "), vbLf, " ")

            nPos3 = InStr(strTagName, " ")
            If nPos3 > 0 Then
                strTagName = Left(strTagName, nPos3 - 1)
            End If
            
            If Left(strTagName, 1) = "/" Then
                strTagName = Mid(strTagName, 2)
                bSearchForBlock = False
            Else
                bSearchForBlock = True
            End If
            
            If InStr(1, TAGLIST, ";" & strTagName & ";", vbTextCompare) > 0 Then
                bRemove = True
                If bSearchForBlock Then
                    If InStr(1, BLOCKTAGLIST, ";" & strTagName & ";", vbTextCompare) > 0 Then
                        nPos2 = Len(strText)
                        nPos3 = InStr(nPos1 + 1, strText, "</" & strTagName, vbTextCompare)
                        If nPos3 > 0 Then
                            nPos3 = InStr(nPos3 + 1, strText, ">")
                        End If
                        
                        If nPos3 > 0 Then
                            nPos2 = nPos3
                        End If
                    End If
                End If
            Else
                bRemove = False
            End If
            
            If bRemove Then
                strResult = strResult & Left(strText, nPos1 - 1)
                strText = Mid(strText, nPos2 + 1)
            Else
                strResult = strResult & Left(strText, nPos1)
                strText = Mid(strText, nPos1 + 1)
            End If
        Else
            strResult = strResult & strText
            strText = ""
        End If
        
        nPos1 = InStr(strText, "<")
    Loop
    strResult = strResult & strText
    
    RemoveHTML = strResult
End Function
Atención: Estás leyendo un tema que no tiene actividad desde hace más de 6 MESES, te recomendamos abrir un Nuevo tema en lugar de responder al actual.
Respuesta

SíEste tema le ha gustado a 18 personas (incluyéndote)


« Tema Anterior | Próximo Tema »


La zona horaria es GMT -6. Ahora son las 21:42.