简易vb连接sql server实例
需引用Microsoft ActiveX Data Objects
```vbnetPrivate Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _(ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPrivate Const SW_SHOW = 5'联盟订单回撤Private Sub Command1_Click()If connT = True ThenDim aa = Text1.TextIf Mid(a, 1, 6) = "LIFEMG" ThenSQL = "update AskForm set State=0 where billno='" & a & "';"RunSQL (SQL)ElseText1.Text = "输入单号！！！LIFEMG开头"End IfElseMsgBox ("当前数据库无法连接，请尝试连接测试后重试！")End IfEnd Sub'找回消失的批发销售单Private Sub Command3_Click()If connT = True ThenDim bb = Text6.TextIf Mid(b, 1, 3) = "XHC" ThenSQL = "INSERT INTO PFSALEDETAIL SELECT PFSaleNo,SerialNo,PluCode,BarCode,PluName,CargoNo,Spec,ProdArea,Punit,Pcount,Unit,Price,Jprice,NetJPrice, OrnPrice,ZkRate,PFPrice,Counts,ZpCount,PFTotal,ZRTotal,Cost,NetCost,Total,JtaxRate,Tag,DepName,DepCode,Remark, ItemCnt,SglCount,OrnPFTotal,YSTotal,RtnTotal,RtnRate,PluDscTotal,ShareTotal,DscCode,AuthNo,null,null,null,null,null,null,0,0,0,0 FROM PFSaleDetail2 b WHERE b.PFSaleNo='" & a & "';"RunSQL (SQL)ElseText6.Text = "输入单号！！！XHC开头"End IfElseMsgBox ("当前数据库无法连接，请尝试连接测试后重试！")End IfEnd Sub'连接测试按钮Private Sub Command2_Click()ipadd = Text2.Textdbase = Text3.Textdbpwd = Text4.TextCall ConnectToDataBaseEnd Sub'直接执行SQLPrivate Sub Command4_Click()If connT = True ThenSQL = Text5.TextDim SpwdSpwd = "password"If (Spwd = InputBox("请输入密码确认,本操作无法回撤", "谨慎操作，非专业人士勿动", "Input password to continue!", 7000, 7000)) ThenMsgBox ("密码正确，继续操作")RunSQL (SQL)ElseMsgBox ("密码错误，非IT请勿操作")End IfElseMsgBox ("当前数据库无法连接，请尝试连接测试后重试！")End IfEnd Sub'其他用户正在进行日结帐Private Sub Command5_Click()If connT = True ThenSQL = "delete from SysCfg where Section='SYSTEM' and ItemName='OVER';"RunSQL (SQL)ElseMsgBox ("当前数据库无法连接，请尝试连接测试后重试！")End IfEnd SubPrivate Sub Command8_Click()Call ShellExecute(Me.hWnd, "open", "http://222.72.136.234:8085/knowledgeQA/forum.php", "", "", SW_SHOW)End Sub'通讯报错：分公司批发销售需先同步商品资料Private Sub Command9_Click()If connT = True ThenSQL = "Truncate table tDRPInfSkuPlu;Truncate table Goods;Update tWebComCtrl set InCreValue=0 where ItemCode='31001';Exec pRcvPlu 01,31001,out;insert into Goods Select * from Goods_bak where Not exists (select 1 from Goods where PluCode= Goods_bak.PluCode);"RunSQL (SQL)ElseMsgBox ("当前数据库无法连接，请尝试连接测试后重试！")End IfEnd Sub'窗口初始化Private Sub Form_Load()connT = Falseipadd = Text2.Textdbase = Text3.Textdbpwd = Text4.Text'Call Command2_ClickEnd SubPublic Sub Text1_Click()If Text1.Text = "输入单号 LIFEMG......" ThenText1.Text = ""End IfEnd SubPrivate Sub Text5_Click()If Text5.Text = "输入SQL语句" ThenText5.Text = ""End IfEnd SubPrivate Sub Text6_Click()If Text6.Text = "输入单号 XHC......" ThenText6.Text = ""End IfEnd Sub'数据库连接测试 --ERRFunction ConnectToDataBase() As BooleanTimer1.Enabled = TrueOn Error GoTo Error1Set myConn = New ADODB.ConnectionmyConn.ConnectionString = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;password=" & dbpwd & ";Initial Catalog=" & dbase & ";Data Source=" & ipaddmyConn.OpenMsgBox "连接成功！", , "提示"connT = TruemyConn.CloseExit FunctionError1:connT = FalseMsgBox "连接错误！请重新输入数据库信息" & vbCrLf & Err.Description, , "警告"End Function'数据库连接执行语句Function RunSQL(SQL)Dim cn As New ADODB.ConnectionDim rs As New ADODB.Recordsetcn.ConnectionString = "Provider=SQLOLEDB;Password='" & dbpwd & "';Persist Security Info=False;User ID='sa';Initial Catalog='" & dbase & "';Data Source='" & ipadd & "'"cn.OpenIf rs.State = adStateOpen Then rs.Closers.CursorLocation = adUseClientrs.Open Trim$(SQL), cn, adOpenKeyset, adLockPessimisticcn.CloseMsgBox ("执行完毕！")End Function```
