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

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

posted on

2006-09-17 18:18

老夫狂傲江湖

阅读(66)

评论(0)

编辑

收藏