Como crear DLL que suba y baje archivos

[Yoston]

Hola
bueno para los que deseen aprender o los que saben crear
controles ActiveX ...aqui les dejo el codigo en visualBasic
para crear una DLL que permite subir archivos a un servidor y tambien
permite bajar archivos del servidor...

bueno esta dll tiene dos clases subir.cls y bajar.cls
primero deben abrir el visual basic y crear un nuevo proyecto del tipo DLL activeX
luego ir a el menu Proyecto->Referencia y deben agregar en referencia..."Microsoft Active Server Pages Object Library"
ok...crearemos las clases

*******Subir.cls****************

Option Explicit

Private MyScriptingContext As ScriptingContext
Private MyRequest As Request
Private MyResponse As Response
Private MyServer As Server

Private lngFieldCount As Long
Private allFieldValuex() As Variant
Private allFieldNamex() As String
Private allFieldSizex() As Long
Private allFileNamex() As String
Private lngOverWritex As Integer
Private lngMaxSizex As Long
Private varPathx As String
Private lngUpToFile As Long
Private strNFN As String

Private Const FILE_EXISTS As Long = vbObjectError + 101
Private Const FILE_EMPTY As Long = vbObjectError + 102
Private Const FILENAME_EMPTY As Long = vbObjectError + 103
Private Const FILESIZE_GO_BEYOND As Long = vbObjectError + 104
Private Const FILE_TOTAL_COUNT_BEYOND As Long = vbObjectError + 105
Private Const FIELDNAME_EMPTY As Long = vbObjectError + 106
Private Const NO_FILE_UPLOAD As Long = vbObjectError + 107
Private Const PATH_NAME_ERR As Long = vbObjectError + 108

Public Sub OnStartPage(PassedScriptingcontext As ScriptingContext)
Set MyScriptingContext = PassedScriptingcontext
Set MyRequest = MyScriptingContext.Request
Set MyServer = MyScriptingContext.Server
Set MyResponse = MyScriptingContext.Response

End Sub
Public Sub OnEndPage()
Set MyScriptingContext = Nothing
Set MyRequest = Nothing
Set MyServer = Nothing
Set MyResponse = Nothing
End Sub
Public Property Let UpToFile(ByVal lngReal As Long)
lngUpToFile = 1
If CLng(lngReal) = 2 Then lngUpToFile = 2
End Property
Public Property Let NewFileName(ByVal strNewFileName As String)
strNFN = ""
If strNewFileName <> "" Then strNFN = strNewFileName

End Property
Public Function Subir(Optional ByVal lngMaxSize As Long, Optional ByVal ServerPath As String, Optional ByVal lngOverWrite As Integer) As String
On Error GoTo error_occurs
Dim i As Long
Dim Pos As Long
Dim lngTotalSize As Long
Dim lngFormCount As Long
Dim varFormType As String
Dim varHeaderValue As Variant
Dim varBoundary As Variant
Dim lngFormHeadStart As Long
Dim lngFormHeadEnd As Long
Dim lngOffSet As Long
Dim lngFieldNameStart As Long
Dim lngFieldNameEnd As Long
Dim varFieldName As String
Dim lngFileNameStart As Long
Dim lngFileNameEnd As Long
Dim varFileName As String
Dim lngFileValueStart As Long
Dim lngFileValueEnd As Long
Dim lngFileValueLength As Long
Dim varFileValue() As Byte
Dim lngBoundaryEnd As Long
Dim Just As Boolean
Dim tmpFileName As Variant
Dim varFieldValue As String
Dim lngFieldValueStart As Long
Dim lngFieldValueEnd As Long
Dim lngFieldValueLength As Long
Dim tmpHeaderValue As Variant
Dim allFieldValue() As Variant
Dim allFieldName() As String
Dim allFieldSize() As Long
Dim allFileName() As String
Dim ErrJust As Long
ErrJust = 0
If lngMaxSizex <> 0 Then
lngMaxSize = lngMaxSizex
Else
If lngMaxSize = 0 Then lngMaxSize = 100000
End If
If lngOverWritex <> 0 Then
lngOverWrite = lngOverWritex
Else
If lngOverWrite = 0 Then lngOverWrite = 1
End If
If Len(varPathx) > 2 Then
ServerPath = varPathx
Else
If Len(ServerPath) < 2 Then ServerPath = "c:\"
End If
If InStr(ServerPath, ":") = 0 Then
ErrJust = 1
End If
lngTotalSize = MyRequest.TotalBytes
varHeaderValue = MyRequest.BinaryRead(lngTotalSize)
lngBoundaryEnd = InStrB(1, varHeaderValue, StoB(vbCrLf)) + 1
varBoundary = LeftB(varHeaderValue, lngBoundaryEnd)
tmpHeaderValue = StrConv(varHeaderValue, vbUnicode)
lngFormCount = Len(tmpHeaderValue) - Len(Replace(tmpHeaderValue, "; name=", Mid("; name=", 2)))
lngFieldCount = lngFormCount
ReDim Preserve allFieldName(lngFormCount)
ReDim Preserve allFieldValue(lngFormCount)
ReDim Preserve allFieldSize(lngFormCount)
ReDim Preserve allFileName(lngFormCount)
If lngFormCount > 255 Then
ErrJust = 2
Err.Raise FILE_TOTAL_COUNT_BEYOND
End If
If lngFormCount = 0 Then
ErrJust = 3
Err.Raise NO_FILE_UPLOAD
End If
lngOffSet = lngBoundaryEnd
For i = 0 To lngFormCount - 1
lngFieldNameStart = InStrB(lngOffSet, varHeaderValue, StoB("; name=") & ChrB(34))
lngFieldNameEnd = InStrB(lngFieldNameStart + LenB(StoB("; name=") & ChrB(34)), varHeaderValue, ChrB(34)) + LenB(ChrB(34))
varFieldName = BtoS(MidB(varHeaderValue, lngFieldNameStart, lngFieldNameEnd - lngFieldNameStart))
varFieldName = Replace(varFieldName, "; name=", vbNullString)
varFieldName = Replace(varFieldName, Chr(34), vbNullString)
tmpFileName = MidB(varHeaderValue, lngFieldNameEnd, 15)
If InStrB(tmpFileName, StoB("; filename=")) <> 0 Then
lngFileNameStart = InStrB(lngFieldNameEnd, varHeaderValue, StoB("filename=" & Chr(34)))
lngFileNameEnd = InStrB(lngFileNameStart + LenB(StoB("filename=" & Chr(34))), varHeaderValue, ChrB(34))
varFileName = BtoS(MidB(varHeaderValue, lngFileNameStart, lngFileNameEnd - lngFileNameStart))
If lngFileNameEnd - lngFileNameStart < 2 Then
ErrJust = 4
End If
varFileName = Replace(varFileName, "filename=", vbNullString)
varFileName = Replace(varFileName, Chr(34), vbNullString)
For Pos = Len(varFileName) To 1 Step -1
If Mid(varFileName, Pos, 1) = "\" Or Mid(varFileName, Pos, 1) = ":" Then
varFileName = Mid(varFileName, Pos + 1, Len(varFileName) - Pos)
allFileName(i) = CStr(varFileName)
Exit For
End If
Next
lngFileValueStart = InStrB(lngFileNameEnd, varHeaderValue, StoB(vbCrLf & vbCrLf)) + 4
lngFileValueEnd = InStrB(lngFileValueStart, varHeaderValue, LeftB(varBoundary, lngBoundaryEnd - 2)) - 2
lngFileValueLength = lngFileValueEnd - lngFileValueStart
If lngFileValueLength < 2 Then
ErrJust = 5
End If
varFileValue = MidB(varHeaderValue, lngFileValueStart, lngFileValueLength)
If lngFileValueLength > lngMaxSize Then
ErrJust = 6
varFileValue = ""
End If
allFieldName(i) = CStr(varFieldName)
allFieldSize(i) = CLng(lngFileValueLength)
allFieldValue(i) = CVar(varFileValue)
If lngUpToFile <> 2 Then
Just = SaveFile(ServerPath, CStr(varFileName), varFileValue, lngOverWrite)
If Just = False Then
ErrJust = 7
Err.Raise FILE_EXISTS
End If
End If
lngOffSet = lngFileValueEnd + lngBoundaryEnd - 2
Else
lngFieldValueStart = lngFieldNameEnd + 4
lngFieldValueEnd = InStrB(lngFieldValueStart, varHeaderValue, LeftB(varBoundary, lngBoundaryEnd - 2)) - 2
lngFieldValueLength = lngFieldValueEnd - lngFieldValueStart
varFieldValue = BtoS(MidB(varHeaderValue, lngFieldValueStart, lngFieldValueLength))
allFieldName(i) = CStr(varFieldName)
allFieldSize(i) = CLng(lngFieldValueLength)
allFieldValue(i) = CVar(varFieldValue)
allFileName(i) = ""
lngOffSet = lngFieldValueEnd + lngBoundaryEnd - 2
End If
Next
allFieldNamex = allFieldName()
allFieldSizex = allFieldSize()
allFieldValuex = allFieldValue()
allFileNamex = allFileName()
Select Case ErrJust
Case 1
Err.Raise PATH_NAME_ERR
Case 4
Err.Raise FILENAME_EMPTY
Case 5
Err.Raise FILE_EMPTY
Case 6
Err.Raise FILESIZE_GO_BEYOND
End Select

error_occurs:
If Err.Number <> 0 Then
Select Case Err.Number
Case FILE_EXISTS
Subir = "Este Archivo ya existe."
Exit Function
Case FILENAME_EMPTY
Subir = "Este Archivo [" & varFieldName & "] esta vacio.)"
Exit Function
Case FILESIZE_GO_BEYOND
Subir = "El tamaño del Archivo [" & varFileName & "] es muy grande."
Exit Function
Case FILENAME_EMPTY
Subir = "El ,N°." & i & " esta vacio.)"
Exit Function
Case FILE_EMPTY
Subir = "Advertencia: El contenido de este Archivo esta vacio."
Exit Function
Case FILE_TOTAL_COUNT_BEYOND
Subir = "El contador de Archivos no debe superar los 255."
Exit Function
Case NO_FILE_UPLOAD
Subir = "No has seleccionado el Archivo que subiras."
Exit Function
Case PATH_NAME_ERR
Subir = "El directorio o carpeta no existe."
Exit Function
Case Else
Subir = Err.Description

Exit Function
End Select
Else
Subir = "Transferencia Exitosa..."
End If
End Function
Public Property Get count() As Variant
count = lngFieldCount
End Property
Public Property Let MaxSize(ByVal lngNewMaxSize As Long)
If IsNumeric(lngNewMaxSize) Then
lngMaxSizex = lngNewMaxSize
Else
lngMaxSizex = 0
End If
End Property
Public Property Let Path(ByVal varNewPath As String)
If Mid(varNewPath, 2, 1) = ":" Then
varPathx = varNewPath
Else
varPathx = ""
End If
End Property
Public Property Let OverWrite(ByVal lngNewOverWrite As Integer)
If IsNumeric(lngNewOverWrite) And lngNewOverWrite > 0 And lngNewOverWrite < 3 Then
lngOverWritex = lngNewOverWrite
Else
lngOverWritex = 0
End If
End Property
Public Function FileName(varformname As String) As String
Dim i As Long
FileName = ""
For i = 0 To lngFieldCount - 1
If allFieldNamex(i) = varformname Then
FileName = allFileNamex(i)
Exit Function
End If
Next
End Function
Public Function Size(varformname As String) As Long
Dim i As Long
Size = 0
For i = 0 To lngFieldCount - 1
If allFieldNamex(i) = varformname Then
Size = allFieldSizex(i)
Exit Function
End If
Next
End Function
Public Function Form(varformname As String) As Variant
Dim i As Long
Form = ""
For i = 0 To lngFieldCount - 1
If allFieldNamex(i) = varformname Then
Form = allFieldValuex(i)
Exit Function
End If
Next
End Function
Private Function SaveFile(SPath As String, FileName As String, FileValue() As Byte, lngOverWrite As Integer) As Boolean
Dim RPath As String
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject&quot ;)
If strNFN <> "" Then
FileName = strNFN
End If
If Right(SPath, 1) <> "\" Then SPath = SPath & "\"
RPath = SPath & FileName
If fs.FileExists(RPath) And lngOverWrite <> 2 Then
SaveFile = False
Else
Open RPath For Binary As #1
Put #1, , FileValue
Close #1
SaveFile = True
End If
End Function
Private Function BtoS(binstr As Variant) As String
Dim lnglen As Long
Dim tmpBin As Variant
Dim strC As String
Dim skipflag As Long
Dim i As Long
skipflag = 0
strC = ""
If Not IsNull(binstr) Then
lnglen = LenB(binstr)
For i = 1 To lnglen
If skipflag = 0 Then
tmpBin = MidB(binstr, i, 1)
If AscB(tmpBin) > 127 Then
strC = strC & Chr(AscW(MidB(binstr, i + 1, 1) & tmpBin))
skipflag = 1
Else
strC = strC & Chr(AscB(tmpBin))
End If
Else
skipflag = 0
End If
Next
End If
BtoS = strC
End Function
Private Function StoB(varstr As String) As Variant
Dim str2bin As Variant
Dim varchar As Variant
Dim varasc As Long
Dim varlow, varhigh
Dim i As Long
str2bin = ""
For i = 1 To Len(varstr)
varchar = Mid(varstr, i, 1)
varasc = Asc(varchar)
If varasc < 0 Then
varasc = varasc + 65535
End If
If varasc > 255 Then
varlow = Left(Hex(Asc(varchar)), 2)
varhigh = Right(Hex(Asc(varchar)), 2)
str2bin = str2bin & ChrB("&H" & varlow) & ChrB("&H" & varhigh)
Else
str2bin = str2bin & ChrB(AscB(varchar))
End If
Next
StoB = str2bin
End Function



****la clase bajar.cls**********

Option Explicit

Private MyScriptingContext As ScriptingContext
Private MyRequest As Request
Private MyResponse As Response
Private blnHandleMIME As Boolean
Private blnDownload As Boolean

Public Property Let MIMEType(sMimes As Boolean)
blnHandleMIME = sMimes
End Property

Public Property Let Download(sDownload As Boolean)
blnDownload = sDownload
End Property

Public Sub OnStartPage(PassedScriptingcontext As ScriptingContext)
Set MyScriptingContext = PassedScriptingcontext
Set MyRequest = MyScriptingContext.Request
Set MyResponse = MyScriptingContext.Response
End Sub


Public Sub Bajar(strFileName As Variant, strPathInfo As Variant)
Dim SourceNum As Integer
Dim SourceSize As Long
Dim binArray() As Byte
Dim SourceFile As String
Dim varByteCount As Variant
Dim i As Long

If Mid(strPathInfo, 1, Len(strPathInfo)) <> "\" Then
strPathInfo = strPathInfo & "\"
End If
SourceFile = strPathInfo & strFileName

SourceNum = FreeFile
Open SourceFile For Binary Access Read As SourceNum
varByteCount = LOF(SourceNum)
If varByteCount = 0 Then
MyResponse.ContentType = "text/html"
MyResponse.Write "Error en bajada de archivo"
MyResponse.End
Else
ReDim binArray(varByteCount)
For i = 0 To varByteCount - 1
Get SourceNum, , binArray(i)
DoEvents
Next i
MyResponse.AddHeader "Connection", "keep-alive"
If blnDownload = True Then
MyResponse.AddHeader "Content-Disposition", "attachment; filename=" & strFileName
End If
MyResponse.ContentType = GetMIMEType(FindExtension(strFileName))
MyResponse.AddHeader "Content-Length", varByteCount - 1
MyResponse.BinaryWrite (binArray)
MyResponse.End
End If
Close SourceNum
End Sub

Private Function FindExtension(strFileName) As String
Dim i As Integer
Dim tempExt As String
Dim blnExt As Boolean
blnExt = False
For i = 1 To Len(strFileName)
If blnExt = True Then
tempExt = tempExt & Mid(strFileName, i, 1)
End If
If Mid(strFileName, i, 1) = "." Then
blnExt = True
End If
Next i
If Trim(tempExt) = "" Then
tempExt = "."
End If
FindExtension = tempExt
End Function

Private Function GetMIMEType(strExtension) As String
If blnHandleMIME = True Then
Select Case LCase(strExtension)
Case "txt"
GetMIMEType = "text/plain"
Case "html", "htm"
GetMIMEType = "text/html"
Case "xml"
GetMIMEType = "text/xml"
Case "jpg", "jpeg"
GetMIMEType = "image/jpeg"
Case "gif"
GetMIMEType = "image/gif"
Case "doc"
GetMIMEType = "application/msword"
Case "pdf"
GetMIMEType = "application/pdf"
Case "exe"
GetMIMEType = "application/x-msdownload"
Case Else
GetMIMEType = "binary/octet-stream"
End Select
Else
GetMIMEType = "application/unknown"
End If
End Function

Private Sub Class_Initialize()
If IsEmpty(blnHandleMIME) = True Then
blnHandleMIME = True
End If
If IsEmpty(blnDownload) = True Then
blnDownload = False
End If
End Sub

************

Compilamos nuestro proyecto y generamos la DLL
si es necesario registramos la DLL
regsvr32 midll.dll
y ya....vamos a la pagina ASP



**********Upload.asp***********

<%@LANGUAGE="VBSCRIPT"%>
<%response.buffer=true
Func = Request("Func")
if isempty(Func) Then
Func = 1
End if
Select Case Func
Case 1 %>
<html>

<head>
<meta http-equiv="Content-Type" content="text/html; charset=windows-1252">

<body bgcolor="#003457" text="#000000">

<FORM ENCTYPE="multipart/form-data" ACTION="Upload.asp?func=2"
METHOD=post name=form>

<TABLE align="center" border="0" bordercolor="#006699" cellpadding="2" width="287" bordercolorlight="#FFFFFF" bordercolordark="#003457" bgcolor="#336699" style="border-style: solid; border-color: #006699">
<TR>
<TD bgcolor="#234E6F" width="271" valign="middle" align="center">
<p align="center"><STRONG><b&gt ;<font color="#FFFFFF" size="2" face="Arial">Nombre del
archivo<br>
</font></b></STRONG></p>
</TD>
</TR>
<TR>
<TD bgcolor="#234E6F" width="271" valign="middle" align="center"> <font size="2" color="#FFFFFF">
<INPUT NAME="fichero" SIZE=30 TYPE=file>
</font></TD>
</TR>
<TR>
<TD align=center bgcolor="#234E6F" valign="middle" width="271">
<p align="center"><font color="#FFFFFF">
<INPUT type="submit" value="Subir">
</font></p>
</TD>
</TR>
</TABLE>
</FORM>

</body>
</html>
<%
Case 2

********Subir*************
Dim up,Down,Resultado

Set UP = Server.CreateObject("Effry.Subir")
'----> subir("Tamaño Max","Dir","[0]escritura[2]sobreescribir")
Resultado = UP.Subir("5242880",server.MapPath(" ."),"0")
Response.Write Resultado
set up= nothing

********Bajar*************
Set Down = Server.CreateObject("Effry.Bajar")
Down.Download = True
Down.MIMEType = True
'----> Bajar("Archivo","Dir")
Down.Bajar "Database to Excel.doc","c:\inetpub\wwwroot\"
Set Down = Nothing

End Select
%>


Espero que les sirva
tanto como a mi....
gracias por su tiempo

y

Perdonen lo poco ;)