frmtool.frm

本软件是人事管理系统

Dim lngHistory As Long '历史记录，记录先前使用的数据连接项目
Dim strTempLink As String  '临时连接字符串

Private Sub CboDatabase_Click() '自动查找选定项目的内容
    intNumber = intSave(CboDatabase.ListIndex) '记录当前的项是哪个号码
    If CInt(GetSetting(App.Title, "Settings", "History", 0)) = intNumber Then '如果选定项目就是启动默认项，则显示chkopen为打勾
        chkOpen.Value = 1
    Else
        chkOpen.Value = 0
    End If
    txtName.Text = GetSetting(App.Title, "Setting-" & intNumber, "UserName", "") '显示内容
    txtPassword.Text = GetSetting(App.Title, "Setting-" & intNumber, "UserPassword", "")
    txtServerName.Text = GetSetting(App.Title, "Setting-" & intNumber, "ServerName", "")
    CboDatabase.Text = GetSetting(App.Title, "Setting-" & intNumber, "Database", "")
     If IsNumeric(GetSetting(App.Title, "Setting-" & intNumber, "Sort", "0")) = True Then
        cboSort.ListIndex = CInt(GetSetting(App.Title, "Setting-" & intNumber, "Sort", "0"))
    Else
        cboSort.ListIndex = 0
    End If
    If Trim(txtServerName.Text) = "" And cboSort.ListIndex = 0 Then '如果服务器名为空，则表示启动项不可用
        chkOpen.Enabled = False
    Else
        chkOpen.Enabled = True
    End If
End Sub

Private Sub cboSort_Click()
    If cboSort.ListIndex = 0 Then
        lblDatabase.Caption = "数据库"
        lblServerName.Visible = True
        txtServerName.Visible = True
    Else
        lblDatabase.Caption = "文件路径"
        lblServerName.Visible = False
        txtServerName.Visible = False
        txtServerName.Text = ""
    End If
End Sub

Private Sub chkOpen_Click() '写入启动时的连接项目名
    If chkOpen.Value = 1 Then '当打勾时
        SaveSetting App.Title, "Settings", "History", intNumber '保存内容
    End If
End Sub

Private Sub cmdDel_Click() '删除
On Error GoTo errDel
        Call subCboCount '刷新
        If CInt(GetSetting(App.Title, "Settings", "History", 0)) = intNumber Then '如果删除项目是默认启动项，则取消其默认值
            DeleteSetting App.Title, "settings"
            chkOpen.Value = 0
        End If
        DeleteSetting App.Title, "Setting-" & intNumber '删除选定项目的所有内容
        Call subCboCount '刷新
errDel:
    Err.Clear
    If CboDatabase.ListCount > 0 Then
        CboDatabase.ListIndex = 0
    Else
        txtName.Text = "" '清空各项内容
        txtPassword.Text = ""
        txtServerName.Text = ""
    End If
End Sub

Private Sub cmdExit_Click() '退出
    On Error Resume Next
    If gblnLoadError = False Then
        Unload Me
        frmInfo.Enabled = True
    Else
        Call Shutdown
    End If
End Sub


Private Sub cmdNew_Click() '新建
On Error GoTo errNew
    Call subCboCount '刷新列表
    If CboDatabase.ListCount = 10 Then '当列表拥有10个连接项目,仍继续进行创建新的连接时,显示错误信息
        MsgBox "列表项目最多只能存储10个数据库连接项  " & vbCrLf & vbCrLf & vbTab & "请删除无效的连接!", vbCritical, "错误"    '查找后发现未有空余项，则发出警告信息
        CboDatabase.Text = GetSetting(App.Title, "Setting-" & intNumber, "Database", "") '返回原有的列表名称
        Exit Sub
    End If
        Call subIntNumber(True) '如果intNumber为0则释放锁定的框
    txtName.Text = "" '清空各项内容
    txtPassword.Text = ""
    txtServerName.Text = ""
    CboDatabase.AddItem "", CboDatabase.ListCount '添加cbodatabse的列
    For lngArithmometer = 1 To 10 '遍历查找有否空的注册表项目名，有则在此注册表项目中写入内容，无则发出警告
        If Trim(GetSetting(App.Title, "Setting-" & lngArithmometer, "Database", "")) = "" Then '当发现有空位时,则预留此空位
            intSave(CboDatabase.ListCount - 1) = lngArithmometer  '写入预留名
            CboDatabase.ListIndex = CboDatabase.ListCount - 1 '读取cbodatabase的列
            txtName.SetFocus
            Exit Sub '写入内容后退出
        End If
    Next
    Exit Sub
errNew:
    Err.Clear
End Sub

Private Sub cmdSave_Click() '保存
    If intNumber > 0 Then '如果有列则进行保存工作，否则退出
        Call subLinkString '检查输入内容是否正确
        If blnErr = True Then  '有错误则退出
            Exit Sub
        End If
        SaveSetting App.Title, "Setting-" & intNumber, "UserName", Trim(txtName.Text) '保存所有内容
        SaveSetting App.Title, "Setting-" & intNumber, "UserPassword", Trim(txtPassword.Text)
        SaveSetting App.Title, "Setting-" & intNumber, "ServerName", txtServerName.Text
        SaveSetting App.Title, "Setting-" & intNumber, "Database", CboDatabase.Text
        SaveSetting App.Title, "Setting-" & intNumber, "Sort", cboSort.ListIndex
        Call subCboCount '刷新
        CboDatabase.Text = GetSetting(App.Title, "Setting-" & intNumber, "Database", "") '读取保存项目在列表中的内容
        chkOpen.Enabled = True '启动项选择功能开启
    End If
End Sub

Private Sub cmdTest_Click() '测试连接
    Dim conn As New ADODB.Connection
    lblText.Caption = ""
    cmdTest.Enabled = False
    strTempLink = gstrLink
    gstrLink = ""
    Call subLinkString '刷新
    If Len(gstrLink) = 0 Then lblText.Caption = "连接失败!": cmdTest.Enabled = True: Exit Sub
    On Error GoTo ErrLink
    With conn
        .CursorLocation = adUseClient
        gstrCN = gstrLink
        .Open gstrCN
        If blnErr = True Then '有错退出
            Exit Sub
        End If
        If .State = adStateOpen Then
            lblText.Caption = "测试连接成功!"
        Else
           lblText.Caption = "测试连接失败!"
        End If
    End With
    cmdTest.Enabled = True
    gstrLink = strTempLink
    Set conn = Nothing
    Exit Sub
ErrLink: '发生错误，则连接失败
    lblText.Caption = "测试连接失败!"
    gstrLink = strTempLink
    cmdTest.Enabled = True
    MsgBox "错误：" & Err.Number & vbCrLf & Err.Description, vbCritical + vbOKOnly, App.Title
End Sub

Private Sub cmdReStats_Click()
    blnLogout = False
    Call Shutdown
    Call Main
End Sub

Private Sub Form_Load()
    On Error Resume Next
    If gblnLoadError = True Then DisSysMenu Me.hWnd, 6 '右上角关闭按钮无效
    Me.Caption = "网络属性"
    'Set frmTool.Icon = LoadPicture(App.Path & "\pic\" & "hengmei.ico")
    intNumber = 0
    Call subIntNumber(False)
    Call subCboCount
    cmdExit.Caption = IIf(gblnLoadError = False, "取消(&C)", "退出(&Q)")
    If CboDatabase.ListCount > 0 Then '如果有项目存在，则进行读取工作
        intNumber = CInt(GetSetting(App.Title, "Settings", "History", 0))
        txtName.Text = GetSetting(App.Title, "Setting-" & intNumber, "UserName", "") '读表内容
        txtPassword.Text = GetSetting(App.Title, "Setting-" & intNumber, "UserPassword", "")
        txtServerName.Text = GetSetting(App.Title, "Setting-" & intNumber, "ServerName", "")
        If IsNumeric(GetSetting(App.Title, "Setting-" & intNumber, "Sort", "0")) = True Then
            cboSort.ListIndex = CInt(GetSetting(App.Title, "Setting-" & intNumber, "Sort", "0"))
        Else
            cboSort.ListIndex = 0
        End If
        Call subIntNumber(True) '有列表内容时，输入框有效
        If intNumber > 0 Then '有默认项时
            chkOpen.Value = 1 '默认项打勾
            For lngArithmometer = 0 To lngCboListCount - 1 '查找所有被记录的有效项目名称
                If intSave(lngArithmometer) = intNumber Then '找到默认项的名称时
                    CboDatabase.ListIndex = lngArithmometer '显示历史记录中记录的列的内容
                    Call subLinkString ''检查输入内容是否正确并建立字符连接串gstrLink
                    Exit Sub
                End If
            Next
        Else
            chkOpen.Value = 0
            CboDatabase.ListIndex = 0  '否则只显示第一个项目的内容
            Call subLinkString ''检查输入内容是否正确并建立字符连接串gstrLink
        End If
    Else '无项存在时
        cboSort.ListIndex = 0
    End If
End Sub
Public Sub subLinkString() '判断字符连接串是否有错，无错误则定义gstrLink内容
    blnErr = True '初始定义为有错误发生
    If cboSort.ListIndex = 0 Then
        If Len(Trim(txtServerName.Text)) = 0 Then '为空时报错
            MsgBox "服务器名不能为空,请输入名称!", vbCritical, "错误"
            Exit Sub
        ElseIf Len(Trim(CboDatabase.Text)) = 0 Then '为空时报错
            MsgBox "数据库名不能为空,请输入名称!", vbCritical, "错误"
            Exit Sub
        End If
        If Len(Trim(txtName.Text)) = 0 Then '为空时，连接为无用户类型
            gstrLink = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;" _
            & "Initial Catalog=" & Trim(CboDatabase.Text) & ";" & "Data Source=" & Trim(txtServerName.Text)
        Else '否则连接为登录用户类型
            gstrLink = "Provider=SQLOLEDB.1;Password=" & Trim(txtPassword.Text) & ";" & "Persist Security Info=True;" _
            & "User ID=" & Trim(txtName.Text) & ";" & "Initial Catalog=" & Trim(CboDatabase.Text) & ";" & "Data Source=" & Trim(txtServerName.Text)
        End If
    Else
        If Len(Trim(CboDatabase.Text)) = 0 Then '为空时报错
            MsgBox "文件路径不能为空,请输入路径!", vbCritical, "错误"
            Exit Sub
        End If
        If Len(Trim(txtName.Text)) = 0 Then '为空时，连接为无用户类型
            txtPassword.Text = ""
            gstrLink = "Provider=" & Mid(cboSort.Text, 9) & ";Persist Security Info=True;" _
            & "Data Source=" & Trim(CboDatabase.Text)
        Else '否则连接为登录用户类型
            gstrLink = "Provider=" & Mid(cboSort.Text, 9) & ";Password=" & Trim(txtPassword.Text) & ";" & "Persist Security Info=True;" _
            & "User ID=" & Trim(txtName.Text) & ";" & "Data Source=" & Trim(CboDatabase.Text)
        End If
    End If
    '"
    blnErr = False '结束时为无错误
End Sub
Public Sub subCboCount() '写入所有记录到列表框中
    lngCboListCount = 0 '初始为0列
    CboDatabase.Clear '清空列表
    For lngArithmometer = 1 To 10 '写入列表项
        If Trim(GetSetting(App.Title, "Setting-" & lngArithmometer, "Database", "")) <> "" Then '当项目不为空，写入项目名称
            CboDatabase.AddItem (GetSetting(App.Title, "Setting-" & lngArithmometer, "Database", "")), lngCboListCount '将项目名称写入列表
            intSave(lngCboListCount) = lngArithmometer '记录项目在注册表中对应的号码
            lngCboListCount = lngCboListCount + 1 '当前下拉列表框的列数
        End If
    Next
    If CboDatabase.ListCount = 0 Then '没有列时，则则各输入框不可用
        Call subIntNumber(False)
    End If
End Sub

Public Sub subIntNumber(GetIntNumber As Boolean) '如果无记录，则各输入框不可用
    txtName.Enabled = GetIntNumber
    txtPassword.Enabled = GetIntNumber
    txtServerName.Enabled = GetIntNumber
    CboDatabase.Enabled = GetIntNumber
    cmdSave.Enabled = GetIntNumber
    CmdDel.Enabled = GetIntNumber
    chkOpen.Enabled = GetIntNumber
End Sub


Private Sub Form_Unload(Cancel As Integer)
    frmInfo.Enabled = True
End Sub