财务分析 财财务分析务分析

Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim Xtsjljc As String                       '系统数据服务器连接串
Dim ErpPassWord As String                   '系统连接密码
Dim Cslj As New ADODB.Connection            '测试连接(为屏蔽提示信息)
Dim Tsxx As String                          '系统提示信息
Dim Czyrec As New ADODB.Recordset           '操作员动态集
Dim Xtrlrec As New ADODB.Recordset          '系统日历动态集
Dim Ztdqsjk As String                       '所选帐套当前数据库
Private Function Ljyxxpd() As Boolean       '数据服务器(系统基本信息库)连接有效性测试
   Ljyxxpd = False
   If Len(Trim(ServerText.Text)) = 0 Then
      Tsxx = "数据服务器名不能为空!"
      Call Xtxxts(Tsxx, 0, 1)
      ServerText.SetFocus
      Exit Function
   End If
   Select Case LxCombo.ListIndex
      Case 0      'SQL SERVER数据库
         Xtsjljc = "Provider=SQLOLEDB.1;"
      Case Else
         Xtsjljc = "Provider=SQLOLEDB.1;"
   End Select
   
   Xtsjljc = Xtsjljc + "Persist Security Info=False;"
   
   Xtsjljc = Xtsjljc + "Data Source=" + Trim(ServerText.Text) + ";"
   
   Xtsjljc = Xtsjljc + " Initial Catalog=" + "Master" + ";"
   
   If Cslj.State = 1 Then Cslj.Close
   
   DdtsLabel = "系统正在连接数据服务器,请稍等..."
   DdtsLabel.Refresh
   With Me.Animation1
    .Visible = True
    .Open App.Path + "\Ljcs.avi"
    .Play
   End With
   On Error GoTo Cwcl
   
   If Cslj.State = 1 Then Cslj.Close
   Cslj.Open Xtsjljc, "Hxxd", ErpPassWord
   
   Animation1.Stop
   Animation1.Visible = False
   
   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 = 15
   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"
   
   XtMenuList = "01%"         '子系统菜单系统代号
   
   ErpPassWord = "123"
   
   With LxCombo
     .AddItem "SQL SERVER数据库"
   End With
      
   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
End Sub
Private Sub LjqdCommand_Click()                              '保 存 设 置
 Dim Fsote As New FileSystemObject, Tste As TextStream
 If Ljyxxpd Then
   Set Tste = Fsote.CreateTextFile(App.Path + "\新世纪erp.txt", True)
   Tste.WriteLine "Sqlserver=" + Trim(ServerText.Text)
   Tste.WriteLine "Datatype=" + Trim(Str(LxCombo.ListIndex))
   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
 End If
End Sub
Private Sub Qcljnr()                                         '取 出 数 据
  Dim Fsote As New FileSystemObject, Tste As TextStream
  Dim Dqhs As Integer, Dqnr As String
  Dqhs = 5
  On Error GoTo Cwcl:
  Set Tste = Fsote.OpenTextFile(App.Path + "\新世纪erp.txt", 1)
  For Jsqte = 1 To Dqhs
      Dqnr = Trim(Tste.ReadLine)
      If InStr(1, UCase(Dqnr), "SQLSERVER=") <> 0 Then
         ServerText.Text = Mid(Dqnr, InStr(1, UCase(Dqnr), "SQLSERVER=") + 10, Len(Dqnr))
      End If
      If InStr(1, UCase(Dqnr), "DATATYPE=") <> 0 Then
         lsbl = Val(Mid(Dqnr, InStr(1, UCase(Dqnr), "DATATYPE=") + 9, Len(Dqnr)))
         If lsbl >= 0 And lsbl <= 1 Then
            LxCombo.Text = LxCombo.List(lsbl)
         End If
      End If
  Next Jsqte
  Exit Sub
Cwcl:
   Exit Sub
End Sub
Private Sub QdCommand_Click()                                     '确定进入系统
  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
     If CtdrCheck.Value <> 1 Then
        CtdrCheck.Value = 1
        GgszCommand.Enabled = False
        XT_Main.Show
     End If
  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
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
    If ZtCombo.ListCount <> 0 Then
       ZtCombo.Text = ZtCombo.List(0)
    End If
   End With
End Sub
Private Sub ZtCombo_Click()
   Dim Xtztxxrec As New ADODB.Recordset        '系统帐套信息动态集
   Dim RecTemp As New ADODB.Recordset
   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 Czyrec = Cw_DataEnvi.DataConnect.Execute("Select * From xt_rygl 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 xt_kjrlb ")
   KjyearCombo.Clear
   With Xtrlrec
     Do While Not .EOF
        KjyearCombo.AddItem Trim(.Fields("kjyear"))
        .MoveNext
     Loop
        KjyearCombo.Text = KjyearCombo.List(KjyearCombo.ListCount - 1)
   End With
   
   Call Drxtztcs             '读入系统帐套参数
   
   Set RecTemp = Cw_DataEnvi.DataConnect.Execute("Select ServerDate=getdate()")
   CzrqText = Format(RecTemp.Fields("ServerDate"), "yyyy-mm-dd")
   
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
   Set Czyrec = Cw_DataEnvi.DataConnect.Execute("Select * From xt_rygl 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
   Select Case LxCombo.ListIndex
      Case 0      'SQL SERVER数据库
         Xtsjljc = "Provider=SQLOLEDB.1;"
      Case 1      'ORACLE数据库
         Xtsjljc = "Provider=MSDAORA.1;"
   End Select
   
   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()                '修改密码
  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 Xt_rygl 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