VB开发的ERP系统

    
    DdtsLabel = ""
    DdtsLabel.Refresh
      
    Ljyxxpd = True
    
    Exit Function
    
Cwcl:
    Animation1.Visible = False
    Animation1.Stop
    DdtsLabel = ""
    Tsxx = "数据服务器连接测试失败!"
    Call Xtxxts(Tsxx, 0, 1)
    Exit Function
  
End Function
Private Sub CzrqText_KeyPress(KeyAscii As Integer)      '录入日期限制
    Call Lrrqxz(KeyAscii)
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)          '控 制 焦 点 转 移
    Dim jdzygs As Integer
    jdzygs = 12
    Select Case KeyAscii
        Case vbKeyReturn
            If Kjjdzy(jdzygs) Then
                KeyAscii = 0
            End If
        Case 39           '屏蔽"'"
            KeyAscii = 0
    End Select
End Sub
Private Sub Form_Load()
    App.HelpFile = App.Path + "\应收系统.chm"
    Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
    
    XtMenuList = "02%"         '子系统菜单系统代号
    
    ErpPassWord = "123"
    
    Call Qcljnr     '读入连接内容
    
    With StTab
        .TabEnabled(0) = False
        Frame1(0).Enabled = False
        .TabEnabled(1) = True
        Frame1(1).Enabled = True
        .TabEnabled(2) = False
        Frame1(2).Enabled = False
         StTab.Tab = 1
    End With
    
End Sub
Private Sub GgszCommand_Click()
    With Me.StTab
        .TabEnabled(0) = False
        Frame1(0).Enabled = False
        .TabEnabled(1) = True
        Frame1(1).Enabled = True
        .Tab = 1
    End With
    
    ' 让数据服务器设置文本框得到焦点
    ServerText.SetFocus
    ServerText.SelStart = 0
    ServerText.SelLength = Len(ServerText.Text)
End Sub
Private Sub LjqdCommand_Click()                              '保 存 设 置
 
    If Ljyxxpd Then
        If Cw_DataEnvi.BaseInfoConnect.State = 1 Then Cw_DataEnvi.BaseInfoConnect.Close
        Cw_DataEnvi.BaseInfoConnect.Open Xtsjljc, "Hxxd", ErpPassWord
        
        Tsxx = "连接测试成功!"
        Call Xtxxts(Tsxx, 0, 4)
        
        StTab.TabEnabled(1) = False
        Frame1(1).Enabled = False
        StTab.TabEnabled(0) = True
        Frame1(0).Enabled = True
        StTab.Tab = 0
        Call Tcztxx
        
        If ZtCombo.ListCount > 0 Then
            ZtCombo.ListIndex = 0
        End If
    End If
End Sub
Private Sub Qcljnr()                                         '取 出 数 据
    On Error Resume Next
    Dim int_Count As Integer
    
    ServerText.Text = ReadOneString("Option", "SqlServer", "localhost")
    str_Account = ReadOneString("Option", "Account", "")
    
    For int_Count = 0 To ZtCombo.ListCount - 1
        If UCase(Mid(ZtCombo.List(int_Count), 1, InStr(ZtCombo.List(int_Count), "-") - 1)) = UCase(Mid(str_Account, 1, InStr(str_Account, "-") - 1)) Then
            ZtCombo.ListIndex = int_Count
        End If
    Next int_Count
End Sub
Private Sub QdCommand_Click()          '确定进入系统
    If Trim(CzyCombo.Text) = "" Then Exit Sub
    
    Set Czyrec = Cw_DataEnvi.DataConnect.Execute("Select * From gy_czygl where czybm='" + Trim(CzyCombo.Text) + "' or czymc='" & Trim(CzyCombo.Text) & "' or rtrim(czybm)+'-'+rtrim(czymc)='" & Trim(CzyCombo.Text) & "'")
    With Czyrec
        If Not .EOF Then
        CzyCombo.Text = Trim(.Fields("czybm")) + "-" + Trim(.Fields("czymc"))
        Else
            Tsxx = "无此用户名!"
            Call Xtxxts(Tsxx, 0, 1)
            Exit Sub
        End If
    End With
    Czyrec.Close
    Set Czyrec = Nothing


    If Xtyxxpd Then
        If Ljyxxpd1 Then
            If Cw_DataEnvi.DataConnect.State = 1 Then Cw_DataEnvi.DataConnect.Close
            Cw_DataEnvi.DataConnect.Open Xtsjljc, "Hxxd", ErpPassWord
        End If
        QdCheck.Value = 1
        Me.Hide
        
        Call WriteOneString("Option", "SqlServer", Trim(ServerText.Text))
        Call WriteOneString("Option", "Account", Trim(ZtCombo.Text))
        
        CtdrCheck.Value = 1
        GgszCommand.Enabled = False
        XT_Main.Show
        
        Xt_Control.tvTreeView.Visible = False
        Xt_Control.tvTreeView.Nodes.Clear
        Xt_Control.Cshgns
        Xt_Control.tvTreeView.Refresh
        Xt_Control.tvTreeView.Visible = True
    End If
End Sub
Private Sub QxCommand_Click()                                     '取消进入系统
    If CtdrCheck.Value <> 1 Then
        Unload Me
    Else
        Me.Hide
    End If
End Sub
Private Sub Rlcommand_Click()                                     '操作日期帮助
    Call Czrqbz
End Sub
Private Sub Timer1_Timer()                                        '激活连接测试
    Timer1.Enabled = False
    
    If Ljyxxpd Then
        If Cw_DataEnvi.BaseInfoConnect.State = 1 Then Cw_DataEnvi.BaseInfoConnect.Close
        Cw_DataEnvi.BaseInfoConnect.Open Xtsjljc, "Hxxd", ErpPassWord
    Else
        Exit Sub
    End If
    
    With StTab
        .TabEnabled(1) = False
        Frame1(1).Enabled = False
        .TabEnabled(0) = True
        Frame1(0).Enabled = True
    End With
    
    StTab.Tab = 0
      
    Call Tcztxx
    Qcljnr
    
    '让用户名录入框得到焦点
    CzyCombo.SetFocus

End Sub
Private Sub LjqxCommand_Click()                                   '连接失败退出
    If CtdrCheck.Value <> 1 Then
        Unload Me
    Else
        Me.Hide
    End If
End Sub
Private Sub Tcztxx()                                              '填充帐套信息选择
    Dim Xtztxxrec As New ADODB.Recordset        '系统帐套信息动态集
    Set Xtztxxrec = Cw_DataEnvi.BaseInfoConnect.Execute("Select * From HDSystem_Databases order by number")
    ZtCombo.Clear
    With Xtztxxrec
        Do While Not .EOF
            If .Fields("YNuse") = "1" Then
                ZtCombo.AddItem .Fields("number") + "-" + Trim(.Fields("CountingRoomName"))
            End If
            .MoveNext
        Loop
    End With
End Sub
Private Sub ZtCombo_Click()
    Dim Xtztxxrec As New ADODB.Recordset        '系统帐套信息动态集
    Dim RecTemp As New ADODB.Recordset
    Dim Xt_Id As Integer                         '该模块系统的ID号
    
    On Error GoTo ErrHandle
    Set Xtztxxrec = Cw_DataEnvi.BaseInfoConnect.Execute("Select * From HDSystem_DataBases where Number='" + Trim(Mid(ZtCombo.Text, 1, InStr(1, ZtCombo.Text, "-") - 1)) + "'")
    With Xtztxxrec
        If Not .EOF Then
            Ztdqsjk = Trim(.Fields("DataBasesName"))
        End If
    End With
    If Ljyxxpd1 Then
        If Cw_DataEnvi.DataConnect.State = 1 Then Cw_DataEnvi.DataConnect.Close
        Cw_DataEnvi.DataConnect.Open Xtsjljc, "Hxxd", ErpPassWord
    Else
        Exit Sub
    End If
   
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute("Select ID From Xt_Xtgnb  Where gnbm='01'")
    If RecTemp.EOF = False Then
        Xt_Id = RecTemp.Fields("ID")
        Set Czyrec = Cw_DataEnvi.DataConnect.Execute("Select * From gy_czygl Where  right(left(AuthorityId," & Xt_Id & "),1)='1' order by czybm")
        XgmaCommand.Enabled = True
        QdCommand.Enabled = True
        CzyCombo.Enabled = True
    Else
        XgmaCommand.Enabled = False
        QdCommand.Enabled = False
        CzyCombo.Text = ""
        CzyCombo.Enabled = False
        Tsxx = "请将该系统的操作权限赋予操作员!"
        Call Xtxxts(Tsxx, 0, 4)
        Exit Sub
    End If

    Set Czyrec = Cw_DataEnvi.DataConnect.Execute("Select * From gy_czygl order by czybm")
    CzyCombo.Clear
    With Czyrec
        Do While Not .EOF
            CzyCombo.AddItem Trim(.Fields("czybm")) + "-" + Trim(.Fields("czymc"))
            .MoveNext
        Loop

        CzyCombo.Text = CzyCombo.List(0)
    End With
    Set Xtrlrec = Cw_DataEnvi.DataConnect.Execute("Select distinct kjyear From gy_kjrlb order by kjyear ")
    KjyearCombo.Clear
    With Xtrlrec
        Do While Not .EOF
           KjyearCombo.AddItem Trim(.Fields("kjyear"))
           .MoveNext
        Loop
    End With
    
    Set Xtrlrec = Cw_DataEnvi.DataConnect.Execute("Select top 1 kjyear From gy_kjrlb where Arjzbz=0 order by kjyear desc,period ")
    If Not Xtrlrec.EOF Then
        KjyearCombo.Text = Xtrlrec.Fields("Kjyear")
    End If
   
    Call Drxtztcs             '读入系统帐套参数
  
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute("Select ServerDate=getdate()")
    CzrqText = Format(RecTemp.Fields("ServerDate"), "yyyy-mm-dd")
   
ErrHandle:
   
End Sub
Private Sub Czrqbz()                                                  '操作日期帮助
    Xtcdcs = Trim(CzrqText.Text)
    Xtfhcs = ""
    XT_calendar.Show 1
    If Xtfhcs <> "" Then
        CzrqText.Text = Trim(Xtfhcs)
    End If
    CzrqText.SetFocus
End Sub
Private Sub CzrqText_KeyDown(KeyCode As Integer, Shift As Integer)    '操作日期帮助
    If KeyCode = vbKeyF2 Then
        Call Czrqbz
    End If
End Sub
Private Function Xtyxxpd() As Boolean                                                   '系统有效性判断
    Xtyxxpd = False
    If Len(Trim(ZtCombo.Text)) = 0 Then
        Tsxx = "公司帐套不能为空,请先建帐套!"
        Call Xtxxts(Tsxx, 0, 1)
        ZtCombo.SetFocus
        Exit Function
    End If
    lsblte = Trim(CzrqText.Text)
    If IsDate(lsblte) Then
        CzrqText.Text = Format(lsblte, "yyyy-mm-dd")
    Else
        Tsxx = "非法公历日期!(格式:" + Format(Date, "yyyy-mm-dd") + ")"
        Call Xtxxts(Tsxx, 0, 1)
        Xtyxxpd = False
        CzrqText.SetFocus
        Exit Function
    End If
    If Val(KjyearCombo.Text) <> Val(Mid(CzrqText.Text, 1, 4)) Then
        Tsxx = "所选操作日期与会计年度不一致!"
        Call Xtxxts(Tsxx, 0, 1)
        Xtyxxpd = False
        CzrqText.SetFocus
        Exit Function
    End If
    
    If Trim(CzyCombo.Text) = "" Then
        Tsxx = "用户名不能为空!"
        Call Xtxxts(Tsxx, 0, 1)
        Xtyxxpd = False
        CzyCombo.SetFocus
        Exit Function
    End If
    
    Set Czyrec = Cw_DataEnvi.DataConnect.Execute("Select * From gy_czygl where czybm='" + Trim(Mid(CzyCombo.Text, 1, InStr(1, CzyCombo.Text, "-") - 1)) + "'")
    With Czyrec
        If Not .EOF Then
            If Trim(.Fields("czmm")) <> Mmjm(MmText.Text) Then
                Tsxx = "操作员密码录入错误!"
                Call Xtxxts(Tsxx, 0, 1)
                Xtyxxpd = False
                MmText.SetFocus
                Exit Function
            End If
        Else
            Tsxx = "无此操作员!"
            Call Xtxxts(Tsxx, 0, 1)
            Xtyxxpd = False
            CzyCombo.SetFocus
            Exit Function
        End If
   End With
   Xtyxxpd = True
End Function
Private Function Ljyxxpd1() As Boolean                  '数据服务器(帐套当前数据库)连接有效性测试
    Ljyxxpd1 = False
    Xtsjljc = "Provider=SQLOLEDB.1;"
    
    Xtsjljc = Xtsjljc + "Persist Security Info=False;"
    
    Xtsjljc = Xtsjljc + "Data Source=" + Trim(ServerText.Text) + ";"
    
    Xtsjljc = Xtsjljc + " Initial Catalog=" + Ztdqsjk + ";"
    
    On Error GoTo Cwcl
    If Cslj.State = 1 Then Cslj.Close
    Cslj.Open Xtsjljc, "Hxxd", ErpPassWord
    
    Ljyxxpd1 = True
    Exit Function
    
Cwcl:
    Tsxx = "帐套数据库连接失败!"
    Call Xtxxts(Tsxx, 0, 1)
    Exit Function
End Function
Private Sub XgmaCommand_Click()                '修改密码
    If Trim(CzyCombo.Text) = "" Then Exit Sub
    
    Set Czyrec = Cw_DataEnvi.DataConnect.Execute("Select * From gy_czygl where czybm='" + Trim(CzyCombo.Text) + "' or czymc='" & Trim(CzyCombo.Text) & "' or rtrim(czybm)+'-'+rtrim(czymc)='" & Trim(CzyCombo.Text) & "'")
    With Czyrec
        If Not .EOF Then
        CzyCombo.Text = Trim(.Fields("czybm")) + "-" + Trim(.Fields("czymc"))
        Else
            Tsxx = "无此用户名!"
            Call Xtxxts(Tsxx, 0, 1)
            Exit Sub
        End If
    End With
    Czyrec.Close
    Set Czyrec = Nothing
    
    
    With StTab
        .TabEnabled(0) = False
        Frame1(0).Enabled = False
        .TabEnabled(2) = True
        Frame1(2).Enabled = True
        .Tab = 2
    End With
    LrText(0).Text = Trim(MmText.Text)
    LrText(1).Text = ""
    LrText(2).Text = ""
    LrText(0).SetFocus
End Sub
Private Sub MmqdCommand_Click()                '修改密码完毕确定
    With Czyrec
        If .State = 1 Then .Close
        .Open "SELECT * FROM gy_czygl WHERE czybm= '" + Trim(Mid(CzyCombo.Text, 1, InStr(1, CzyCombo.Text, "-") - 1)) + "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If .EOF Then
            Tsxx = "此操作员已删除!"
            Call Xtxxts(Tsxx, 0, 1)
            Exit Sub
        End If
        If Trim(.Fields("czmm")) <> Mmjm(Trim(LrText(0).Text)) Then
            Tsxx = "输入旧密码错误!"
            Call Xtxxts(Tsxx, 0, 1)
            LrText(0).SetFocus
            Exit Sub
        End If
        If Len(Trim(LrText(1).Text)) = 0 Then
            Tsxx = "操作员密码不能为空!"
            Call Xtxxts(Tsxx, 0, 1)
            LrText(1).SetFocus
            Exit Sub
        End If
        If Trim(LrText(0).Text) = Trim(LrText(1).Text) Then
            Tsxx = "密码没有发生改变!"
            Call Xtxxts(Tsxx, 0, 1)
            LrText(1).SetFocus
            Exit Sub
        End If
        If Trim(LrText(1).Text) <> Trim(LrText(2).Text) Then
            Tsxx = "输入密码与确认密码不一致!"
            Call Xtxxts(Tsxx, 0, 1)
            LrText(1).SetFocus
            Exit Sub
        End If
        .Fields("czmm") = Mmjm(Trim(LrText(1).Text))
        .Fields("xgrq") = Date
        .Update
        MmText.Text = Trim(LrText(1).Text)
        Tsxx = "用户密码修改完毕!"
        Call Xtxxts(Tsxx, 0, 4)
    End With
    With StTab
        .TabEnabled(0) = True
        Frame1(0).Enabled = True
        .TabEnabled(2) = False
        Frame1(2).Enabled = False
        .Tab = 0
    End With
End Sub
Private Sub MmqxCommand_Click()                          '修改密码取消
    With StTab
        .TabEnabled(0) = True
        Frame1(0).Enabled = True
        .TabEnabled(2) = False
        Frame1(2).Enabled = False
        .Tab = 0
    End With
End Sub