Using VB and SQL Server to implement file upload (square case)

server| upload Need a adodb.connection, connect user name need sysadmin authority, first RadioButton need xp_cmdshell support, second \ Three need WSH support, When used, it adjusts itself as a result of the restrictions on the server. Example of a control see the post drawings

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 (+) & Txtserver.text & Chr (34)
Strexec = Strexec & "U" & Chr (+) & txtUsername.Text & Chr (34)
Strexec = strexec & "/P" & Chr (+) & txtPassword.Text & Chr (34)
Strexec = strexec & "/D master"
Strexec = strexec & "/T cmds0002"
Strexec = strexec & "/C Files"
Strexec = strexec & "/w" & Chr (+) & "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 as 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), 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" & 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 as 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
' Get the data from a temporary file and save it to the database
' Col is an ADO field, Diskfile is a filename, it can be a remote file.
Dim strdata () as Byte declares a dynamic array
Dim numblocks as Long ' Read and write block number
Dim filelength as Long ' file length
Dim leftover as Long ' number of bytes left
Dim sourcefile as Long ' file handle
Dim I as Long
SourceFile = FreeFile ' Gets the remaining file handle number
Open Diskfile for Binary Access read as sourcefile opens the source file in binary read mode.
Filelength = LOF (sourcefile) ' Get file length
If filelength = 0 Then
Close SourceFile ' closes file
MsgBox Diskfile & "Empty or not Found.", vbOKOnly + vbexclamation
Else
Numblocks = filelength \ BLOCKSIZE ' Get the number of blocks
leftover = filelength Mod BLOCKSIZE ' last byte number
Col.appendchunk null ' append null value to clear existing data
ReDim strdata (BLOCKSIZE) ' reads the content from the file and writes it to the file.
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