📄 form1.frm
字号:
VERSION 5.00
Object = "{CFA7AFF4-3242-4269-9172-7389D695AE01}#1.0#0"; "StoneXP.ocx"
Begin VB.Form Form1
BackColor = &H00C0C0FF&
BorderStyle = 1 'Fixed Single
Caption = "SQL数据库连接"
ClientHeight = 3045
ClientLeft = 45
ClientTop = 435
ClientWidth = 5160
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3045
ScaleWidth = 5160
StartUpPosition = 1 '所有者中心
Begin StoneXP.XPButton XPButton1
Default = -1 'True
Height = 375
Left = 1800
TabIndex = 9
Top = 2520
Width = 1455
_ExtentX = 2566
_ExtentY = 661
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ButtonStyle = 1
Caption = "连接并登陆"
MouseIcon = "Form1.frx":0000
MousePointer = 99
End
Begin StoneXP.XPFrame XPFrame2
Height = 1455
Left = 240
TabIndex = 0
Top = 840
Visible = 0 'False
Width = 4575
_ExtentX = 8070
_ExtentY = 2566
Caption = "远程服务器配置"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BackColor = 12632319
LeftSpace = 0
RightSpace = 0
RoundSize = 0
Begin VB.TextBox Text1
Appearance = 0 'Flat
BorderStyle = 0 'None
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 210
IMEMode = 3 'DISABLE
Index = 2
Left = 1200
PasswordChar = "*"
TabIndex = 3
Top = 900
Width = 1335
End
Begin VB.TextBox Text1
Appearance = 0 'Flat
BorderStyle = 0 'None
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 210
Index = 1
Left = 3240
TabIndex = 2
Top = 360
Width = 1215
End
Begin VB.TextBox Text1
Appearance = 0 'Flat
BorderStyle = 0 'None
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 210
Index = 0
Left = 1200
TabIndex = 1
Top = 360
Width = 1335
End
Begin VB.Label Label4
BackStyle = 0 'Transparent
Caption = "密码:"
Height = 255
Left = 600
TabIndex = 6
Top = 885
Width = 495
End
Begin VB.Label Label3
BackStyle = 0 'Transparent
Caption = "帐号:"
Height = 255
Left = 2640
TabIndex = 5
Top = 360
Width = 495
End
Begin VB.Label Label2
BackStyle = 0 'Transparent
Caption = "服务器名称:"
Height = 255
Left = 120
TabIndex = 4
Top = 360
Width = 1095
End
End
Begin StoneXP.XPRadioButton XPRadioButton3
Height = 375
Left = 720
TabIndex = 7
Top = 240
Width = 1215
_ExtentX = 2143
_ExtentY = 661
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Caption = "远程服务器"
BackColor = 12632319
End
Begin StoneXP.XPRadioButton XPRadioButton4
Height = 375
Left = 3240
TabIndex = 8
Top = 240
Width = 1215
_ExtentX = 2143
_ExtentY = 661
Value = -1 'True
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Caption = "本地服务器"
BackColor = 12632319
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim intFile As Integer
Dim strInput As String
Dim strst() As String
Dim strtargetfile As String
Dim filesize As Double
Dim LoginMX As Double
Private Sub ipserver()
On Error GoTo tkFinish
server = Text1(0).Text
loginname = Text1(1).Text
password = Text1(2).Text
tkOpenSQLServerDB server, "master", loginname, password
Dim sql As String
sql = "select * from sysdatabases Where Name = '" & DataName & "'"
Set rs = cnn.Execute(sql)
If Not rs.EOF Then '---------
cnn.Close
Else
sql = "select * from sysdatabases where name='master'"
Set rs = cnn.Execute(sql)
MsgBox "第一次登陆，正在新建数据库！", vbInformation, "新建数据库"
sql = "create database yxsell"
MsgBox "正在新建数据库内容！", vbInformation, "表创建过程中"
Set rs = cnn.Execute(sql)
cnn.Close
End If '--------------------
tkOpenSQLServerDB server, DataName, loginname, password
ADDBase
strtargetfile = App.Path & "\Login.XHL"
If Dir(strtargetfile, vbNormal) <> "" Then
Kill strtargetfile
End If
Open strtargetfile For Append As #1
Print #1, server & "|" & loginname & "|" & password & "|"
Close #1
seladmin
Exit Sub
tkFinish:
MsgBox Err.Description
strtargetfile = App.Path & "\Login.XHL"
If Dir(strtargetfile, vbNormal) <> "" Then
Kill strtargetfile
End If
End Sub
Private Sub Form_Load()
On Error GoTo Finish:
DataName = "yxsell" '数据库名称,通用
strtargetfile = App.Path & "\Login.XHL"
If Dir(strtargetfile, vbNormal) <> "" Then
intFile = FreeFile
filesize = FileLen(strtargetfile)
Open strtargetfile For Binary As #intFile
strInput = Space(filesize)
Get #intFile, , strInput
strst = Split(strInput, "|")
Close #intFile
If UBound(strst) = 1 Then '判断无帐号时为本地登陆
cnn.Open "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=" & DataName & ";Data Source=."
ADDBase
seladmin
Else
tkOpenSQLServerDB strst(0), DataName, strst(1), strst(2)
If LoginMX = True Then '确定上条语句的成功
ADDBase
seladmin
End If
End If
End If
Exit Sub
Finish:
strtargetfile = App.Path & "\Login.XHL"
If Dir(strtargetfile, vbNormal) <> "" Then
Kill strtargetfile
End If
End Sub
Private Sub XPButton1_Click()
If XPRadioButton3.Value = True Then
If Text1(0).Text = "" Or Text1(1).Text = "" Then
MsgBox "远程服务器名称与帐号不可为空!", vbInformation, "错误"
Exit Sub
Else
ipserver
End If
ElseIf XPRadioButton4.Value = True Then
bdserver
End If
End Sub
Private Sub XPRadioButton3_Click()
If XPRadioButton3.Value = True Then
XPFrame2.Visible = True
Else
XPFrame2.Visible = False
End If
End Sub
Private Sub XPRadioButton4_Click()
If XPRadioButton4.Value = True Then
XPFrame2.Visible = False
Else
XPFrame2.Visible = True
End If
End Sub
Private Sub ADDBase()
strtargetfile = App.Path & "\SQL.txt"
intFile = FreeFile
filesize = FileLen(strtargetfile)
Open strtargetfile For Binary As #intFile
strInput = Space(filesize)
Get #intFile, , strInput
strst = Split(strInput, "|")
Close #intFile
For i = 0 To UBound(strst) - 1 Step 2
sql = "select name from sysobjects where name='" & strst(i) & "'"
Set rs = cnn.Execute(sql)
If rs.EOF = True Then
Set rs = cnn.Execute(strst(i + 1))
End If
Next
End Sub
Private Sub tkOpenSQLServerDB( _
tkServerName As String, _
tkDefaultDatabase As String, _
tkUserID As String, _
tkPassword As String _
)
On Error GoTo tkFinish
On Error GoTo tkFinish
cnn.Open "Provider=SQLOLEDB.1;" & _
"Data Source=" & tkServerName & ";" & _
"Use Procedure for Prepare=1;" & _
"Auto Translate=True;" & _
"Packet Size=4096;" & _
"Use Encryption for Data=False;" & _
"Tag with column collation when possible=False", _
tkUserID, _
tkPassword
cnn.DefaultDatabase = tkDefaultDatabase
LoginMX = True
Exit Sub
tkFinish:
LoginMX = False
cnn.Close
End Sub
Private Sub bdserver()
On Error GoTo tkFinish
cnn.Open "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=master;Data Source=."
Dim sql As String
sql = "select * from sysdatabases Where Name = '" & DataName & "'"
Set rs = cnn.Execute(sql)
If Not rs.EOF Then
cnn.Close
Else
sql = "select * from sysdatabases where name='master'"
Set rs = cnn.Execute(sql)
MsgBox "第一次登陆，正在新建数据库！", vbInformation, "新建数据库"
sql = "create database yxsell"
MsgBox "执行系统备份的还原！", vbInformation, "还原数据库"
Set rs = cnn.Execute(sql)
cnn.Close
End If
cnn.Open "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=" & DataName & ";Data Source=."
ADDBase
strtargetfile = App.Path & "\Login.XHL"
If Dir(strtargetfile, vbNormal) <> "" Then
Kill strtargetfile
End If
Open strtargetfile For Append As #1
Print #1, "." & "|"
Close #1
seladmin
Exit Sub
tkFinish:
MsgBox Err.Description
strtargetfile = App.Path & "\Login.XHL"
If Dir(strtargetfile, vbNormal) <> "" Then
Kill strtargetfile
End If
End Sub
Public Sub seladmin() '数据库处理完成后导向
'在此加入新处理的内容，如打开一个新的窗体，并结束当前窗体等等
MsgBox "登陆完成"
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -