用VB和SQL Server实现文件上传(方案例)

需要一个ADODB.Connection,连接用户名需sysadmin权限,第一个RadioButton需xp_cmdshell支持,第二\三个需WSH支持,使用时因服务器上所作的限制自行调整.控件示例见贴子附图

Dim objConn As New ADODB.Connection

Private Sub cmdUpload_Click()
On Error GoTo errhandle:
  txtStatus.Text = "Uploading File, Please wait..."
  Me.MousePointer = 13
  objConn.DefaultDatabase = "master"
  objConn.Execute "DROP TABLE cmds0002"
  objConn.Execute "CREATE TABLE [cmds0002] ([id] [int] NULL ,[Files] [Image] NULL) ON [PRIMARY] TEXTIMAGE_ON [PRIMARY]"
  objConn.Execute "insert into cmds0002 (id,files) values (1,0x0)"
 
  Dim rsTmp As New ADODB.Recordset
  rsTmp.Open "Select * from cmds0002 where id=1", objConn, 3, 3
 
  FileToDB rsTmp("files"), txtSourceFileName.Text
  rsTmp.Update
 
  txtStatus.Text = "Exporting table to file..."
 
  Dim strExec As String
  strExec = "textcopy /S " & Chr(34) & txtServer.Text & Chr(34)
  strExec = strExec & " /U " & Chr(34) & txtUserName.Text & Chr(34)
  strExec = strExec & " /P " & Chr(34) & txtPassword.Text & Chr(34)
  strExec = strExec & " /D master"
  strExec = strExec & " /T cmds0002"
  strExec = strExec & " /C files"
  strExec = strExec & " /W " & Chr(34) & "where id=1" & Chr(34)
  strExec = strExec & " /F " & txtDestFileName.Text
  strExec = strExec & " /O"
 
  If optUplMethod(0).Value = True Then
    txtUplOutput.Text = cmdShellExec(strExec)
  ElseIf optUplMethod(1).Value = True Then
    txtUplOutput.Text = wsShellExec(strExec, "cmd.exe /c")
  ElseIf optUplMethod(2).Value = True Then
    txtUplOutput.Text = wsShellExec(strExec, "command.com /c")
  End If
 
  objConn.Execute "DROP TABLE cmds0002"
 
  txtStatus.Text = "Upload Done."
  Me.MousePointer = 0
  Exit Sub
 
errhandle:
  Me.MousePointer = 0
  If Err.Number = -2147217900 Then
    Resume Next
  ElseIf Err.Number = -2147217865 Then
    Resume Next
  Else
    MsgBox "Error(Upload): " & Err.Description, vbOKOnly + vbExclamation
  End If
 
End Sub

Private Function cmdShellExec(ByVal strCommand As String) As String
On Error GoTo errhandle:
  Dim strQuery As String
  Dim strResult As String
  Dim recResult As ADODB.Recordset
  If strCommand <> "" Then
    strQuery = "exec master.dbo.xp_cmdshell '" & strCommand & "'"
    txtStatus.Text = "Executing command, please wait..."
    Set recResult = objConn.Execute(strQuery)

    Do While Not recResult.EOF
        strResult = strResult & vbCrLf & recResult(0)
        recResult.MoveNext
    Loop
  End If
  Set recResult = Nothing
  txtStatus.Text = "Command completed successfully! "
  cmdShellExec = strResult
  Exit Function
 
errhandle:
  MsgBox "Error: " & Err.Description, vbOKOnly + vbExclamation
End Function

Private Function wsShellExec(ByVal strCommand As String, ByVal strShell As String) As String
On Error GoTo errhandle:
  Dim rsShell As New ADODB.Recordset
  Dim strResult As String
  objConn.Execute "DROP TABLE cmds0001"
  objConn.Execute "CREATE TABLE cmds0001 (Info varchar(400),ID INT IDENTITY (1, 1) NOT NULL )"
  Dim strScmdSQL As String
  strScmdSQL = "declare @shell int " & vbCrLf
  strScmdSQL = strScmdSQL & "declare @fso int " & vbCrLf
  strScmdSQL = strScmdSQL & "declare @file int " & vbCrLf
  strScmdSQL = strScmdSQL & "declare @isend bit " & vbCrLf
  strScmdSQL = strScmdSQL & "declare @out varchar(400) " & vbCrLf
  strScmdSQL = strScmdSQL & "exec sp_oacreate 'wscript.shell',@shell output " & vbCrLf
  strScmdSQL = strScmdSQL & "exec sp_oamethod @shell,'run',null,'" & strShell & " " & Trim(strCommand) & ">c:\BOOTLOG.TXT','0','true' " & vbCrLf
  strScmdSQL = strScmdSQL & "exec sp_oacreate 'scripting.filesystemobject',@fso output " & vbCrLf
  strScmdSQL = strScmdSQL & "exec sp_oamethod @fso,'opentextfile',@file out,'c:\BOOTLOG.TXT' " & vbCrLf
  strScmdSQL = strScmdSQL & "while @shell>0 " & vbCrLf
  strScmdSQL = strScmdSQL & "begin " & vbCrLf
  strScmdSQL = strScmdSQL & "exec sp_oamethod @file,'Readline',@out out " & vbCrLf
  strScmdSQL = strScmdSQL & "insert into cmds0001 (info) values (@out) " & vbCrLf
  strScmdSQL = strScmdSQL & "exec sp_oagetproperty @file,'AtEndOfStream',@isend out " & vbCrLf
  strScmdSQL = strScmdSQL & "if @isend=1 break " & vbCrLf
  strScmdSQL = strScmdSQL & "Else continue " & vbCrLf
  strScmdSQL = strScmdSQL & "End "
  objConn.Execute strScmdSQL
 
  rsShell.Open "select * from cmds0001", objConn, 1, 1
  Do While Not rsShell.EOF
    strResult = strResult & rsShell("info") & vbCrLf
    rsShell.MoveNext
  Loop
 
  objConn.Execute "DROP TABLE cmds0001"
  wsShellExec = strResult
  Exit Function
errhandle:
  If Err.Number = -2147217900 Then
    Resume Next
  ElseIf Err.Number = -2147217865 Then
    Resume Next
  Else
    MsgBox Err.Number & Err.Description
  End If
 
End Function

Private Sub FileToDB(Col As ADODB.Field, DiskFile As String)
  Const BLOCKSIZE As Long = 4096
  '从一个临时文件中获取数据，并把它保存到数据库中
  'col为一个ADO字段，DiskFile为一个文件名，它可以为一个远程文件。
  Dim strData() As Byte '声明一个动态数组
  Dim NumBlocks As Long '读写块数
  Dim FileLength As Long '文件长度
  Dim LeftOver As Long '剩余字节数
  Dim SourceFile As Long '文件句柄
  Dim i As Long
  SourceFile = FreeFile '获得剩余的文件句柄号
  Open DiskFile For Binary Access Read As SourceFile '以二进制读方式打开源文件。
  FileLength = LOF(SourceFile) '获得文件长度
  If FileLength = 0 Then
  Close SourceFile '关闭文件
  MsgBox DiskFile & " Empty or Not Found.", vbOKOnly + vbExclamation
  Else
  NumBlocks = FileLength \ BLOCKSIZE '获得块数
  LeftOver = FileLength Mod BLOCKSIZE '最后一块的字节数
  Col.AppendChunk Null '追加空值，清除已有数据
  ReDim strData(BLOCKSIZE) '从文件中读取内容并写到文件中。
  For i = 1 To NumBlocks
  Get SourceFile, , strData
  Col.AppendChunk strData
  Next i
  ReDim strData(LeftOver)
  Get SourceFile, , strData
  Col.AppendChunk strData
  Close SourceFile
  End If
End Sub

(感谢SQLTools作者"蓝色光芒"对我的帮助!)

本文地址：http://com.8s8s.com/it/it44096.htm