一个关于文件上传的问题。（给200分也不是问题啊）

[lovingfish]

目前网络上有很多文件上传的组件如：Upload等，但是功能不全，无法自己修改其中的设计，我想知道如何自己用VB写一个DLL的组件实现上传文件到数据库的功能。组件要实现将上一个网页通过method="POST" enctype="multipart/form-data" 传来的数据保存到数据库中，写出的代码要放在W98+PWS中运行正常，如果哪位知道怎样写请告诉我啊，最好有源代码，要VB的啊，或是介绍一些有相关文章的电子书给我看看也可以。（给200分啊）

[dgz01]

ASPCN。COM 上在有一个有源程序的

＊＊＊＊＊
打工好辛苦
＊＊＊＊＊
钞票好难赚
＊＊＊＊＊
编程好伤神
＊＊＊＊＊
光阴好易混
＊＊＊＊＊

[meetweb]

那好办。你用vb开发组件把数据库的密码写进.dll，调用asp不也可以解决

[newnewworm]

编写Dll吧！

[lovingfish]

我的意思就是这样，本人技术不好，自己从头写起没那本事啊，有没有哪位有DLL的VB原代码？

[dgz01]

ASPCN.COM上的ASPCNUP有DLL的源程序

＊＊＊＊＊
打工好辛苦
＊＊＊＊＊
钞票好难赚
＊＊＊＊＊
编程好伤神
＊＊＊＊＊
光阴好易混
＊＊＊＊＊

[cat_hsfz]

推荐用上面说的aspcnup，里面有完整例子，但是是保存成文件的。
如果要保护数据库密码，建议你用odbc，通过dsn链接

[lovingfish]

具体如何做啊？给一个代码吧，谢谢

[nice90]

98下好象不能够，因为很多文件上传需要FSO。

[lovingfish]

那个例子我写出后只能在2000下用，98下会出错啊。

[lovingfish]

FSO是什么？那其它的一些上传组件为什么都支持98？它们是怎么写出来的？

[xjbx]

我有段vb写的dll的原码，你看看！
（一）
类模块
-----------------------------

Option Explicit
Option Compare Text


Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Private poContext As ASPTypeLibrary.ScriptingContext
Private poRequest As ASPTypeLibrary.Request

Private psPath As String
Private psSaveAs As String
Private sData As String
Private poSavedRequest As New Scripting.Dictionary
Private psUserFileName As String
Private plFileStart As Long
Private plFileEnd As Long
Private pbNoFileName As Boolean
Private pbNoFileContents As Boolean
Private pbytArrContents() As Byte
Private pbytArrInput() As Byte
Private psError As String

'Header/content delimiter per RFC1867
Private Const HTTP_DELIMITER = "-----------------------------"
Private FORM_DATA As String

Public Sub OnStartPage(Sc As ScriptingContext)

'IIS Passes the scripting context to
'any component contained with the
'requested page
Dim iCtr As Integer

Set poContext = Sc
Set poRequest = poContext.Request
PopulateForm


End Sub

Public Property Get Path() As String
Dim s As String
If psPath = "" Then ResolveFileName (s)

Path = psPath
End Property

Public Property Let Path(ByVal NewValue As String)
If Right(NewValue, 1) <> "\" Then NewValue = NewValue & "\"
psPath = NewValue
End Property

Public Property Get FileName() As String
Dim s As String

If psSaveAs = "" Then ResolveFileName (s)
FileName = psSaveAs
End Property

Public Property Let FileName(ByVal NewValue As String)
Dim sFileName As String
sFileName = NewValue

'the replace statement is necessary probably due to a bug in
'in the populate form procedure.
'but it works, so do we care?

sFileName = Replace(NewValue, vbLf, "")

If InStr(sFileName, "\") > 0 Then
psSaveAs = NameFromFullPath(sFileName)
Path = PathOnly(sFileName)
Else
psSaveAs = TrimWithoutPrejudice(sFileName)
End If
End Property

[xjbx]

（二）
------------
Private Function PopulateForm() As Boolean

On Error GoTo ErrorHandler

Dim sFileName As String

Dim lBytes As Long

Dim sPath As String
Dim sSplit() As String
Dim lCtr As Long, iCtr As Long
Dim lCtr2 As Long, iCtr2 As Integer
Dim lFileCtr As Long

Dim sKey As String
Dim sValue As String
Dim sChar As String
Dim sTemp As String
Dim lSavedCtr As Long



lBytes = poRequest.TotalBytes
'save the entire request in a byte array
ReDim pbytArrInput(lBytes) As Byte

pbytArrInput = poRequest.BinaryRead(lBytes)


'save the http header, the end of which is indicated by
'two vbcrlfs

lCtr = 0
Do Until lCtr >= lBytes
sTemp = sTemp & Chr(pbytArrInput(lCtr))

lCtr = lCtr + 1
'check at certain lengths for items of interest
If sTemp = HTTP_DELIMITER Then

'this is the delimiter, move on to the next
lCtr = lCtr + 1
Do

sTemp = sTemp & Chr(pbytArrInput(lCtr))
If Right(sTemp, 2) = vbCrLf Then Exit Do
lCtr = lCtr + 1

Loop
sTemp = ""
lCtr = lCtr + 1

ElseIf sTemp = FORM_DATA Then

sTemp = ""
sKey = ""
'
'get the key
Do
If Chr(pbytArrInput(lCtr)) = Chr(34) Then Exit Do
'CopyMemory ByVal StrPtr(sKey) + 1, pbytArrInput(lCtr), 1
sKey = sKey & Chr(pbytArrInput(lCtr))
lCtr = lCtr + 1
Loop

[xjbx]

（三）

-----------
'see if this is the file name
For iCtr = lCtr To (lCtr + 11)

sTemp = sTemp & Chr(pbytArrInput(iCtr))
Next

If InStr(sTemp, "filename=") > 0 Then

sTemp = ""
lCtr = lCtr + 1
'move past "filename ="
Do
sChar = Chr(pbytArrInput(lCtr))
If sChar = Chr(34) Then Exit Do
lCtr = lCtr + 1
Loop

Do
lCtr = lCtr + 1
sChar = Chr(pbytArrInput(lCtr))
If sChar = Chr(34) Then Exit Do
'CopyMemory ByVal StrPtr(sTemp) + 1, pbytArrInput(lCtr), 1
sTemp = sTemp & Chr(pbytArrInput(lCtr))
Loop
If Trim(sTemp) = "" Then
pbNoFileName = True
pbNoFileContents = True
Else
AddToForm sKey, sTemp
'user file name
sSplit = Split(sTemp, "\")
'Other OS's use backslashes (I think)
'If I'm wrong, won't change anything anyway
If UBound(sSplit) = 0 Then sSplit = Split(sTemp, "/")
psUserFileName = sSplit(UBound(sSplit))


End If
'next line tells us content type, move past
lCtr = lCtr + 2
sTemp = ""
Do
lCtr = lCtr + 1

sTemp = sTemp & Chr(pbytArrInput(lCtr))
If Right(sTemp, 2) = vbCrLf Then Exit Do
Loop
sTemp = ""


'Now file contents. Get start point and end
'point in the byte array. Commit to disk when the
'user calls the save method. move forward 3 to account
'for vbcrlf

lCtr = lCtr + 3

plFileStart = lCtr

sValue = ""
Do

If Chr(pbytArrInput(lCtr)) = Left(HTTP_DELIMITER, 1) Then
sValue = ""

For iCtr2 = 1 To Len(HTTP_DELIMITER)


sValue = sValue & Chr(pbytArrInput(lCtr))
lCtr = lCtr + 1
Next

lSavedCtr = lCtr
If sValue = HTTP_DELIMITER Then
plFileEnd = lCtr

Exit Do
Else
lCtr = lSavedCtr
End If
End If

lCtr = lCtr + 1
Loop

[yhncom_36de]

我有，给你发送一个过来吧:

your email:

[xjbx]

呵呵，接着昨天的来---（四）
--------------------------
'now we can figure out the end point of the file's contents
plFileEnd = lCtr - (Len(HTTP_DELIMITER) + 2)
If plFileEnd <= plFileStart Then pbNoFileContents = True

If Not pbNoFileContents Then

ReDim pbytArrContents(plFileEnd - plFileStart)

CopyMemory pbytArrContents(0), pbytArrInput(plFileStart), plFileEnd - plFileStart




End If

'we're at a delimiter again, just move past it.
sValue = ""
Do Until Right(sValue, 2) = vbCrLf
sValue = sValue & Chr(pbytArrInput(lCtr))
lCtr = lCtr + 1
Loop

sTemp = ""

Else


lCtr = lCtr + 4

'read value
'until we hit HTTP_DELMITER we don't know
'that we have whole value. This is because value
'can be multiline

'if someone enter HTTP_DELIMITER as a value in your form
'this code dies. But that is very unlikely.
sValue = ""
Do

sValue = sValue & Chr(pbytArrInput(lCtr))
If Right(sValue, Len(HTTP_DELIMITER)) = HTTP_DELIMITER Then
If Len(TrimWithoutPrejudice(sValue)) <= Len(HTTP_DELIMITER) Then
sValue = ""
Else
sValue = Mid(sValue, 2, Len(sValue) - (Len(HTTP_DELIMITER) + 3))
End If
AddToForm sKey, sValue
sValue = ""
'we're at a delimiter again, just move past it.
Do Until Right(sValue, 2) = vbCrLf

sValue = sValue & Chr(pbytArrInput(lCtr))
lCtr = lCtr + 1
Loop

sTemp = ""
Exit Do
End If
lCtr = lCtr + 1
Loop
End If 'INSTR
Else


End If 'stemp = form_data

Loop

PopulateForm = True

Exit Function

ErrorHandler:
psError = Err.Description



End Function
Private Function AppPath() As String
'http://www.freevbcode.com/ShowCode.Asp?ID=878

Dim sAns As String
sAns = App.Path
If Right(App.Path, 1) <> "\" Then sAns = sAns & "\"
AppPath = sAns

End Function

Public Property Get Error() As String
Error = psError
End Property
Private Function ResolveFileName(FullPath As String) As Boolean
Dim sFileName As String
Dim sPath As String

'logic:
'if no path supplied, use app.path by default
'if no file name supplied, use the user's file name be default



If psPath = "" Then psPath = AppPath
sPath = psPath

sFileName = psSaveAs


If sFileName = "" Then
sFileName = psUserFileName
psSaveAs = psUserFileName

End If


ResolveFileName = Dir(psPath, vbDirectory) <> ""
If ResolveFileName = False Then
psError = sPath & " is an invalid path"
Else
FullPath = psPath & sFileName
End If


End Function

[xjbx]

（五）
---------------
Private Function NameFromFullPath(FullPath As String) As String
'Input: Name/Full Path of a file
'Returns: Name of file

Dim sPath As String
Dim sList() As String
Dim sAns As String
Dim iArrayLen As Integer

If Len(FullPath) = 0 Then Exit Function
sList = Split(FullPath, "\")
iArrayLen = UBound(sList)
sAns = IIf(iArrayLen = 0, "", sList(iArrayLen))

NameFromFullPath = sAns

End Function
Private Function PathOnly(FullPath As String) As String
'Input: Name/Full Path of a file
'Returns: Name of Directory Only

Dim sPath As String
Dim sList() As String
Dim sAns As String
Dim iArrayLen As Integer, iArrayStart As Integer


Dim iCtr As Integer

sList = Split(FullPath, "\")

iArrayStart = LBound(sList)
iArrayLen = UBound(sList) - 1

If iArrayLen > LBound(sList) Then
For iCtr = iArrayStart To iArrayLen
sAns = sAns & sList(iCtr) & "\"

Next
End If
PathOnly = sAns
End Function

Public Function Form(sKey As String) As String
If poSavedRequest.Exists(sKey) Then
Form = poSavedRequest(sKey)
End If

End Function


Private Function ByteArrayToString(bytArray() As Byte) As String
Dim sAns As String
Dim iPos As String

sAns = StrConv(bytArray, vbUnicode)
iPos = InStr(sAns, Chr(0))
If iPos > 0 Then sAns = Left(sAns, iPos - 1)

ByteArrayToString = sAns

End Function
Private Function AddToForm(Key As String, Data As String)
If poSavedRequest.Exists(Key) Then
poSavedRequest.Item(Key) = poSavedRequest.Item(Key) & ", " & Data
Else
poSavedRequest.Add Key, Data
End If


End Function
Private Function TrimWithoutPrejudice(ByVal InputString As String) As String
'http://www.freevbcode.com/ShowCode.ASP?ID=104
Dim sAns As String
Dim sWkg As String
Dim sChar As String
Dim lLen As Long
Dim lCtr As Long

sAns = InputString
lLen = Len(InputString)

If lLen > 0 Then
'Ltrim
For lCtr = 1 To lLen
sChar = Mid(sAns, lCtr, 1)
If Asc(sChar) > 32 Then Exit For
Next

sAns = Mid(sAns, lCtr)
lLen = Len(sAns)

'Rtrim
If lLen > 0 Then
For lCtr = lLen To 1 Step -1
sChar = Mid(sAns, lCtr, 1)
If Asc(sChar) > 32 Then Exit For
Next
End If
sAns = Left$(sAns, lCtr)
End If

TrimWithoutPrejudice = sAns

End Function

[xjbx]

（六）
Public Function Save() As Boolean
Dim lCtr As Long

Dim iFile As Integer
Dim sFullPath As String
Dim lLen As Long

On Error GoTo ErrorHandler
iFile = FreeFile

If pbNoFileName Then
psError = "No file was uploaded"
Exit Function
End If

If pbNoFileContents Then
psError = "Uploaded file was empty"
Exit Function
End If

'sfullpath is empty string passed byref
'will be populated by resolvefilename function

If Not ResolveFileName(sFullPath) Then Exit Function

If Dir(sFullPath) <> "" Then
On Error Resume Next
Kill sFullPath
On Error GoTo ErrorHandler
End If


Open sFullPath For Binary Access Write As #iFile
Put #iFile, , pbytArrContents
Close #iFile

Save = True
Exit Function
ErrorHandler:
psError = Err.Description

End Function

Private Sub Class_Initialize()
FORM_DATA = "Content-Disposition: form-data; name=" & Chr(34)
poSavedRequest.CompareMode = TextCompare


End Sub

Private Sub Class_Terminate()
Set poContext = Nothing
Set poSavedRequest = Nothing
Set poRequest = Nothing
Erase pbytArrInput

End Sub

完了！

[lovingfish]

能否把完整的VB代码发到我邮箱来？[e-mail] 谢谢！

[Lostinet]

倒，我写的那个就是VBS的
要转到VB中很容易~~~

<Script Language=JScript RunAt=Server>
/****************************************************************\
<lostinet:source xmlns:lostinet="lostinet-d2g-com/source">
<lostinet:source-info>
<lostinet:name>Lostinet_ASP_Upload</lostinet:name>
<lostinet:description>用ASP处理multipart/form-data上传来的数据</lostinet:description>
</lostinet:source-info>
<lostinet:author-info>
<lostinet:name>Lostinet</lostinet:name>
<lostinet:email>[e-mail];[e-mail];</lostinet:email>
<lostinet:homepage>http://lostinet.d2g.com</lostinet:homepage>
</lostinet:author-info>
<lostinet:copyright-info>
<lostinet:copyright>版权声明:这个软件可以随意发布。也可以根据具体情况进行优化修改。但是请保留作者的相关信息。</lostinet:copyright>
</lostinet:copyright-info>
</lostinet:source>
\****************************************************************/
</Script>
<Script Language=VBScript RunAt=Server>
Option Explicit

'替换内容，用来提取信息
Function GetFormData_ReplacePattern(str1,p,str2)
Dim re
Set re=new RegExp
re.IgnoreCase=true
re.Global=true
re.Pattern=p
GetFormData_ReplacePattern=re.Replace(str1,str2)
End Function

'二进制到Unicode
Function ASCII2Unicode(str)
dim strLen,res,I
strLen=LenB(str)
I=1
While I < strLen+1
If I<>strLen And AscB(MidB(str,I,1))>127 Then
res=res&Chr(AscB(MidB(str,I,1))*256+AscB(MidB(str,I+1,1)))
I=I+1
Else
res=res&ChrW(AscB(MidB(str,I,1)))
End If
I=I+1
Wend
ASCII2Unicode=res
End Function


'公共属性：
'IsFile 是否为File类型
'Name 表单的名字
'Size,Length 数据的长度

'非文件类型的表单数据
Class GetFormData_FormObject
Dim Value '表单的值
Dim IsFile,Name,Size,Length
Private Sub Class_Initialize
IsFile=false
End Sub
End Class

'文件类型的数据
Class GetFormData_FileObject
Dim FileName '文件在客户端时的路径
Dim ShortName '文件的短名字
Dim ContentType '文件的MIME类型
Dim Stream '公用的Stream
Dim StreamStart '这个FileObject的数据，在Stream的开始位置
Dim IsFile,Name,Size,Length
Private Sub Class_Initialize
IsFile=true
End Sub
Public Function GetData()
If Size=0 Then
GetData=""
Exit Function
End If
Stream.Position=StreamStart
GetData=Stream.Read(Size)
End Function
End Class

'从fn:filename 返回短文件名
Function GetFormData_ShortName(fn)
Dim pos1,pos2
pos1=InStrRev(fn,"\")
pos2=InStrRev(fn,"/")
If pos2>pos1 Then
pos1=pos2
End If
GetFormData_ShortName=Mid(fn,pos1+1,Len(fn)-pos1)
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'调用这个取得表单数据，详细用法，请看例子vbscript.asp
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub GetFormData(ByRef funcForm,ByRef funcFile)
Dim ContentType
ContentType=CStr(Request.ServerVariables("Content_Type"))
If InStr(1,LCase(ContentType),"multipart/form-data",1) = 0 Then
Err.Raise -1,"","只能是multipart/form-data","",0
End If
Dim data,Stream
data=Request.BinaryRead(Request.TotalBytes)
Set Stream=Server.CreateObject("ADODB.Stream")
Stream.Mode=3
Stream.Type=1
Stream.Open
Stream.Write(data)
Dim lb,pos,pos1,pos2,pos3,oldpos,spliter,spliterlen
lb=ChrW(2573)
pos=InStrB(1,data,lb,0)
spliter=LeftB(data,pos-1)
spliterlen=LenB(spliter)
pos=1
oldpos=1

Dim subdata,subdatalen,line1,line2
Dim objForm,objFile
Do
If pos <> 1 Then
subdatalen=pos-oldpos-spliterlen-4
subdata=MidB(data,oldpos+spliterlen+2,subdatalen)
pos1=InStrB(1,subdata,lb,0)
pos2=InStrB(pos1+2,subdata,lb,0)
pos3=InStrB(pos2+2,subdata,lb,0)
line1=ASCII2Unicode(LeftB(subdata,pos1-1))
If pos1+2 <> pos2 Then
Set objFile=new GetFormData_FileObject
objFile.Name=GetFormData_ReplacePattern(line1,"(^([^;]*)\s*;\s*name=\x22([^\s]*)\x22\s*;\s*filename=\x22([^\x22]*)\x22$)","$3")
objFile.FileName=GetFormData_ReplacePattern(line1,"(^([^;]*)\s*;\s*name=\x22([^\s]*)\x22\s*;\s*filename=\x22([^\x22]*)\x22$)","$4")
objFile.ShortName=GetFormData_ShortName(objFile.FileName)
line2=ASCII2Unicode(MidB(subdata,pos1+2,pos2-pos1-2))
objFile.ContentType=GetFormData_ReplacePattern(line2,"(\s*content-type\s*:\s*(\S)\s*)","$2")
objFile.Size=subdatalen-pos3-1
objFile.Length=objFile.Size
Set objFile.Stream=Stream
objFile.StreamStart=oldpos+spliterlen+2+pos3
Stream.Position=objFile.StreamStart
funcFile objFile
objFile=null
Else
Set objForm=new GetFormData_FormObject
objForm.Name=GetFormData_ReplacePattern(line1,"(([^;]*)\s*;\s*name=\x22([^\s]*)\x22)","$3")
objForm.Value=ASCII2Unicode(RightB(subdata,subdatalen-pos2-1))
objForm.Size=Len(objForm.Value)
objForm.Length=objForm.Size
funcForm objForm
objForm=null
End If
End If
oldpos=pos
pos=InStrB(pos+2,data,spliter,0)
Loop Until pos = 0
End Sub
</Script>

[Lostinet]

http://www.chinaok.net/down/lup.zip