2.8w+
社区成员
- 主页
一个关于文件上传的问题。（给200分也不是问题啊）
目前网络上有很多文件上传的组件如：Upload等，但是功能不全，无法自己修改其中的设计，我想知道如何自己用VB写一个DLL的组件实现上传文件到数据库的功能。组件要实现将上一个网页通过method="POST" enctype="multipart/form-data" 传来的数据保存到数据库中，写出的代码要放在W98+PWS中运行正常，如果哪位知道怎样写请告诉我啊，最好有源代码，要VB的啊，或是介绍一些有相关文章的电子书给我看看也可以。（给200分啊）
...全文
请发表友善的回复…
发表回复
Lostinet 2002-08-20
http://www.chinaok.net/down/lup.zip
Lostinet 2002-08-20
倒，我写的那个就是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>lostinet@21cn.com;lostinet@chongjian.com;</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>
要转到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>lostinet@21cn.com;lostinet@chongjian.com;</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>
lovingfish 2002-08-20
能否把完整的VB代码发到我邮箱来？btn.nb@163.com 谢谢！
ijianbo 2002-08-15
（六）
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
完了！
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
完了！
ijianbo 2002-08-15
（五）
---------------
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
---------------
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
ijianbo 2002-08-15
呵呵，接着昨天的来---（四）
--------------------------
'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
--------------------------
'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
yhncom_36de 2002-08-14
我有，给你发送一个过来吧:
your email:
your email:
ijianbo 2002-08-14
（三）
-----------
'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
-----------
'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
ijianbo 2002-08-14
（二）
------------
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
------------
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
ijianbo 2002-08-14
我有段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
（一）
类模块
-----------------------------
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
lovingfish 2002-08-12
FSO是什么？那其它的一些上传组件为什么都支持98？它们是怎么写出来的？
lovingfish 2002-08-10
那个例子我写出后只能在2000下用，98下会出错啊。
nice90 2002-08-10
98下好象不能够，因为很多文件上传需要FSO。
lovingfish 2002-08-02
具体如何做啊？给一个代码吧，谢谢
CatChen 2002-08-02
推荐用上面说的aspcnup，里面有完整例子，但是是保存成文件的。
如果要保护数据库密码，建议你用odbc，通过dsn链接
如果要保护数据库密码，建议你用odbc，通过dsn链接
dgz01 2002-08-02
ASPCN.COM上的ASPCNUP有DLL的源程序
＊＊＊＊＊
打工好辛苦
＊＊＊＊＊
钞票好难赚
＊＊＊＊＊
编程好伤神
＊＊＊＊＊
光阴好易混
＊＊＊＊＊
＊＊＊＊＊
打工好辛苦
＊＊＊＊＊
钞票好难赚
＊＊＊＊＊
编程好伤神
＊＊＊＊＊
光阴好易混
＊＊＊＊＊
lovingfish 2002-08-02
我的意思就是这样，本人技术不好，自己从头写起没那本事啊，有没有哪位有DLL的VB原代码？
newnewworm 2002-08-02
编写Dll吧！
meetweb 2002-08-01
那好办。你用vb开发组件把数据库的密码写进.dll，调用asp不也可以解决
dgz01 2002-07-31
ASPCN。COM 上在有一个有源程序的
＊＊＊＊＊
打工好辛苦
＊＊＊＊＊
钞票好难赚
＊＊＊＊＊
编程好伤神
＊＊＊＊＊
光阴好易混
＊＊＊＊＊
＊＊＊＊＊
打工好辛苦
＊＊＊＊＊
钞票好难赚
＊＊＊＊＊
编程好伤神
＊＊＊＊＊
光阴好易混
＊＊＊＊＊