frmtool.frm

人事管理系统vb版,用于一般中小企业

      Left            =   4560
      TabIndex        =   7
      Top             =   3615
      Width           =   1095
      _extentx        =   1931
      _extenty        =   609
      font            =   "frmTool.frx":0B6E
      caption         =   "登录(&U)"
      forecolor       =   -2147483630
   End
   Begin Manage.uclMainPic uclMainPic1 
      Height          =   3510
      Left            =   0
      TabIndex        =   9
      Top             =   0
      Width           =   6975
      _extentx        =   12303
      _extenty        =   6191
   End
End
Attribute VB_Name = "frmTool"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' 数据库连接方式编辑器 V0.89 测试版
'
Option Explicit
Dim strTemp As String  '临时字符串
Dim intNumber As Integer
Private WithEvents EncryptGost As clsGost '加密算法
Attribute EncryptGost.VB_VarHelpID = -1
Private EncryptObject As Object
Dim strPath As String
Dim blnFileNull As Boolean 'T：文件内容为空，或文件不存在,F:文件有内容
Dim blnStart As Boolean 'T: 启动 F:不是启动

Private Sub chkPass_Click()
    txtConceal.Enabled = IIf(chkPass.Value = Checked, True, False)
    txtConceal.BackColor = IIf(chkPass.Value = Checked, &HFFFFFF, &H8000000F)
    lblPassword.Enabled = txtConceal.Enabled
End Sub

Private Sub cmdFile_Click()
    On Error Resume Next
    cdgFile.DialogTitle = "加载Access数据库"
    cdgFile.Filter = "Microsoft Access (*.mdb)|*.mdb|"
    cdgFile.Filename = ""
    cdgFile.ShowOpen
    strTemp = cdgFile.Filename
    If Len(strTemp) = 0 Then Exit Sub
    txtDatabase.Text = strTemp
End Sub

Private Sub Form_Load()
    On Error GoTo errNext
    blnStart = True
    If gblnLoadError = True Then DisSysMenu Me.hwnd, 6 '右上角关闭按钮无效
'    PrevWndFunc = SetWindowLong(txtConceal.hwnd, GWL_WNDPROC, AddressOf MessageFunc)
'    PrevWndFunc = SetWindowLong(txtPassword.hwnd, GWL_WNDPROC, AddressOf MessageFunc)
    cboProvider.ListIndex = 0
    gstrNowLink = ""
    If gblnLoadError = False Then
        CmdExit.Caption = "关闭(&C)"
    Else
        CmdExit.Caption = "退出(&Q)"
    End If
    Set EncryptGost = New clsGost
    Set EncryptObjects.Object = EncryptGost
    EncryptObjects.Name = "Gost"
    Set EncryptObject = EncryptObjects.Object
    strPath = App.Path & "\corp.dat"
    blnFileNull = True
    If Len(Dir(strPath)) <> 0 Then '文件是否存在
        If FileLen(strPath) > 13 And FileLen(strPath) < 50000 Then '文件内容是否为空,13为此密码的长度
            blnFileNull = False
            Call EncryptObject.DecryptFile(strPath, strPath, "$ fk#ci(%2^d9") '解密
            Open strPath For Binary As #1
            gstrNowLink = Trim(Input$(LOF(1), #1))
            Close #1
            Call EncryptObject.EncryptFile(strPath, strPath, "$ fk#ci(%2^d9")  '加密
            cboProvider.Text = Mid(gstrNowLink, 10, 23)
            intNumber = InStr(1, gstrNowLink, ";User ID=", vbTextCompare) + 9
            If intNumber > 9 Then txtName.Text = Mid(gstrNowLink, intNumber, InStr(intNumber, gstrNowLink, ";Jet OLEDB", vbTextCompare) - intNumber)
            intNumber = InStr(1, gstrNowLink, ";Jet OLEDB:Database Password=", vbTextCompare) + 29
            If intNumber > 29 Then txtPassword.Text = Mid(gstrNowLink, intNumber, InStr(intNumber, gstrNowLink, ";Data Source", vbTextCompare) - intNumber)
            intNumber = InStr(1, gstrNowLink, ";Data Source=", vbTextCompare) + 13
            If intNumber > 13 Then txtDatabase.Text = Mid(gstrNowLink, intNumber, InStr(intNumber, gstrNowLink, ";Persist Security", vbTextCompare) - intNumber)
            
            If Len(txtPassword.Text) = 0 Then
                txtConceal.Enabled = False
                txtConceal.BackColor = &H8000000F
                lblPassword.Enabled = False
                chkPass.Value = Checked
            Else
                txtConceal.Text = Mid(" abcdefghijklmnopqrstuvwxyz", 1, Len(txtPassword.Text) * 2)
            End If
            'End If
        Else
            Kill strPath
            Open strPath For Output As #1 '建文件
            Close #1
        End If
    Else
        Open strPath For Output As #1 '建文件
        Close #1
    End If
    blnStart = False
    Exit Sub
errNext:
    blnStart = False
    Call ErrMsg(Err.Number, Err.Description)
End Sub

Private Sub cmdDel_Click() '删除
    On Error GoTo errNext
    If Len(Dir(strPath)) <> 0 Then
        If MsgBox("确实要删除此设置吗", vbInformation + vbYesNo) = vbYes Then
            Kill strPath
            Open strPath For Output As #1
            Close #1
            gstrNowLink = ""
            txtName.Text = "" '清空各项内容
            txtConceal.Text = ""
            txtDatabase.Text = ""
            MsgBox "设置被成功删除!", vbInformation
        End If
    End If
    Exit Sub
errNext:
    Call ErrMsg(Err.Number, Err.Description)
End Sub

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

Private Sub cmdSave_Click() '保存
    On Error GoTo errNext
    If Len(Trim(txtDatabase.Text)) = 0 Then MsgBox "数据库路径不能为空,请输入路径后再进行保存.", vbExclamation: txtDatabase.SetFocus: Exit Sub
    If chkPass.Value = Checked Or Len(Trim(txtPassword.Text)) = 0 Then '无密码
        strTemp = "Provider=" & cboProvider.Text & ";Data Source=" & Trim(txtDatabase.Text) & ";Persist Security Info＝True"
    Else '有密码
        strTemp = "Provider=" & cboProvider.Text & ";User ID=" & Trim(txtName.Text) & ";Jet OLEDB:Database Password=" & Trim(txtPassword.Text) & ";Data Source=" & Trim(txtDatabase.Text) & ";Persist Security Info＝True"
    End If
    If (FileLen(strPath) > 13 And FileLen(strPath) < 50000) And Len(Dir(strPath)) <> 0 Then '文件内容为空,或文件不存在
        If blnFileNull = False Then Call EncryptObject.DecryptFile(strPath, strPath, "$ fk#ci(%2^d9") '解密
    ElseIf (FileLen(strPath) <= 13 Or FileLen(strPath) >= 50000) And Len(Dir(strPath)) <> 0 Then
        Kill strPath
    End If
    Open strPath For Output As #1
    Print #1, strTemp
    Close #1
    Call EncryptObject.EncryptFile(strPath, strPath, "$ fk#ci(%2^d9")  '加密
    MsgBox "保存成功!", vbInformation
    Exit Sub
errNext:
    Open strPath For Output As #1 '加密出错就写空文件
    Print #1, ""
    Close #1
        Kill strPath
    Open strPath For Output As #1
    Close #1
    Call ErrMsg(Err.Number, Err.Description)
End Sub

Private Sub cmdTest_Click() '测试连接
    Dim conn As New ADODB.Connection
    lblText.Caption = ""
    If Len(Trim(txtDatabase.Text)) = 0 Then MsgBox "数据库路径不能为空,请输入路径后再测试连接.", vbExclamation: txtDatabase.SetFocus: Exit Sub
    cmdTest.Enabled = False
    If chkPass.Value = Checked Or Len(Trim(txtPassword.Text)) = 0 Then  '无密码
        strTemp = "Provider=" & cboProvider.Text & ";Data Source=" & Trim(txtDatabase.Text) & ";Persist Security Info＝True"
    Else '有密码
        strTemp = "Provider=" & cboProvider.Text & ";User ID=" & Trim(txtName.Text) & ";Jet OLEDB:Database Password=" & Trim(txtPassword.Text) & ";Data Source=" & Trim(txtDatabase.Text) & ";Persist Security Info＝True"
    End If
    On Error GoTo ErrLink
    With conn
        .CursorLocation = adUseClient
        .CommandTimeout = 10
        .Open strTemp
        lblText.ForeColor = &HFF0000
        lblText.Caption = "测试连接成功,此设置可用!"
    End With
    Set conn = Nothing
    cmdTest.Enabled = True
    Exit Sub
ErrLink: '发生错误，则连接失败
    lblText.ForeColor = &HFF&
    lblText.Caption = "测试连接失败,请重新设置!"
    Set conn = Nothing
    cmdTest.Enabled = True
    Call ErrMsg(Err.Number, Err.Description)
End Sub

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

Private Sub Form_Unload(Cancel As Integer)
    Set EncryptGost = Nothing
    Set EncryptObject = Nothing
End Sub

Private Sub txtConceal_Change()
    If blnStart = True Then Exit Sub
    Dim D As String, e As String, C As Integer
    D = " abcdefghijklmnopqrstuvwxyz"
    txtPassword.SetFocus
    C = Len((txtPassword.Text))
    e = Mid(D, C + 1, 1) & (C + 1)
    txtConceal.Text = Mid(txtConceal.Text & e, 1, C * 2)
    txtConceal.SetFocus
    SendKeys "{end}"
End Sub
Private Sub txtConceal_KeyPress(KeyAscii As Integer)
If KeyAscii = 8 Then
    txtConceal.SetFocus
    SendKeys "{end}"
    If Len(txtPassword.Text) = 0 Then Exit Sub
    txtPassword.Text = Mid(txtPassword.Text, 1, Len(txtPassword.Text) - 1)
Else
    txtPassword.Text = txtPassword.Text & Chr(KeyAscii)
End If
End Sub

Private Sub txtPassword_GotFocus()
    txtConceal.SetFocus
    SendKeys "{end}"
End Sub