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. <% 'Base de datos en oracle con dsn Dim MM_orafin_STRING MM_orafin_STRING = "dsn=mibasededatos;uid=miuid;pwd=mipass;" %> <% 'No se olvide crear la conexion con el string 'Ojo ...

  #61 (permalink)  
Antiguo 04/04/2005, 09:43
 
Fecha de Ingreso: septiembre-2004
Mensajes: 66
Antigüedad: 19 años, 5 meses
Puntos: 0
craear tabla, buscar, insertar, borrar, con Recordsets

<%
'Base de datos en oracle con dsn
Dim MM_orafin_STRING
MM_orafin_STRING = "dsn=mibasededatos;uid=miuid;pwd=mipass;"
%>
<%
'No se olvide crear la conexion con el string
'Ojo que pueden existir mas de una columnas por lo tanto columnasydatos es un array que contiene
'el nombre de la columna y el dato ejm
' Si una tabla en la base de datos tiene 2 columnas FECHA y DATO
'el array seria definico asi Dim columnasydatos(1)(1)
'donde la primera fila del array seria para la FECHA y su valor que sequiere ingresar
'columnasydatos(0,0) = "FECHA" columnasydatos(0,1) = '12/12/2001'
'y la segunda fila del array seria para el DATO y su valor que se quiere ingresar
'columnasydatos(1,0) "DATO" = columnasydatos(1,1) = 50
'Se pueden crear array mas grandes
FUNCTION InsertarDatosTabla(nombretabla , columnasydatos )
Dim RecInsertar
Dim columna
Set RecInsertar = Server.CreateObject("ADODB.Recordset")
RecInsertar.ActiveConnection = MM_orafin_STRING
RecInsertar.Source = "SELECT * FROM " & nombretabla
RecInsertar.CursorType = 0
RecInsertar.CursorLocation = 2
RecInsertar.LockType = 3
RecInsertar.Open()
RecInsertar.AddNew
Dim conttemp
for contfil = 0 to Ubound(columnasydatos,1)
conttemp = 0
for contcol = 0 to Ubound(columnasydatos,2)
conttemp = conttemp + 1
columna = columnasydatos(contfil,contcol)
dato = columnasydatos(contfil,conttemp)
contcol = Ubound(columnasydatos,2)
RecInsertar(columna) = dato
next
next
RecInsertar.Update
RecInsertar.Close()
Set RecInsertar = Nothing
END FUNCTION
FUNCTION BorrarDatosTabla(tabla , columna , datos)
Dim RecBorrar
Set RecBorrar = Server.CreateObject("ADODB.Recordset")
RecBorrar.ActiveConnection = MM_orafin_STRING
RecBorrar.Source = "SELECT * FROM " & tabla & " WHERE " & columna & "= '" & datos & "' " & " ORDER BY " & columna & " ASC"
RecBorrar.CursorType = 0
RecBorrar.CursorLocation = 2
RecBorrar.LockType = 3
RecBorrar.Open()
'Nos movemos a la primera posición
RecBorrar.MoveFirst
'Borramos
RecBorrar.Delete
'Guardamos los cambios
RecBorrar.Update
RecBorrar.Close()
Set RecBorrar = Nothing
END FUNCTION

FUNCTION BuscarDatosTabla(tabla , columna , datos)
Dim RecBuscar
Dim datobuscado
Set RecBuscar = Server.CreateObject("ADODB.Recordset")
RecBuscar.ActiveConnection = MM_orafin_STRING
RecBuscar.Source = "SELECT * FROM " & tabla & " WHERE " & columna & "= '" & datos & "' " & " ORDER BY " & columna & " ASC"
RecBuscar.CursorType = 0
RecBuscar.CursorLocation = 2
RecBuscar.LockType = 3
RecBuscar.Open()
IF RecBuscar.EOF THEN
'"NO SE ENCONTRO NADA" TAMBIEN SE PODIA HABER HECHO ASI Y SE QUITABA EL "ELSE" :
'NOT RecBuscar.EOF
ELSE
'Aqui se guarda el dato buscado
datobuscado = RecBuscar.Fields.Item(columna).Value
END IF
RecBuscar.Close()
Set RecBuscar = Nothing
BuscarDatosTabla = datobuscado
END FUNCTION

FUNCTION CrearTabla(Nombretabla)

Dim RecCreaTabla
'Se crea un recordset
Set RecCreaTabla = Server.CreateObject("ADODB.Recordset")
'Se asocia el recordset a la base de datos con el string
RecCreaTabla.ActiveConnection = MM_orafin_STRING
'Se crea una consulta en SQL ejem SELECT, CREATE, etc
RecCreaTabla.Source = "CREATE TABLE " & Nombretabla & " (FECHA DATE NULL, CANTACCIONES NUMBER NULL, VOLUMEN NUMBER NULL, PRECIOMAX NUMBER NULL, PRECIOMIN NUMBER NULL, PRECIOCIERRE NUMBER NULL)"
'Dejar esto por defecto 0
RecCreaTabla.CursorType = 0
'Cursor: 2 Server, 1 Cliente dejar por defecto 2
RecCreaTabla.CursorLocation = 2
'Opcion 3 Optimistic que no es solo lectura
RecCreaTabla.LockType = 3
'Se abre o se realiza la consulta
RecCreaTabla.Open()
END FUNCTION


%>



espero que les sirva de algo una pequeña contribución porque sus funciones me sirvieron mucho gracias
  #62 (permalink)  
Antiguo 06/04/2005, 11:00
Avatar de pablinweb  
Fecha de Ingreso: julio-2003
Mensajes: 283
Antigüedad: 20 años, 8 meses
Puntos: 0
Importe a letras

Código:
<%
Function ImporteEnLetras(pImporte, pSepDecimal, pCharPorLinea, pDesMoneda, pDesCentavos, pDecimalesEnNumeros, pLeyenda)

Dim tmpEntero(9)
Dim tmpDecimal(2)
Dim tmpImporteEnLetras
Dim tmpLetrasFinal
Dim tmpEsDecimal
Dim tmpImporte
Dim tmpEnteros
Dim tmpDecimales
Dim tmpChar
Dim i
Dim tmpLargoImporte
Dim tmpLargoEnteros
Dim tmpPosicion
Dim tmpDigito
Dim tmpCantChar
Dim tmpPalabra

ImporteEnLetras = ""

tmpImporteEnLetras = ""
tmpLetrasFinal = ""
tmpImporte = Trim(pImporte)
tmpEsDecimal = False
tmpEnteros = ""
tmpDecimales = ""

For i = 1 To Len(tmpImporte)
  tmpChar = Mid(tmpImporte, i, 1)
  If tmpChar <> pSepDecimal And (Asc(tmpChar) < 48 Or Asc(tmpChar) > 57) Then
    Exit Function
  End If
Next

For i = 1 To 9
  tmpEntero(i) = "0"
Next

tmpLargoImporte = Len(tmpImporte)

For tmpPosicion = 1 To tmpLargoImporte
  tmpChar = Mid(tmpImporte, tmpPosicion, 1)
  If tmpChar = pSepDecimal Then
    tmpEsDecimal = True
  Else
    If tmpEsDecimal = True Then
      tmpDecimales = tmpDecimales + tmpChar
    Else
      tmpEnteros = tmpEnteros + tmpChar
    End If
  End If
Next

tmpDecimales = Left(tmpDecimales + "00", 2)
tmpLargoEnteros = Len(tmpEnteros)

For tmpDigito = tmpLargoEnteros To 1 Step -1
  tmpEntero(tmpDigito) = Mid(tmpEnteros, (tmpLargoEnteros - tmpDigito + 1), 1)
Next

If (tmpEntero(9) <> "0" Or tmpEntero(8) <> "0" Or tmpEntero(7) <> "0") Then
  tmpImporteEnLetras = tmpImporteEnLetras + ConvierteLetras(tmpEntero(9), tmpEntero(8), tmpEntero(7))
  If (tmpEntero(9) = "0" And tmpEntero(8) = "0" And tmpEntero(7) = "1") Then
    tmpImporteEnLetras = tmpImporteEnLetras + "millon "
  Else
    tmpImporteEnLetras = tmpImporteEnLetras + "millones "
  End If
End If

If (tmpEntero(6) <> "0" Or tmpEntero(5) <> "0" Or tmpEntero(4) <> "0") Then
  If (tmpEntero(6) = "0" And tmpEntero(5) = "0" And tmpEntero(4) = "1") Then
  Else
    tmpImporteEnLetras = tmpImporteEnLetras + ConvierteLetras(tmpEntero(6), tmpEntero(5), tmpEntero(4))
  End If
  tmpImporteEnLetras = tmpImporteEnLetras + "mil "
End If

tmpImporteEnLetras = tmpImporteEnLetras + ConvierteLetras(tmpEntero(3), tmpEntero(2), tmpEntero(1))
If tmpEntero(1) = "1" Then tmpImporteEnLetras = Left(tmpImporteEnLetras, Len(tmpImporteEnLetras) - 1) + "o "

If tmpImporteEnLetras = "" Then tmpImporteEnLetras = "cero "
If pDecimalesEnNumeros = True Then
   tmpImporteEnLetras = tmpImporteEnLetras + pDesMoneda + " con " + tmpDecimales + "/100 " + pDesCentavos
Else
   tmpDecimal(1) = Mid(tmpDecimales, 1, 1)
   tmpDecimal(2) = Mid(tmpDecimales, 2, 1)
   tmpImporteEnLetras = tmpImporteEnLetras + pDesMoneda + " con " + ConvierteLetras("0", tmpDecimal(1), tmpDecimal(2)) + pDesCentavos
End If

tmpImporteEnLetras = RTrim(tmpImporteEnLetras)

If Len(tmpImporteEnLetras) <= pCharPorLinea Then
  tmpLetrasFinal = tmpImporteEnLetras
Else
  tmpCantChar = 0
  tmpPalabra = ""
  For i = 1 To Len(tmpImporteEnLetras)
    tmpCantChar = tmpCantChar + 1
    tmpChar = Mid(tmpImporteEnLetras, i, 1)
    If tmpChar = " " Then
      tmpLetrasFinal = tmpLetrasFinal + tmpPalabra
      tmpPalabra = ""
      If tmpCantChar < pCharPorLinea Then tmpLetrasFinal = tmpLetrasFinal + tmpChar
    Else
      tmpPalabra = tmpPalabra + tmpChar
    End If
    If tmpCantChar > pCharPorLinea Then
      tmpCantChar = Len(tmpPalabra)
      
    If gCHARLINE Then
      tmpLetrasFinal = tmpLetrasFinal & vbCrLf
    Else
      tmpLetrasFinal = tmpLetrasFinal + Chr(10)
    End If

    End If
  Next
  tmpLetrasFinal = tmpLetrasFinal + tmpPalabra
End If

If pLeyenda = "" Then
    ImporteEnLetras = UCase(tmpLetrasFinal)
Else
    ImporteEnLetras = UCase(tmpLetrasFinal & " " & pLeyenda)
End If

End Function
Function ConvierteLetras(pDigito3, pDigito2, pDigito1)

Dim tmpLetras

ConvierteLetras = ""
tmpLetras = ""

Select Case pDigito3
  Case "0"
  Case "1"
    If pDigito2 = "0" And pDigito1 = "0" Then
      tmpLetras = tmpLetras + "cien "
    Else
      tmpLetras = tmpLetras + "ciento "
    End If
  Case "2"
    tmpLetras = tmpLetras + "doscientos "
  Case "3"
    tmpLetras = tmpLetras + "trescientos "
  Case "4"
    tmpLetras = tmpLetras + "cuatrocientos "
  Case "5"
    tmpLetras = tmpLetras + "quinientos "
  Case "6"
    tmpLetras = tmpLetras + "seiscientos "
  Case "7"
    tmpLetras = tmpLetras + "setecientos "
  Case "8"
    tmpLetras = tmpLetras + "ochocientos "
  Case "9"
    tmpLetras = tmpLetras + "novecientos "
  Case Else
    Exit Function
End Select

Select Case pDigito2
  Case "0"
  Case "1"
    Select Case pDigito1
      Case "0"
        tmpLetras = tmpLetras + "diez "
      Case "1"
        tmpLetras = tmpLetras + "once "
      Case "2"
        tmpLetras = tmpLetras + "doce "
      Case "3"
        tmpLetras = tmpLetras + "trece "
      Case "4"
        tmpLetras = tmpLetras + "catorce "
      Case "5"
        tmpLetras = tmpLetras + "quince "
      Case "6"
        tmpLetras = tmpLetras + "dieciseis "
      Case "7"
        tmpLetras = tmpLetras + "diecisiete "
      Case "8"
        tmpLetras = tmpLetras + "dieciocho "
      Case "9"
        tmpLetras = tmpLetras + "diecinueve "
      Case Else
        Exit Function
    End Select
  Case "2"
    If pDigito1 = "0" Then
      tmpLetras = tmpLetras + "veinte "
    Else
      tmpLetras = tmpLetras + "veinti"
    End If
  Case "3"
    tmpLetras = tmpLetras + "treinta "
  Case "4"
    tmpLetras = tmpLetras + "cuarenta "
  Case "5"
    tmpLetras = tmpLetras + "cincuenta "
  Case "6"
    tmpLetras = tmpLetras + "sesenta "
  Case "7"
    tmpLetras = tmpLetras + "setenta "
  Case "8"
    tmpLetras = tmpLetras + "ochenta "
  Case "9"
    tmpLetras = tmpLetras + "noventa "
  Case Else
    Exit Function
End Select
If cdbl(pDigito2) >= 3 And pDigito1 <> "0" Then tmpLetras = tmpLetras + "y "

If pDigito2 <> "1" Then
  Select Case pDigito1
    Case "0"
    Case "1"
      tmpLetras = tmpLetras + "un "
    Case "2"
      tmpLetras = tmpLetras + "dos "
    Case "3"
      tmpLetras = tmpLetras + "tres "
    Case "4"
      tmpLetras = tmpLetras + "cuatro "
    Case "5"
      tmpLetras = tmpLetras + "cinco "
    Case "6"
      tmpLetras = tmpLetras + "seis "
    Case "7"
      tmpLetras = tmpLetras + "siete "
    Case "8"
      tmpLetras = tmpLetras + "ocho "
    Case "9"
      tmpLetras = tmpLetras + "nueve "
    Case Else
      Exit Function
  End Select
End If

ConvierteLetras = tmpLetras

End Function
%>
para llamarla:

tmp = 1234.45
tmp = ImporteEnLetras(tmp, ".", 100, "PESOS", "CENTAVOS", false, "")
response.Write(tmp)


Definición:

pImporte: Monto
pSepDecimal: Separeción de decimales ("," o ".")
pCharPorLinea: Caracteres por linea para que no se salga del ancho requerido
pDesMoneda: Descripción de la moneda ("PESOS", "DOLARES ESTADOUNIDENSES", "EUROS", etc)
pDesCentavos: Descripción de los centavos ("CENTAVOS", "CENTS", etc)
pDecimalesEnNumeros: true = pone los decimales en números ej:12/100. false los pone en letras
pLeyenda: leyenda final que se le puede agregar o no al texto por ejemplo en Mexico se usa "M.N." de moneda nacional

Espero les sea útil...
Si alguien se copa podrian adaptarla para que se pueda elegir el idioma porque hay casos en los que si son dolares te lo piden en ingles.

Última edición por pablinweb; 06/04/2005 a las 11:03
  #63 (permalink)  
Antiguo 25/04/2005, 12:10
Avatar de Saruman  
Fecha de Ingreso: mayo-2003
Ubicación: Panama city, Panama, Panama
Mensajes: 1.154
Antigüedad: 20 años, 10 meses
Puntos: 5
Calcular la Edad de algo

Hola... esta función calcula la edad de una persona o algo....
Utilizacion:
fecha_nacimiento = "09/10/1981"
edad = Age(fecha_nacimiento)

response.write(edad & " años.")

Resultado: 23 años.


Código:
Function Age(strBirthDate)
	If IsNull(strBirthDate) then Age = 0: Exit Function
	
	varAge = DateDiff("yyyy", strBirthDate, Now)
	If Date < DateSerial(Year(Now), Month(strBirthDate), Day(strBirthDate)) Then
		varAge = varAge - 1
	End If
	Age = CInt(varAge)
End Function
__________________
Saruman

One Ring to rule them all, One Ring to find them, One Ring to bring them all and in the darkness bind them.
  #64 (permalink)  
Antiguo 25/04/2005, 12:15
Avatar de Saruman  
Fecha de Ingreso: mayo-2003
Ubicación: Panama city, Panama, Panama
Mensajes: 1.154
Antigüedad: 20 años, 10 meses
Puntos: 5
Signo Zodiacal

Saber el signo zodiacal de alguien...

Utilización:

fecha_nacimiento = "09/10/1981"
mi_signo = PutSignoZodiacal(fecha_nacimiento)

response.write("Mi Signo Zodiacal es: " & mi_signo)

Resultado: Mi Signo Zodiacal es: Virgo

Código:
Function PutSignoZodiacal(strFechaNacimiento)
	strDia = day(strFechaNacimiento)
	strMes = month(strFechaNacimiento)
		
	select case strMes
		case 1
			if strDia <= 19 then strSigno = "Capricornio"
			if strDia >= 20 then strSigno = "Acuario"
		case 2
			if strDia <= 18 then strSigno = "Acuario"
			if strDia >= 19 then strSigno = "Piscis"
		case 3
			if strDia <= 20 then strSigno = "Piscis"
			if strDia >= 21 then strSigno = "Aries"
		case 4
			if strDia <= 20 then strSigno = "Aries"
			if strDia >= 21 then strSigno = "Tauro"
		case 5
			if strDia <= 20 then strSigno = "Tauro"
			if strDia >= 21 then strSigno = "Geminis"
		case 6
			if strDia <= 21 then strSigno = "Geminis"
			if strDia >= 22 then strSigno = "C&aacute;ncer"
		case 7
			if strDia <= 22 then strSigno = "C&aacute;ncer"
			if strDia >= 23 then strSigno = "Leo"
		case 8
			if strDia <= 22 then strSigno = "Leo"
			if strDia >= 23 then strSigno = "Virgo"
		case 9
			if strDia <= 22 then strSigno = "Virgo"
			if strDia >= 23 then strSigno = "Libra"
		case 10
			if strDia <= 22 then strSigno = "Libra"
			if strDia >= 23 then strSigno = "Escorpion"
		case 11
			if strDia <= 21 then strSigno = "Escorpion"
			if strDia >= 22 then strSigno = "Sagitario"
		case 12
			if strDia <= 21 then strSigno = "Sagitario"
			if strDia >= 22 then strSigno = "Capricornio"
		case else
			strSigno = ""
	end select
		
	PutSignoZodiacal = strSigno
End Function
__________________
Saruman

One Ring to rule them all, One Ring to find them, One Ring to bring them all and in the darkness bind them.
  #65 (permalink)  
Antiguo 25/04/2005, 12:25
Avatar de Saruman  
Fecha de Ingreso: mayo-2003
Ubicación: Panama city, Panama, Panama
Mensajes: 1.154
Antigüedad: 20 años, 10 meses
Puntos: 5
Calcular el Raiting

Esta función permite culcular el raiting de un producto, artículo o lo que queramos valorar... ESTILO AMAZON.COM

Utilización:

voto1 = 2
voto2 = 3
voto3 = 1
voto4 = 6
voto5 = 8

Total de votos = 20

total = RateIt(voto1, voto2, voto3, voto4, voto5)

response.write(total)

Resultado: 4

<img src="estrella_<%=(total)%>.gif" border="0">


Código:
Function RateIt(strEstrella1, strEstrella2, strEstrella3, strEstrella4, strEstrella5)
	strFullEstrella = 0
	strTotal_Estrellas = strEstrella1 + strEstrella2 + strEstrella3 + strEstrella4 + strEstrella5
	if strEstrella1 > 0 then strEstrella1 = strEstrella1 * 1
	if strEstrella2 > 0 then strEstrella2 = strEstrella2 * 2
	if strEstrella3 > 0 then strEstrella3 = strEstrella3 * 3
	if strEstrella4 > 0 then strEstrella4 = strEstrella4 * 4
	if strEstrella5 > 0 then strEstrella5 = strEstrella5 * 5
		
	if strTotal_Estrellas > 0 then
		strFullEstrella = (strEstrella1 + strEstrella2 + strEstrella3 + strEstrella4 + strEstrella5) / strTotal_Estrellas
		strFullEstrella = round(strFullEstrella,0)
		if strFullEstrella > 5 then strFullEstrella = 5
	end if
		
	RateIt = strFullEstrella
End Function
__________________
Saruman

One Ring to rule them all, One Ring to find them, One Ring to bring them all and in the darkness bind them.

Última edición por Saruman; 03/05/2005 a las 10:28
  #66 (permalink)  
Antiguo 29/04/2005, 09:20
Avatar de Muzztein  
Fecha de Ingreso: agosto-2002
Ubicación: Hangar 18
Mensajes: 1.703
Antigüedad: 21 años, 7 meses
Puntos: 16
estas sonviejas

Un par de funciones viejas mas refinadas


Esta funcion da la opcion de checar por la existencia de una variable, segun un tipo de dato requerido, en el caso de que no cumpla con la regla a validar, asigna un valor por defecto.

Código:
function checa_cadena(cadena,tipo_de_dato_a_chequear,valor_por_defecto)

	'tipo_de_dato_a_chequear = 0 cadena deberia ser una cadena de largo no igual a cero
	'tipo_de_dato_a_chequear = 1 cadena deberia ser numerico
	'tipo_de_dato_a_chequear = 2 cadena deberia ser fecha
	
	Select Case tipo_de_dato_a_chequear
    Case 0
		if len(cadena) = 0 then
			salida = valor_por_defecto
		else
			salida = cstr(cadena)
		end if
	Case 1
		if isnumeric(cadena) = false then
			salida = valor_por_defecto
		else
			salida = cadena
		end if
	Case 2
		if isdate(cadena) = false then
			salida = valor_por_defecto
		else
			salida = cadena
		end if
    Case Else 
		salida = cadena 
	End Select

	checa_cadena = salida

end function

Esta funcion unifica los modos de limpiar que puede presentar una variable.
permitiendo anexar mas formas de limpiar una cadena.

Código:
function limpia_cadena(str_a_limpiar,modo_de_limpiar)

	'modo_de_limpiar = 0 prepara str_a_limpiar para insert 
	'modo_de_limpiar = 1 Prepara str_a_limpiar para insert evitando, ademas, la entrada de HTML
	'modo_de_limpiar = 2 Prepara str_a_limpiar para un login y evita sql injection
	
	str = trim(str_a_limpiar)
	
	Select Case modo_de_limpiar
    Case 0
		str = replace(str,"'","''")
	Case 1
		str = replace(str,"'","''")
		str = replace(str,"<","&lt;")
		str = replace(str,">","&gt;")
	Case 2
                          str = lcase(str)
                          str = replace(str,"=","")
                          str = replace(str,"'","")
                          str = replace(str,"""""","")
                          str = replace(str," or ","")
                          str = replace(str," and ","")
                          str = replace(str,"(","")
                          str = replace(str,")","")
                          str = replace(str,"<","[")
                          str = replace(str,">","]")
                          str = replace(str,"having ","")
                          str = replace(str,"group by","")
                          str = replace(str,"union select sum","")
                          str = replace(str,"union select min","")
                          str = replace(str,"--","")
                          str = replace(str,"select ","")
                          str = replace(str,"insert ","")
                          str = replace(str,"update ","")
                          str = replace(str,"delete ","")
                          str = replace(str,"drop ","")
                          str = replace(str,"-shutdown","")
    Case Else 
        str = str_a_limpiar
	End Select

	limpia_cadena = str

end function


ahi sip


Un ejemplo de uso!

Código:
	iws_login		= checa_cadena(request.Form("iws_login"),0,false)
	iws_password	= checa_cadena(request.Form("iws_password"),0,false)
	
	if iws_login = false or iws_password = false then termina
	
	iws_login	 = limpia_cadena(iws_login,2)
	iws_password = limpia_cadena(iws_password,2)

Última edición por Muzztein; 29/04/2005 a las 14:11
  #67 (permalink)  
Antiguo 10/05/2005, 13:41
Avatar de drmkace  
Fecha de Ingreso: febrero-2005
Mensajes: 26
Antigüedad: 19 años, 1 mes
Puntos: 0
Esta es una funcion para Obtener un campo de una tabla determinada dada un acondicion en otor campo


Function ObtenerValorCampo(strTabla,strCampoResult,strCampo Donde,strValorDonde,cnn)

dim rst,sReturnValue,sSql

sSql="SELECT DISTINCT " & strCampoResult & " FROM " & strTabla & " WHERE " & strCampoDonde & "=" & strValorDonde
Set rst = CreateObject("ADODB.RecordSet")
with rst
.Open sSql,cnn
if not (.EOF and .BOF) then
ObtenerValorCampo=.Fields(strCampoResult)
Else
ObtenerValorCampo=""
End iF
.close
End With
set rst=Nothing
End function

PARAMETROS:
--------------

strTabla : Tabla
strCampoReult : CAmpo que Se desea devolver su Valor
strCampoDonde : Campo por el cual se desea filtrar / Buscar
strValorDonde : Valor para filtrar / Buscar en strCampoDonde
cnn : ADODB.Connection (Valida)
  #68 (permalink)  
Antiguo 11/05/2005, 09:25
perrogrun
Invitado
 
Mensajes: n/a
Puntos:
Funcion que nos dice si una url tiene contenido o no

Imaginemos que tenemos una base de datos con enlaces y queremos checkear si éstos todavía existen, ¿Cómo podemos hacerlo desde asp con cierto éxito?

Código:
function enlace(url)
		set http_obj = createObject("Microsoft.XMLHTTP")
		ulr=request("url")
		http_obj.Open "GET",url,false
		On Error Resume Next
		http_obj.Send()
		if err.number <> 0 then
			enlace=false
		else
			codigo = Server.HTMLEncode(http_obj.responseText)
			if instr(codigo,"&lt;title&gt;No se encuentra la p&amp;aacute;gina&lt;/title&gt;")<>0 then
				enlace=false
			else
				enlace=true
			end if
			
			if instr(codigo,"El sistema no puede hallar el archivo especificado")<>0 then
				enlace=false
			else
				enlace=true
			end if
			
			if instr(codigo,"&lt;title&gt;Error&lt;/title&gt;")<>0 then
				enlace=false
			else
				enlace=true
			end if
		end if
		end function
Por ejemplo si ponemos
<%=enlace("http://www.instruccionesymanuales.com")%>
nos devuelve "true"
si ponemos
<%=enlace("http://www.manualesangle.com.es")%>
no devuelve "false"

Ya se que se puede mejorar añadiendo más posibles mensajes de error y por eso os animo a que juntos lo hagamos.

Un saludo y suerte a todos

*Nota: la función tarda un poco en ejecutarse porque tiene que recoger todo el código html de la web que buscamos, por lo que si queremos checkear toda una base de datos sugiero que pongáis un Server.ScriptTimeout bastante alto

Última edición por perrogrun; 11/05/2005 a las 09:46
  #69 (permalink)  
Antiguo 17/05/2005, 05:03
Avatar de Bravenap  
Fecha de Ingreso: noviembre-2002
Ubicación: Los Arroyos, El Escorial, Madrid
Mensajes: 2.084
Antigüedad: 21 años, 4 meses
Puntos: 4
Clave aleatoria (modificación)

Hola, esta es un pequeña modificación del código de pempas para generar una clave aleatoria (http://www.forosdelweb.com/showthrea...rio#post893965). La modificación es porque entre los caracteres ASCII que van desde el 48 al 90 se nos cuelan los siguientes indeseables:

58: :
59: ;
60: <
61: =
62: >
63: ?
64: @

Código:
function aleatorio()
	randomize
	car = Int((90 - 48 + 1) * Rnd + 48)
	aleatorio = car
end function

Dim clave
Dim tamano = 15

do while Len(clave) < tamano
	n = aleatorio()
	if n < 58 or n > 64 then
		clave = clave & chr(n)		
	end if
loop

Response.Write(clave)
Un saludo.
__________________
¡¡NO A LA GUERRA!!
Si ponemos a nuestros mensajes títulos adecuados, la gente se animará más a abrirlos y resultarán más útiles en las busquedas. ¡No a los ayuuudaaa, urgenteee y similares!
  #70 (permalink)  
Antiguo 19/05/2005, 13:52
Avatar de Muzztein  
Fecha de Ingreso: agosto-2002
Ubicación: Hangar 18
Mensajes: 1.703
Antigüedad: 21 años, 7 meses
Puntos: 16
Seguridad

Siguiendo con las funciones de seguridad.

Esta funcion compara la procedencia del usuario contra la procedencia que el programador especificó para que determinado script se pudiera ejecutar de manera segura.

Util para asegurarse, por ejemplo ,que una pagina del tipo eliminar.asp?id=12 sea accionada de su correcto formulario y no de manera directa, impidiendo así a un usuario mal intensionado hacer acciones que no esta autorizado a hacer.



Código:
function checa_procedencia(procedencia_autorizada,dominio_autorizado)

	aux = Request.ServerVariables("HTTP_REFERER")
	
	if len(aux) = 0 or aux = "" then 
		checa_procedencia = false
		exit function
	end if
	
	arreglo			 = split(aux,"/")
	dominio_real	 = arreglo(2)
	procedencia_real = arreglo(ubound(arreglo))
	
	if lcase(procedencia_real) = lcase(procedencia_autorizada) and lcase(dominio_real) = lcase(dominio_autorizado) then
		checa_procedencia = true
	else
		checa_procedencia = false
	end if
end function

Donde procedencia_autorizada es el nombre del archivo ASP que DEBE invocar a nuestro script a ejecutar, y donde dominio_autorizado es el dominio o nombre de la web de donde el script se esta ejecutando. ej : "www.misitio.com"

Modo de uso

Código:
if checa_procedencia("1.asp","localhost") = true then 
	escribe "eres bienvenido" 
else
	escribe "no eres binevenido"
end if

Consumala a discrecion

  #71 (permalink)  
Antiguo 30/05/2005, 13:36
Avatar de Neuron_376  
Fecha de Ingreso: abril-2005
Mensajes: 1.051
Antigüedad: 18 años, 11 meses
Puntos: 2
Variable inicializada

Funcion para asegurarnos completamente si si una variable ha sido inicializada y si contiene datos

Código HTML:
function Inicializada(Var)

  Inicializada = False

  if ((NOT isEmpty(Var)) and (NOT isNULL(Var)) and (Len(Trim(Expr)) > 0)) then 
    Inicializada = TRUE
  end if

END FUNCTION
if Inicializada(Session("Var"))
//Tienes acceso
else
//No tienes acceso
end if

Aplica para cualquier variable.

Es como Isset de PHP

Suerte!!
__________________
NeuronaNet.com... la idea correcta.
http://www.NeuronaNet.com
  #72 (permalink)  
Antiguo 30/05/2005, 16:26
Avatar de Saruman  
Fecha de Ingreso: mayo-2003
Ubicación: Panama city, Panama, Panama
Mensajes: 1.154
Antigüedad: 20 años, 10 meses
Puntos: 5
De acuerdo Super Fast String Concatenation

Función para concatenar miles de variables en una sola y rápidamente...
normalmente se utiliza:

for I = 1 to 10000
mivariable = mivariable & I
next

y esto nos arroja timeout en nuestras páginas de asp y además es super lento

Esta clase reemplaza eso y lo hace super rápido (segundos)

aquí les va:

Código:
Class StringBuilder
	Private Sub Class_Initialize()
		growthRate = 50
		itemCount = 0
		ReDim arr(growthRate)
	End Sub
	
	Public Sub Append(ByVal strValue)
		If itemCount > UBound(arr) Then
			ReDim Preserve arr(UBound(arr) + growthRate)
		End If
	
		arr(itemCount) = strValue
		itemCount = itemCount + 1
	End Sub
	
	Public Function ToString() 
		ToString = Join(arr, "")
	End Function
End Class
UTILIZACIÓN:

Código:
Dim objBuilder, i
Set objBuilder = new StringBuilder

For i = 0 To 5000
variable = "este es el número: " & i & "<br>" & vbcrlf
objBuilder.Append(variable) Next Response.Write objBuilder.ToString()

está super cool esta función...
__________________
Saruman

One Ring to rule them all, One Ring to find them, One Ring to bring them all and in the darkness bind them.
  #73 (permalink)  
Antiguo 02/06/2005, 13:01
 
Fecha de Ingreso: marzo-2005
Mensajes: 1.418
Antigüedad: 19 años
Puntos: 9
Función de validación genérica de los campos comunes de un formulario:


function isIt_Valid(Var, len_allowed, numbers_allowed, text_allowed)

Dim intruders_symbols
Dim valid_state

intruders_symbols = array("insert","select","drop","database","'","""" ,"*","--","-","delete","update","true","<",">")
Var = Lcase(Var)

valid_state = true

For i=0 To UBound(Intruders_symbols)
If Instr(Var, Intruders_symbols(i)) > 0 then
valid_state = "intruder"
isIt_Valid = valid_state
exit function
end if
next

if numbers_allowed = true And text_allowed = true then
For i = 1 To Len(Var)
If(Mid(Var, i, 1) < "a" Or Mid(Var, i, 1) > "z") And _
(Mid(Var, i, 1) < "0" Or Mid(Var, i, 1) > "9") then
valid_state = false
isIt_Valid = valid_state
exit function
End If
next

elseif numbers_allowed = true And text_allowed = false then
For i = 1 To Len(Var)
If(Mid(Var, i, 1) < "0" Or Mid(Var, i, 1) > "9") then
valid_state = false
isIt_Valid = valid_state
exit function
end if
next

elseif numbers_allowed = false And text_allowed = true then
For i = 1 To Len(Var)
If(Mid(Var, i, 1) < "a" Or Mid(Var, i, 1) > "z") then
valid_state = false
isIt_Valid = valid_state
exit function
end if
Next
end if

if Len(Var) > len_allowed OR Var = "" then
valid_state = false
isIt_Valid = valid_state
exit function
end if

isIt_Valid = valid_state

end function


En donde Var sería el campo a validar, len_allowed el máximo permitido de caracteres, numbers_allowed una propiedad boleana que especifica si el campo podrá contener números o no, text_allowed lo mismo que la anterior, pero especificando en true o false si podrá o no contener letras respectivamente.

Un ejemplo de su uso:

Dim FieldName
FieldName = "Mariano"

state = isIt_Valid(FieldName, 12, false, true)

El resultado obviamente sería TRUE.
Saludos y espero que le sirva a alguien.
Suerte!.
  #74 (permalink)  
Antiguo 09/06/2005, 07:41
 
Fecha de Ingreso: marzo-2005
Mensajes: 1.418
Antigüedad: 19 años
Puntos: 9
Función que sirve para ordenar un array, no me acuerdo de que página lo extraje ni quien es el autor, ya uqe hace tiempo que conseguí esta función en la red. Si alguien ha visto esta función en alguna página, que cite el autor y la página asi somos justos.


FUNCTION SortArray(varArray)
For i = UBound(varArray, 2) - 1 To 1 Step - 1
MaxVal = varArray(1, i)
MaxIndex = i

For j = 0 To i
If varArray(1, j) > MaxVal Then
MaxVal = varArray(1, j)
MaxIndex = j
End If
Next

If MaxIndex < i Then
varArray(1, MaxIndex) = varArray(1, i)
varArray(1, i) = MaxVal
End If
Next
END FUNCTION

Con esto se puede probar:

REDIM arrSORT(1, 8)

arrSORT(0,0)= 1
arrSORT(0,1)= 20
arrSORT(0,2)= 49
arrSORT(0,3)= 74
arrSORT(0,4)= 23
arrSORT(0,5)= 73
arrSORT(0,6)= 21
arrSORT(0,7)= 4
arrSORT(1,0)= "Argentina"
arrSORT(1,1)= "Mexico"
arrSORT(1,2)= "Brazil"
arrSORT(1,3)= "España"
arrSORT(1,4)= "Chile"
arrSORT(1,5)= "Guatemala"
arrSORT(1,6)= "Italia"
arrSORT(1,7)= "Groenlandia"
arrSORT(1,8)= "Nicaragua"

Response.write "<TABLE BORDER=1 WIDTH=100% ><TR><TD><B>UNSORTED</B></TD><TD><B>SORTED</B></TD></TR>"
Response.write "<TR><TD>"

FOR i = 0 TO UBOUND(arrSORT,2) - 1
Response.write "<B>arrSORT(" & i & ") value: </B>" & arrSORT(1, i) & "<BR>"
NEXT

Response.write "</TD><TD>"

SortArray arrSORT

FOR i = 0 TO UBOUND(arrSORT,2) - 1
Response.write "<B>arrSORT(" & i & ") value: </B>" & arrSORT(1, i) & "<BR>"
NEXT


Response.write "</TD></TR></TABLE>"
%>
  #75 (permalink)  
Antiguo 11/07/2005, 12:47
Avatar de Saruman  
Fecha de Ingreso: mayo-2003
Ubicación: Panama city, Panama, Panama
Mensajes: 1.154
Antigüedad: 20 años, 10 meses
Puntos: 5
Proósito: Convertir los los links e emails en links de html.

Utilización:

Código:
 
texto = "www.forosdelweb.com"
texto = InsertHyperlinks(texto) 
response.write(texto)

Funciones:

Código:
 
'Convierte los E-Mail's y los Links en enlaces
Function InsertHyperlinks(strInText, strEstilo)
Dim objRegExp, strBuf
Dim objMatches, objMatch
Dim Value, ReplaceValue, iStart, iEnd
 
strBuf = ""
iStart = 1
iEnd = 1
 
Set objRegExp = New RegExp
 
objRegExp.Pattern = "\b(www|http|\S+@)\S+\b"
objRegExp.IgnoreCase = True
objRegExp.Global = True
Set objMatches = objRegExp.Execute(strInText)
 
For Each objMatch in objMatches
iEnd = objMatch.FirstIndex
strBuf = strBuf & Mid(strInText, iStart, iEnd-iStart+1)
 
If InStr(1, objMatch.Value, "@") Then
	strBuf = strBuf & GetHref(objMatch.Value, "email", "_blank", strEstilo)
Else
	strBuf = strBuf & GetHref(objMatch.Value, "web", "_blank", strEstilo)
End If
 
iStart = iEnd+objMatch.Length+1
Next
 
strBuf = strBuf & Mid(strInText, iStart)
InsertHyperlinks = strBuf
End Function
 
 
Function GetHref(url, urlType, Target, strEstilo)
Dim strBuf
 
if strEstilo <> "" then strEstilo = "class=""" & strEstilo & """"
 
strBuf = "<a href="""
 
If urlType = "web" Then
If LCase(Left(url, 3)) = "www" Then
	strBuf = "<a href=""http://" & url & """ target=""" & Target & """ " & strEstilo & ">" & url & "</a>"
Else
	strBuf = "<a href=""" & url & """ target=""" & Target & """ " & strEstilo & ">" & url & "</a>"
End If
 
ElseIf UCase(urlType) = "email" Then
strBuf = "<a href=""mailto:" & url & """ target=""" & Target & """ " & strEstilo & ">" & url & "</a>"
End If
 
GetHref = strBuf
End Function
__________________
Saruman

One Ring to rule them all, One Ring to find them, One Ring to bring them all and in the darkness bind them.
  #76 (permalink)  
Antiguo 19/07/2005, 12:07
Avatar de dobled  
Fecha de Ingreso: enero-2002
Ubicación: Rancagua - Chile
Mensajes: 1.328
Antigüedad: 22 años, 1 mes
Puntos: 2
Funcion para Redireccionar con mensajeBox

Código:
Sub Redirecciona(pagina,mensaje)
If pagina="" Then
pagina="window.history.back();"
ElseIf isNumeric(pagina) Then
pagina="window.history.go(-"&pagina&")"
Else pagina="location.href='"&pagina&"';"
End If

Response.Write("<script language=""javascript"">")

If mensaje<>"" Then
Response.Write("alert('"&Mensaje&"');")
End If

Response.Write (pagina&"</script>")
Response.End
End Sub
se utiliza asi

Código:
<%
Call Redirecciona("form_ingreso_cursos.asp","El curso "&nom_curso&" se ingreso correctamente.")
%>
o

Código:
<%
    Call Redirecciona("","Los datos son erroneos.")
%>
__________________
Usa títulos específicos y con sentido
En las listas de correo o en los grupos de noticias, la cabecera del mensaje es tu oportunidad de oro para atraer la atención de expertos cualificados en aproximadamente 50 caracteres o menos. No los desperdicies en balbuceos como "Por favor ayúdame" (de "POR FAVOR AYÚDAME!!!" ya ni hablamos). No intentes impresionarnos con lo profundo de tu angustia; mejor usa ese preciado espacio para una descripción lo más concisa posible del problema.
  #77 (permalink)  
Antiguo 23/07/2005, 14:29
 
Fecha de Ingreso: marzo-2005
Mensajes: 1.418
Antigüedad: 19 años
Puntos: 9
Sacar el máximo valor de un array

Código:
function GetMax(param_arr)
 
Dim endLoop, maxValue
endLoop = UBound(param_arr) - 1
maxValue = 0 
   
   for i=0 to endLoop
	   if param_arr(i) > param_arr(i+1) and param_arr(i) => maxValue then
	   maxValue = param_arr(i)
	elseif arr(i + 1) > maxValue then 
	   maxValue = param_arr(i+1)
	end if
   next
  
   GetMax = maxValue
end function
Así se llama:

Dim arr(4)
arr(0) = 50392
arr(1) = 239023
arr(2) = 493
arr(3) = 4892
arr(4) = 4095

Response.Write(GetMax(arr)) ' Devuelve 239023

Espero que sea útil.
Saludos!.
__________________
Add, never Remove
  #78 (permalink)  
Antiguo 25/07/2005, 00:38
perrogrun
Invitado
 
Mensajes: n/a
Puntos:
Función istime

Función istime para saber si una hora es correcta o no

Código:
function istime(data)
data = replace(data,".",":")
	if instr(data,":")<>0 then
		hora = trim(left(data,instr(data,":")-1))
		minutos = trim(mid(data,instr(data,":")+1,len(data)))
		if isnumeric(hora) then
			if hora>=0 and hora <24 then
				istime = true
				if isnumeric(minutos) then
					if minutos>=0 and minutos <60 then
						istime = true
					else
						istime = false
					end if
				else
					istime = false
				end if
			else
				istime = false
			end if
		else
			istime = false
		end if
	else
		istime = false
	end if
	
end function
Forma de usarla:

if istime("12:45") then
codigo
else
codigo
end if
  #79 (permalink)  
Antiguo 25/07/2005, 01:24
 
Fecha de Ingreso: enero-2002
Mensajes: 1.438
Antigüedad: 22 años, 2 meses
Puntos: 0
ideal para formularios.

Si reconoce la fecha la formatea tipo mysql,
si no la reconoce, salta una alerta y se regresa.

Código:
<%
 function Cfecha (fecha)
   if IsDate(Fecha) then
     anho=year(fecha)
     mes = month (fecha)
     dia =day(fecha)
     Cfecha=anho & "/" & mes & "/" & dia
   Elseif (Fecha<>"") then 
     MM_abortEdit = "True"
	%>
	<script language="JavaScript">
    alert("Formato de Fecha no válido: DD/MM/AAAA");
	history.back();
    </script>
	<%
   end if		  
 end function  
%>
  #80 (permalink)  
Antiguo 25/07/2005, 14:22
Avatar de El_Metallick  
Fecha de Ingreso: noviembre-2002
Ubicación: Santiago, Chile
Mensajes: 1.718
Antigüedad: 21 años, 4 meses
Puntos: 16
Funcion para envio de emails con varios componentes:
Código:
<%
function email(strPara,strDe,strDeEmail,strAsunto,strMemsaje,strHost,componente)
 
    'componente = 0 Si el componente es CDONTS
    'componente = 1 Si el componente es CDOSYS
    'componente = 2 Si el componente es AspMail
'componente = 3 Si el componente es AspEmail
'componente = 4 Si el componente es Geocel
'componente = 5 Si el componente es JMail
'componente = 6 Si el componente es DynuEmail
'componente = 7 Si el componente es EasyMail
'componente = 8 Si el componente es SA-SMTPMail
'componente = 9 Si el componente es ocxQmail
 
    Select Case componente
Case 0
        Set msMail = CreateObject("CDONTS.NewMail")
        With msMail
        .BodyFormat = 0 '0 si es HTML y 1 si es texto plano.
        .MailFormat = 0 '0 si es HTML y 1 si es texto plano.
        .To = strPara
        .From = strDe & " <" & strDeEmail & ">"
        .Subject = strAsunto
        .Body = strMensaje
        .Send
        End With
    Case 1
        Dim conf
        Set conf = Server.CreateObject("CDO.Configuration")
        With conf.Fields
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strHost
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
        .Update 
        End With
 
        Set msMail = Server.CreateObject("CDO.Message")
        With msMail
        Set .Configuration = conf
        .From = strDe & " <" & strDeEmail & ">"
        .To = strPara
        .Subject = strAsunto
        .HTMLBody = strMensaje
        .Send
        End With
    Case 2
        Set msMail = Server.CreateObject("SMTPsvg.Mailer")
        With msMail
        .ContentType = "text/html"
        .RemoteHost = strHost
        .FromName = strDe
        .FromAddress = strDeEmail
        .AddRecipient "", strPara
        .Subject = strAsunto
        .BodyText = strMensaje
        .SendMail
        End With
    Case 3
        Set msMail = Server.CreateObject("Persits.MailSender")
        With msMail
        .Host = strHost
        .From = strDeEmail
        .FromName = strDe
        .AddAddress strPara
        .Subject = strAsunto
        .Body = strMensaje
        .IsHTML = True
        .Send
        End With
    Case 4
        Set msMail = Server.CreateObject("Geocel.Mailer")
        With msMail
        .AddServer strHost, 25
        .FromAddress = strDeEmail
        .FromName = strDe
        .AddRecipient strPara, ""
        .Subject = strAsunto
        .Body = strMensaje
        .ContentType = "text/html"
        .LogLevel = 4
        .LogFile = "c:\temp\emailcoms\geocel.log"
        .Send
        End With
    Case 5
        Set msMail = Server.CreateOBject("JMail.Message")
        With msMail
        .From = strDeEmail
        .FromName = strDe
        .AddRecipient strPara
        .Subject = strAsunto
        .HTMLBody = strMensaje
        .Send(strHost)
        End With
    Case 6
        Set msMail = Server.CreateObject("Dynu.Email")
        With msMail
        .Host = strHost
        .IsHTML = True
        .From = strDeEmail
        .FromName = strDe
        .AddAddress strPara
        .Subject = strAsunto
        .Body = strMensaje
        .Send()
        End With
    Case 7
        Set msMail = Server.CreateObject("EasyMail.SMTP.5") 
        With msMail
        .MailServer = strHost
        .BodyFormat = 1 'para HTML
        .FromAddr = strDeEmail
        .AddRecipient "", strPara, 1
        .Subject = strAsunto
        .Send()
        End With
    Case 8
        Set msMail = Server.CreateObject("SoftArtisans.SMTPMail")
        With msMail
        .RemoteHost = strHost
        .FromAddress = strDeEmail
        .FromName = strDe
        .AddRecipient strPara
        .Subject = strAsunto
        .HTMLText = strMensaje
        .Wordwrap = True
        .SendMail
        End With 
    Case 9
        Set msMail = Server.CreateObject("ocxQmail.ocxQmailCtrl.1") 
        msMail.XHeader "Content-Type", "text/html; charset=""iso-8859-1"""
        msMail.Q strHost, strDe, strDeEmail, "", "", strPara, "", "", "", strAsunto, strMensaje
    End Select
end function
%>
Modo de uso:
Código:
email(Destinatario,Remitente,Email_Remitente,Asunto,Memsaje,Host,componente)
Lista de Componentes:
0 CDONTS
1 CDOSYS
2 AspMail
3 AspEmail
4 Geocel
5 JMail
6 DynuEmail
7 EasyMail
8 SA-SMTPMail
9 ocxQmail

saludos

------- Editado -------

No es una funcion ni una clase ni nada pero encuentro que es un buen complemtendo de la funcion de arriba.... sirve para detectar que componente esta instalado en el servidor (para efectos del envio de emails:
Código:
<%
'Empezamos el Arreglo
Dim ObjInstalados(9)
ObjInstalados(0) = "CDONTS.NewMail" 'Si el componente es CDONTS
ObjInstalados(1) = "CDO.Message" 'Si el componente es CDOSYS
ObjInstalados(2) = "SMTPsvg.Mailer" 'Si el componente es AspMail
ObjInstalados(3) = "Persits.MailSender"    'Si el componente es AspEmail
ObjInstalados(4) = "Geocel.Mailer"    'Si el componente es Geocel
ObjInstalados(5) = "JMail.SMTPMail"    'Si el componente es JMail
ObjInstalados(6) = "Dynu.Email"    'Si el componente es DynuEmail
ObjInstalados(7) = "EasyMail.SMTP.5"    'Si el componente es EasyMail
ObjInstalados(8) = "SoftArtisans.SMTPMail"    'Si el componente es SA-SMTPMail
ObjInstalados(9) = "ocxQmail.ocxQmailCtrl.1"    'Si el componente es ocxQmail
'Luego podemos ir agregando mas objetos, segun los que necesitemos
Function cmpObjInstalados(strClassString)
On Error Resume Next
' Inicia Valores por Defecto
cmpObjInstalados = False
Err = 0
' Probamos
Dim PruebaObj
Set PruebaObj = Server.CreateObject(strClassString)
If 0 = Err Then cmpObjInstalados = True
' Limpiamos
Set PruebaObj = Nothing
Err = 0
End Function
If cmpObjInstalados(ObjInstalados(0))=True Then
   Response.Write("CDONTS")
ElseIf cmpObjInstalados(ObjInstalados(1))=True Then
   Response.Write("CDOSYS")
ElseIf cmpObjInstalados(ObjInstalados(2))=True Then
   Response.Write("AspMail")
ElseIf cmpObjInstalados(ObjInstalados(3))=True Then
   Response.Write("AspEmail")
ElseIf cmpObjInstalados(ObjInstalados(4))=True Then
   Response.Write("Geocel")
ElseIf cmpObjInstalados(ObjInstalados(5))=True Then
    Response.Write("JMail")
ElseIf cmpObjInstalados(ObjInstalados(6))=True Then
     Response.Write("DynuEmail")
ElseIf cmpObjInstalados(ObjInstalados(7))=True Then
      Response.Write("EasyMail")
ElseIf cmpObjInstalados(ObjInstalados(8))=True Then
       Response.Write("SA-SMTPMail")
ElseIf cmpObjInstalados(ObjInstalados(9))=True Then
        Response.Write("ocxQmail")
Else
Response.Write ("No hay componentes")
End If
%>
Saludos
__________________
Haz la guerra en la cama y el amor donde se te de la gana...
El tiempo es el mejor maestro, lo único malo es que te mata...¡¡Aprovecha tu tiempo!!

Última edición por El_Metallick; 17/06/2006 a las 14:47
  #81 (permalink)  
Antiguo 02/08/2005, 20:41
Avatar de juanamador  
Fecha de Ingreso: abril-2004
Ubicación: Tijuana
Mensajes: 5
Antigüedad: 19 años, 11 meses
Puntos: 0
Comprobar si un registro existe

Aqui va una, espero sea util para mas de alguno


'Nombre: fExisteReg
'Proposito:Determinar si un registro existe en la Base de Datos
'Parametros:
' strTableName=Tabla donde se va a buscar el valor
' strFieldName=Campo de la tabla donde se va a buscar
' myValue=Valor que vamos a buscar en el campo
' intTipoCampo=Tipo de campo en el que vamos a buscar
' 1=Texto
' 2=Numero
' 3=Fecha
' strConexion=Cadena de conexion a la Base de Datos
' Por ejemplo:"DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & Server.MapPath("db1.mdb")
' nos conectaria a una base de datos de Microsoft Access alojada en la misma direccion
' donde se encuentre alojada esta funcion.
'Autor: Juan Amador
'E-mail: famaads en yahoo.com
'Fecha: Enero/2005
'Uso: IF fExisteReg("Table1","Field1","Juan Amador",1) Then
'Resultado: Devuelve TRUE si el dato existe y FALSE si no existe


Function fExisteReg(strTableName,strFieldName,myValue,intTi poCampo,strConexion)
Dim strCritExisteReg
Dim strConnExisteReg
Dim ConexionExisteReg
Dim strSQLExisteReg
Dim rstExisteReg

strConnExisteReg =strConexion
Set ConexionExisteReg=CreateObject("adodb.connection")
Set rstExisteReg=CreateObject("AdoDB.Recordset")

Select Case intTipoCampo
Case 1 'Texto
strCritExisteReg="[" & strFieldName & "]='" & myValue & "'"
Case 2 'Numerico
strCritExisteReg="[" & strFieldName & "]=" & myValue
Case 3 'Fecha
strCritExisteReg="[" & strFieldName & "]=#" & myValue & "#"
End Select

strSQLExisteReg="SELECT * FROM [" & strTableName & "] WHERE " & strCritExisteReg

ConexionExisteReg.Open strConnExisteReg

rstExisteReg.Open strSQLExisteReg,ConexionExisteReg

If rstExisteReg.BOF And rstExisteReg.EOF Then
fExisteReg=False
Else
fExisteReg=True
End If

rstExisteReg.Close
ConexionExisteReg.Close
Set rstExisteReg=Nothing
Set ConexionExisteReg=Nothing
End Function
  #82 (permalink)  
Antiguo 05/08/2005, 16:49
Avatar de mamon  
Fecha de Ingreso: enero-2002
Ubicación: Lima
Mensajes: 1.302
Antigüedad: 22 años, 2 meses
Puntos: 3
Paginar Un Texto

Cómo paginar un texto?

Código:
<%
sub paginar_texto(variable)
variable = Replace(variable,vbcrlf,"<br>")

V = Split(variable," ")
palabras = Ubound(V)
mostrar = 10
If Request.QueryString("pag") = "" Then
pagina_actual = 0
Else
pagina_actual = CInt(Request.QueryString("pag"))
End If

cant_paginas = Int(palabras/mostrar)

If pagina_actual > cant_paginas Then pagina_actual = cant_paginas
If pagina_actual < 0 Then pagina_actual = 0

if pagina_actual < cant_paginas then
for i = pagina_actual*mostrar to pagina_actual*mostrar+mostrar-1
response.Write(V(i)&" ")
next
else
for i = pagina_actual*mostrar to palabras
response.Write(V(i)&" ")
next
end if
response.Write("<br>")
if pagina_actual > 0 then
response.Write("<a href='mid.asp?pag="&pagina_actual-1&"'><<</a> ")
end if


if pagina_actual < cant_paginas then
response.Write(" <a href='mid.asp?pag="&pagina_actual+1&"'>>></a>")
end if

end sub

'aquí tenemos el texto
texto = "Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est"
'ahora llamamos a la subrutina
paginar_texto(texto)
%>
__________________
Yo si sé lo que es trabajar duro, porque lo he visto.
  #83 (permalink)  
Antiguo 11/08/2005, 17:48
 
Fecha de Ingreso: marzo-2005
Mensajes: 1.418
Antigüedad: 19 años
Puntos: 9
Estructura de categorías

Genera la jerarquía de determinadas categorías. Este procedimiento es una modificación de uno que mencionó A Z para resolver un problema similar al mío de sjam7 o speedy (no recuerdo en este momento). Lo que no me gustaba era que por cada llamada al procedimiento se creaba un objeto conexion y un objeto recordset. Con esta función se crean menos objetos recordset y se utiliza una sola conexion, que es pasada como argumento del procedimiento (eso gracias al maestro de U_Goldman). Los campos que debería tener la tabla desde donde se sacan las categorías serían los siguientes:

CAT_ID --> Id de la categoría
CAT_IDDEP --> Id de la categoría del cual depende (el 0 son categorias princ.)
CAT_HIJOS --> 1 si tiene hijos, 0 si la categoría no tiene hijos
CAT_NIVEL --> Nivel de la categoría en la estructura (0 para las principales, 1, 2...)

Código:
sub getCategories(param_id, objConnection)
sql = "SELECT CAT_ID, CAT_NOMBRE, CAT_HIJOS, CAT_NIVEL FROM CAT_CATEGORIAS WHERE CAT_IDDEP = " & param_id
	  set rs = server.createObject("ADODB.recordSet")
	   rs.open sql, objConnection
	   if not rs.eof then
	   do until rs.eof
		  leftSpace = rs("CAT_NIVEL") * 5
		  response.write(replace(space(leftSpace)," ","&nbsp;") & rs("CAT_NOMBRE") & "<BR>")	   
	   if rs("CAT_HIJOS") = 1 then
		  getCategories rs("CAT_ID"), objConnection	   
	   end if
		  rs.moveNext	   
	   loop
	end if
	rs.close()
   set rs = nothing
end sub
Se llamaría de esta forma:

set conn = server.createObject("ADODB.connection")
conn.open strConn
call getCategories(0, conn)
conn.close()
set conn = nothing

Espero que sea útil para alguien esta modificación.
__________________
Add, never Remove
  #84 (permalink)  
Antiguo 12/08/2005, 02:33
 
Fecha de Ingreso: enero-2002
Mensajes: 1.438
Antigüedad: 22 años, 2 meses
Puntos: 0
Código:
  ' Añadir la query string a la redirect URL 
  MM_editRedirectUrl = "pagina2.asp"

  If (MM_editRedirectUrl <> "" And Request.QueryString <> "") Then
    If (InStr(1, MM_editRedirectUrl, "?", vbTextCompare) = 0 And Request.QueryString <> "") Then
      MM_editRedirectUrl = MM_editRedirectUrl & "?" & Request.QueryString
    Else
      MM_editRedirectUrl = MM_editRedirectUrl & "&" & Request.QueryString
    End If
  End If

   If (MM_editRedirectUrl <> "") Then
     Response.Redirect(MM_editRedirectUrl)
   End If
  #85 (permalink)  
Antiguo 09/09/2005, 03:51
 
Fecha de Ingreso: enero-2002
Mensajes: 1.438
Antigüedad: 22 años, 2 meses
Puntos: 0
'cazo los datos del Form anterior y los meto en un array
se puede arreglar para no preocuparse por la dimension del array

<%
if Request.Form = "" then
response.redirect ("Test.asp")
else
Dim respuestas(14)
Dim i
for i = 1 to 14
respuestas(i) = Request.Form(i)
next

end if
%>
  #86 (permalink)  
Antiguo 07/10/2005, 13:10
Avatar de Saruman  
Fecha de Ingreso: mayo-2003
Ubicación: Panama city, Panama, Panama
Mensajes: 1.154
Antigüedad: 20 años, 10 meses
Puntos: 5
Cargar SELECT con datos de la Base de Datos

En este ejemplo presento como cargar datos de una base de datos a dos select, y que estos cambien automáticamente.


Código:
 
<%
 'Función para conectarse a la Base de Datos
 
 'strStringConection = 0 (SQL Server 2000)  1 (MS Access)
 'strDBPath = ruta donde está la BD
 'strDBName = nombre de la BD (en el caso que sea SQL Server 2000)
 'strDBUserId = nombre del usuario (en el caso que sea SQL Server 2000)
 'strDBPassword = password de la BD
 
 Function DBOpenConection()
  Dim Master
  Dim strSringConection
  
  select case strDBType
   case 0
    strStringConection = "Provider=sqloledb;" & _ 
          "Data Source=" & strDBPath & ";" & _
          "Persist Security Info=False;Trusted_Connection=false;" & _
          "Initial Catalog=" & strDBName & ";" & _
          "User Id=" & strDBUserId & ";" & _
          "Password=" & strDBPassword
   case 1
    strStringConection = "Provider=Microsoft.Jet.OLEDB.4.0; " & _
          "Data Source=" & Server.MapPath(strDBPath) & ";" & _
          "Jet OLEDB:Database Password=" & strDBPassword
  end select
  
  Set Master = Server.CreateObject("ADODB.Connection")
  Master.Open strStringConection
  Set DBOpenConection = Master
 End Function
 
 
 set Master = DBOpenConection()
 
 
 provincia = request("provincia")
 if provincia = "" then provincia = 0
 
 'TABLA PROVINCIAS:
  'codigo = numerico
  'nombre = texto
 
 'TABLA DISTRITOS
  'codigo = numerico
  'nombre = texto
  'provincia_codigo = numerico   --   este campo va relacionado con codigo de provincia en la tabla PROVINCIAS
 
 
 sSQL = "select * from PROVINCIA order by codigo"
 set RSProvincias = Master.Execute(sSQL)
 
 sSQL = "select * from DISTRITOS where provincia_codigo=" & provincia & " order by nombre"
 set RSDistritos = Master.Execute(sSQL)
%>
Código PHP:
<table border="0" cellspacing="2" cellpadding="2" class="TablaSimple">
  <
tr>
    <
td width="80">Provincia:</td>
    <
td>
 <
select name="provincia" onChange="load_distritos(this.value)">
<%
 if 
RSProvincias.bof=false and RSProvincias.eof=false then
  
if provincia 0 then response.Write(vbtab "<option value=""0"" selected>Seleccione una Provincia</option>" vbcrlf)
  while 
not RSProvincias.eof
   
if clng(RSProvincias("codigo")) = provincia then
    response
.Write(vbtab "<option value=""" RSProvincias("codigo") & """ selected>" RSProvincias("nombre") & "</option>" vbcrlf)
   else
    
response.Write(vbtab "<option value=""" RSProvincias("codigo") & """>" RSProvincias("nombre") & "</option>" vbcrlf)
   
end if
   
RSProvincias.movenext
  wend
  
  RSProvincias
.movefirst
 
else
  
response.Write(vbtab "<option value=""0"" selected>No Existe ninguna Provincia</option>" vbcrlf)
 
end if
%>
    </
select>
 </
td>
  </
tr>
  <
tr>
   <
td>Distrito:</td>
 <
td>
 <
select name="distrito">
<%
 if 
RSDistritos.bof=false and RSDistritos.eof=false then
  
if distrito 0 then response.Write(vbtab "<option value=""0"" selected>Seleccione un Distrito</option>" vbcrlf)
  while 
not RSDistritos.eof
   
if clng(RSDistritos("codigo")) = distrito then
    response
.Write(vbtab "<option value=""" RSDistritos("codigo") & """ selected>" RSDistritos("nombre") & "</option>" vbcrlf)
   else
    
response.Write(vbtab "<option value=""" RSDistritos("codigo") & """>" RSDistritos("nombre") & "</option>" vbcrlf)
   
end if
   
RSDistritos.movenext
  wend
 
else
  
response.Write(vbtab "<option value=""0"" selected>Seleccione un Distrito</option>" vbcrlf)
 
end if
%>
 </
select>
 </
td>
  </
tr>
</
table>
<
script language="javascript">
 function 
load_distritos(provincia) {
<%
 
0
 
while not RSProvincias.eof
  sSQL 
"select * from distritos where provincia_codigo=" RSProvincias("codigo") & " order by nombre"
  
set RSDistritos Master.Execute(sSQL)
  
  
0
  response
.Write(vbtab vbtab "if (provincia == " RSProvincias("codigo") & ") {") & vbcrlf
  response
.Write(vbtab vbtab vbtab "f.distrito.options.length = 0;") & vbcrlf
  response
.Write(vbtab vbtab vbtab "sub" " = new Option(""Seleccione un Distrito"",""0"",""defauldSelected"");") & vbcrlf
  response
.Write(vbtab vbtab vbtab "f.distrito.options[" "] = sub" ";") & vbcrlf
  J 
1
  
if RSDistritos.bof=false and RSDistritos.eof=false then
   
while not RSDistritos.eof
    distrito_codigo 
RSDistritos("codigo")
    
distrito_nombre RSDistritos("nombre")
    
response.Write(vbtab vbtab vbtab "sub" " = new Option(""" distrito_nombre """,""" distrito_codigo ""","""");") & vbcrlf
    response
.Write(vbtab vbtab vbtab "f.distrito.options[" "] = sub" ";") & vbcrlf
    J 
1
    RSDistritos
.movenext
   wend
  
else
   
response.Write(vbtab vbtab vbtab "sub" " = new Option(""No Existe ningún Distrito en esta Provincia"",""0"","""");") & vbcrlf
   response
.Write(vbtab vbtab vbtab "f.distrito.options[" "] = sub" ";") & vbcrlf
  end 
if
  
  
set RSDistritos nothing
  
  response
.Write(vbtab vbtab "}") & vbcrlf
  
  I 
1
  RSProvincias
.movenext
 wend
 
 set RSProvincias 
nothing
%>
 }
</script> 
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.
  #87 (permalink)  
Antiguo 22/10/2005, 16:55
Avatar de HPNeo  
Fecha de Ingreso: mayo-2004
Ubicación: The Matrix
Mensajes: 223
Antigüedad: 19 años, 10 meses
Puntos: 0
Convertir fechas a Español

Bien... no se si sea de utilidad, pero sirve para los que tienen hosting en ingles y no pueden modificarlo, esta funcion recoge la fecha de la variable fecha , luego verifica cual es el dia de la semana y le asigna a una variable un string con el nombre en español, igual que al mes, luego un response.write con el dia de la semana, el numero de dia, el mes y el año.

Código:
Function FechaEspanol(fecha)
hoy=fecha
diasemana=(WeekDay(hoy))
dia=Day(hoy)
mes=Month(hoy)
anyo=Year(hoy)
 
Select Case diasemana
 Case "1"
  dsemana="Domingo"
 Case "2"
  dsemana="Lunes"
 Case "3"
  dsemana="Martes"
 Case "4"
  dsemana="Miércoles"
 Case "5"
  dsemana="Jueves"
 Case "6"
  dsemana="Viernes"
 Case "7"
  dsemana="Sábado"
End Select
 
Select Case mes
 Case "1"
  mmes="Enero"
 Case "2"
  mmes="Febrero"
 Case "3"
  mmes="Marzo"
 Case "4"
  mmes="Abril"
 Case "5"
  mmes="Mayo"
 Case "6"
  mmes="Junio"
 Case "7"
  mmes="Julio"
 Case "8"
  mmes="Agosto"
 Case "9"
  mmes="Setiembre"
 Case "10"
  mmes="Octubre"
 Case "11"
  mmes="Noviembre"
 Case "12"
  mmes="Diciembre"
End Select
 
Response.Write(dsemana&", "&dia&" de "&mmes&" de "&anyo)
 
End Function
Nos vemos luego
__________________
HPNeo
  #88 (permalink)  
Antiguo 15/11/2005, 12:34
Avatar de Saruman  
Fecha de Ingreso: mayo-2003
Ubicación: Panama city, Panama, Panama
Mensajes: 1.154
Antigüedad: 20 años, 10 meses
Puntos: 5
Sonrisa Mostrar diálogo "Guardar como..." para cualquier archivo, Parte I

Pregunta: ¿Cómo hago en ASP para descargar cualquier archivo mostrando la ventana de diálogo "guardar como"?

A veces sucede en archivos como .txt, .jpg, .gif, etc que se abren directamente en el explorador, pues este script los descarga sin que se abra en el explorer del usuario.

Solución:

Archivos principales almacenados en la carpeta "descargar"

ssort.asp

Código:
 
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<% 
 '8***********************************************8
 ' Jason Withrow - For ASP101 July 2001
 ' Page Builds List of Files in Specific Folder
 ' With Links to Download files
 '
 ' [email protected]
 '8***********************************************8
 Dim strThisPage
 strThisPage = Request.ServerVariables("SCRIPT_NAME")
 strThisPage = Right(strThisPage, Len(strThisPage) - 1)
 
 'Path To Folder That holds Files To Download Here
 'Default is the current Folder
 FILE_FOLDER = StripFileName(Request.ServerVariables("PATH_TRANSLATED"))
 
 'Constants
 Const adVarChar = 200
 Const adInteger = 3
 Const adDate = 7
 Const adFileTime = 64
 Const adNumeric = 131
 
%>
<HTML>
<HEAD>
 <TITLE>File Download List For <%= Date() %></TITLE>
 <STYLE TYPE="TEXT/CSS">
 .TabHeader { Font-Family: Arial; Font-Weight: Bold; Font-Size: 12px; Background: Silver }
 .DataCol { Font-Family: Verdana; Font-Size: 12px }
 </STYLE>
 <SCRIPT>
  function msg() {
   self.status = 'File Downloads For <%= Date() %>';
   return true
  }
 </SCRIPT>
</HEAD>
<BODY onLoad="msg()">
<TABLE BORDER=1 ID=tblFileData BACKGROUND="">
 <TR>
  <TD CLASS=TabHeader><A HREF="sSort.asp?sort=Name">File Name</A></TD>
  <TD CLASS=TabHeader><A HREF="sSort.asp?sort=Type">File Type</A></TD>
  <TD CLASS=TabHeader><A HREF="sSort.asp?sort=Size">File Size</A></TD>
  <TD CLASS=TabHeader><A HREF="sSort.asp?sort=Path">File Path</A></TD>
  <TD CLASS=TabHeader><A HREF="sSort.asp?sort=Date">Last Modified</A></TD>
 </TR>
<%  
 strSortHeader = Request.QueryString("sort")
 
 IF strSortHeader = "" Then
  Call GetAllFiles("")
 Else
  Call GetAllFiles(strSortHeader)
 End IF
%>
 
</TABLE>
</BODY>
</HTML>
<%  
'8*****************************************8
' The next release will have sort routines 
' That is why the column headers are links
' They are hooks to add the sorts into.
'8****************************************8
 
Sub GetAllFiles(strSortBy)
 Dim oFS, oFolder, oFile
 Set oFS = Server.CreateObject("Scripting.FileSystemObject")
 
 'Set Folder Object To Proper File Directory
 Set oFolder = oFS.getFolder(FILE_FOLDER)
 
 Dim intCounter
 
 intCounter = 0
 
 IF strSortBy = "" Then 'UnSorted (default)
  Dim FileArray()
  ReDim Preserve FileArray(oFolder.Files.Count, 5)
 
  For Each oFile in oFolder.Files
   strFileName = oFile.Name
   strFileType = oFile.Type
   strFileSize = oFile.Size
   strFilePath = oFile.Path
   strFileDtMod = oFile.DateLastModified
 
   FileArray(intCounter, 0) = strFileName
   FileArray(intCounter, 1) = "<A HREF=" & Chr(34) & "startDownload.asp?File=" _
    & Server.urlEncode(strFilePath) & "&Name=" & Server.urlEncode(strFileName) & "&Size=" & strFileSize & Chr(34) _
    & " onMouseOver=" & Chr(34) & "self.status='" & strFileName & "'; return true;" & Chr(34) _
    & " onMouseOut=" & Chr(34) & "self.status=''; return true;" & Chr(34) & ">" & strFileName & "</A>"
   FileArray(intCounter, 2) = strFileType
   FileArray(intCounter, 3) = strFileSize
   FileArray(intCounter, 4) = strFilePath
   FileArray(intCounter, 5) = strFileDtMod
 
   intCounter = (intCounter + 1)
  Next
 
  intRows = uBound(FileArray, 1)
  intCols = uBound(FileArray, 2)
 
  For x = 0 To intRows -1
   Echo("<TR>")
   For z = 0 To intCols
    If z > 0  Then
     BuildTableCol(FileArray(x, z))
    End IF
   Next
   Echo("</TR>")
  Next
 
 Else
 'Sorted List
 
  Set oRS = Server.CreateObject("ADODB.Recordset")
  oRS.Fields.Append "Name", adVarChar, 500
  oRS.Fields.Append "Type", adVarChar, 500
  oRS.Fields.Append "Size", adInteger
  oRS.Fields.Append "Path", adVarChar, 500
  oRS.Fields.Append "Date", adFileTime
  oRS.Open
 
  For Each oFile in oFolder.Files
   strFileName = oFile.Name
   strFileType = oFile.Type
   strFileSize = oFile.Size
   strFilePath = oFile.Path
   strFileDtMod = oFile.DateLastModified
 
   oRS.AddNew
   oRS.Fields("Name").Value = "<A HREF=" & Chr(34) & "startDownload.asp?File=" _
    & Server.urlEncode(strFilePath) & "&Name=" & Server.urlEncode(strFileName) & "&Size=" & strFileSize & Chr(34) _
    & " onMouseOver=" & Chr(34) & "self.status='" & strFileName & "'; return true;" & Chr(34) _
    & " onMouseOut=" & Chr(34) & "self.status=''; return true;" & Chr(34) & ">" & strFileName & "</A>"
   oRS.Fields("Type").Value = strFileType
   oRS.Fields("Size").Value = strFileSize
   oRS.Fields("Path").Value = strFilePath
   oRS.Fields("Date").Value = strFileDtMod
  Next
 
  oRS.Sort = strSortBy & " ASC"
 
  Do While Not oRS.EOF
   Echo("<TR>")
    BuildTableCol(oRS("Name"))
    BuildTableCol(oRS("Type"))
    BuildTableCol(oRS("Size"))
    BuildTableCol(oRS("Path"))
    BuildTableCol(oRS("Date"))
   Echo("</TR>")
  oRS.MoveNext
  Loop   
 
  oRS.Close
  Set oRS = Nothing
 End IF
 
 EchoB("<B>" & oFolder.Files.Count & " Files Available</B>")
 
 Cleanup oFile
 Cleanup oFolder
 Cleanup oFS
End Sub
Function Echo(str)
 Echo = Response.Write(str & vbCrLf)
End Function
Function EchoB(str)
 EchoB = Response.Write(str & "<BR>" & vbCrLf)
End Function
Sub Cleanup(obj)
 IF isObject(obj) Then
  Set obj = Nothing
 End IF
End Sub
Function StripFileName(strFile)
 StripFileName = Left(strFile, inStrRev(strFile, "\"))
End Function
Sub BuildTableCol(strData)
 Echo("<TD CLASS=DataCol>" & strData & "</TD>")
End Sub
'Not implemented
Sub BuildTableRow(arrData)
 Dim intCols
 intCols = uBound(arrData)
 For y = 0 To intCols
  Echo("<TD CLASS=DataCol>" & arrData(y) & "</TD>")
 Next
End Sub
%>

startdownload.asp

Código:
 
<%
 Response.Buffer = True
 Dim strFilePath, strFileSize, strFileName
 
 Const adTypeBinary = 1
 
 strFilePath = Request.QueryString("path")
 strFileSize = Request.QueryString("size")
 strFileName = Request.QueryString("name")
 'strFilePath = server.MapPath(strFilePath & strFileName)
 
 Response.Clear
 
 Set objStream = Server.CreateObject("ADODB.Stream")
 objStream.Open
 objStream.Type = adTypeBinary
 objStream.LoadFromFile strFilePath
 
 strFileType = right(strFileName, len(strFileName) - instrrev(strFileName, "."))
 
    Select Case strFileType
        Case "asf"
            ContentType = "video/x-ms-asf"
        Case "avi"
            ContentType = "video/avi"
        Case "doc"
            ContentType = "application/msword"
        Case "zip"
            ContentType = "application/zip"
        Case "xls"
            ContentType = "application/vnd.ms-excel"
        Case "gif"
            ContentType = "image/gif"
        Case "jpg", "jpeg"
            ContentType = "image/jpeg"
        Case "wav"
            ContentType = "audio/wav"
        Case "mp3"
            ContentType = "audio/mpeg3"
        Case "mpg", "mpeg"
            ContentType = "video/mpeg"
        Case "rtf"
            ContentType = "application/rtf"
  Case "htm", "html"
            ContentType = "text/html"
  Case "asp"
            ContentType = "text/asp"
        Case Else
            'Handle All Other Files
            ContentType = "application/octet-stream"
    End Select
 
 
 Response.AddHeader "Content-Disposition", "attachment; filename=" & strFileName
 Response.AddHeader "Content-Length", strFileSize
 ' In a Perfect World, Your Client would also have UTF-8 as the default 
 ' In Their Browser
 Response.Charset = "UTF-8"
 Response.ContentType = ContentType
 
 Response.BinaryWrite objStream.Read
 Response.Flush
 objStream.Close
 Set objStream = Nothing
%>

continúa en el siguiente post....
__________________
Saruman

One Ring to rule them all, One Ring to find them, One Ring to bring them all and in the darkness bind them.
  #89 (permalink)  
Antiguo 15/11/2005, 12:37
Avatar de Saruman  
Fecha de Ingreso: mayo-2003
Ubicación: Panama city, Panama, Panama
Mensajes: 1.154
Antigüedad: 20 años, 10 meses
Puntos: 5
Sonrisa Mostrar diálogo "Guardar como..." para cualquier archivo, Parte II

...Continuación...

ahora, en el archivo funciones.asp colocamos las siguientes funciones necesarias para trabajar con el script de descargas. este archivo debe ir en el root.


funciones.asp

Código:
 
<%
'Si el Archivo existe en el Servidor
Function IsFileExists(strNombre)
 Set FSO = Server.CreateObject("Scripting.FileSystemObject")
 
 if FSO.FileExists(server.MapPath(strNombre)) = true then
  IsFileExists = true
 else
  IsFileExists = false
 end if
 
 set FSO = Nothing
End Function
'File Size
Function FileSize(Path, FileName, Tipo)
 if IsFolderExists(Path) = true and IsFileExists(Path & FileName) = true then
  set FSO = Server.CreateObject("Scripting.FileSystemObject")
  set oFile = FSO.GetFile(Server.MapPath(Path & FileName))
 
  FileSize = oFile.Size
 
  select case Tipo
   case 2:
    FileSize = Round(FileSize / 1024, 2)
   case 3:
    FileSize = Round(FileSize / 1048576, 2)
   case 4:
    FileSize = FileSize & " bytes"
   case 5:
    FileSize = Round(FileSize / 1024, 2) & " KB"
   case 6:
    FileSize = Round(FileSize / 1048576, 2) & " MB"
   case 7:
    if FileSize > 0 and FileSize < 1024 then
     FileSize = FileSize & " bytes"
    elseif FileSize >= 1024 and FileSize < 1048576 then
     FileSize = Round(FileSize / 1024, 2) & " KB"
    elseif FileSize >= 1048576 then
     FileSize = Round(FileSize / 1048576, 2) & " MB"
    end if
   case else
    FileSize = FileSize
  end select
 
  set oFile = nothing
  set FSO = nothing
 else
  FileSize = 0
 end if
End Function
'Comprobar si existe folder
Function IsFolderExists(Carpeta)
 set FSO = Server.CreateObject("Scripting.FileSystemObject")
 
 if Carpeta <> "" then
  if Not FSO.FolderExists(server.mappath(Carpeta)) then
   Folder_Exist = false
  else
   Folder_Exist = true
  end if
 else
  Folder_Exist = false
 end if
 
 IsFolderExists = Folder_Exist
End Function
%>

finalmente, un archivo default para hacer la prueba

default.asp

Código:
 
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" />
<title>Mostrar diálogo "Guardar como..."</title>
</head>
<body>
<!-- #include file="funciones.asp" -->
<%
 Ruta = "/ruta_del_archivo/"
 archivo = "archivo.ext"
 
 archivo_byte = FileSize(Ruta, archivo, 1)
 archivo_link = "descargar/startdownload.asp?path=" & Server.urlEncode(server.MapPath(Ruta & archivo)) & _
 "&name=" & Server.urlEncode(archivo) & "&size=" & archivo_byte
%>
<a href="<%=(archivo_link)%>" onMouseOver="self.status='Descargar el Archivo'; return true;" onMouseOut="self.status=''; return true;"><strong>PRESIONA AQUI PARA DESCARGAR EL ARCHIVO</strong></a>
</body>
</html>

si tienes alguna pregunta, no dudes en avisarme.
espero que este script sea de ayuda para muchos

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.
  #90 (permalink)  
Antiguo 16/01/2006, 16:15
Avatar de a n g e l u s  
Fecha de Ingreso: enero-2006
Ubicación: Chile
Mensajes: 237
Antigüedad: 18 años, 2 meses
Puntos: 1
FUNCION PARA BUSCAR EL ULTIMO REGISTRO INGRESADO EN LA BD, BASTANTE UTIL

ASI SE LLAMA
ultimodato = sqlmaximo(campo, tabla)

campo = corresponde autonumerico
tabla = tabla que buscas el ultimo registro ingresado

ESTA ES LA FUNCION

Function sqlmaximo( campo, tabla )
on error resume next
sql = "select max("&campo&") as maximo from "&tabla
set rsmax = db.execute(sql)
if err <> 0 then
Response.Write("ERROR :"&err.description&"<hr>")
else
if not rsmax.eof then
sqlmaximo = rsmax("maximo")
end if
rsmax.close
End Function
__________________
Atte,
A n g e l u s
Concepción - Chile
más vale respuestas bien pensadas, que 7000 post
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)




La zona horaria es GMT -6. Ahora son las 22:49.