frmac_multsel.frm

一个用VB写的财务软件源码

Dim i As Integer
If Me.chkAccountSel.Value = 0 Then
    If Index = tabSelect.Tabs - 1 Then
       Index = 2
       tabSelect.TabVisible(tabSelect.Tabs - 1) = False
    End If
    For i = 0 To tabSelect.Tabs - 2
        If i = Index - 1 Then
           tabSelect.TabVisible(i) = True
        Else
           tabSelect.TabVisible(i) = False
        End If
    Next
    tabSelect.Tab = Index - 1
Else
    tabSelect.TabVisible(tabSelect.Tabs - 1) = False
    tabSelect.TabVisible(0) = True
    tabSelect.Tab = 0
End If
If Index = 2 Then
   Call cmdPre_Click(1)
End If
End Sub
'==========================================================================

'===========================部门科目帮助=====================================
Private Sub cmdDept_Click()
Dim frm As New frmUSU_Department
With frm
     .Show vbModal, Me
     If .Valid Then
        txtDept.text = GetDeptName(.DepartmentCode, True)
     End If
End With
Unload frm
End Sub
Private Sub cmdSubject_Click()
Dim frm As New frmUSU_KmHelp
With frm
     .ubSelAll = True
     .MultiSelNode = False
     .Show vbModal, Me
     If frm.Valid Then
        txtSubject.text = GetKmName(.SubjectCode, True)
     End If
     Unload frm
End With
End Sub
'=========================================================================

'============================ 左右移动项目 ==============================
Private Sub cmdLeft_Click()
lsvItemSource.ListItems.Add , , lsvItemTarget.SelectedItem.text
lsvItemTarget.ListItems.Remove lsvItemTarget.SelectedItem.Index
End Sub
Private Sub cmdLeftAll_Click()
Dim i As Integer
While lsvItemTarget.ListItems.Count > 0
    lsvItemSource.ListItems.Add , , lsvItemTarget.ListItems(1).text
    lsvItemTarget.ListItems.Remove 1
Wend
End Sub
Private Sub cmdRight_Click()
Dim i As Integer
Dim sTmp As String
If lsvItemSource.SelectedItem.Index < 0 Then Exit Sub
sTmp = GetLeftRight(lsvItemSource.SelectedItem.text, "=", True)
If sTmp = "" Then Exit Sub
If GetLsvInclude(lsvItemTarget, sTmp) Then Exit Sub
i = 1
While i <= lsvItemTarget.ListItems.Count
    If InStr(1, GetLeftRight(lsvItemTarget.ListItems(i).text, "=", True), sTmp, vbTextCompare) <> 0 Then
       lsvItemTarget.ListItems.Remove i
    Else
       i = i + 1
    End If
Wend
lsvItemTarget.ListItems.Add , , lsvItemSource.SelectedItem.text
lsvItemSource.ListItems.Remove lsvItemSource.SelectedItem.Index
End Sub
Private Sub cmdRightAll_Click()
Dim i As Integer, j As Integer
Dim sTmp As String
i = 1
While i <= lsvItemSource.ListItems.Count
    sTmp = GetLeftRight(lsvItemSource.ListItems(i).text, "=", True)
    If Not GetLsvInclude(lsvItemTarget, sTmp) Then
        j = 1
        While j <= lsvItemTarget.ListItems.Count
            If InStr(1, GetLeftRight(lsvItemTarget.ListItems(j).text, "=", True), sTmp, vbTextCompare) <> 0 Then
               lsvItemTarget.ListItems.Remove j
            Else
               j = j + 1
            End If
        Wend
       lsvItemTarget.ListItems.Add , , lsvItemSource.ListItems(i).text
       lsvItemSource.ListItems.Remove i
    Else
       i = i + 1
    End If
Wend
End Sub
Private Function GetLsvInclude(lsv As ListView, sCode As String) As Boolean
Dim i As Integer
GetLsvInclude = False
For i = 1 To lsv.ListItems.Count
    If InStr(1, sCode, GetLeftRight(lsv.ListItems(i).text, "=", True), vbTextCompare) > 0 Then GetLsvInclude = True: Exit Function
Next
End Function
'=========================分析不同栏目时得到级次的最大值==========
Private Sub cboAnalyseObj_Click()
Dim iJcMax As Integer
Dim i As Integer
With cboAnalyseObj
        If .text = "科目" Then
          iJcMax = uGetSubSubjectMaxJc(m_sSubjectCode)
        ElseIf .text = "部门" Then
          iJcMax = uGetDeptMaxJc(m_sDeptCode)
        Else
          iJcMax = uGetItemMaxJc(m_sItemCodeCollect)
        End If
End With
With cboAnalyseLevel
        .Clear
        For i = 1 To iJcMax
            .AddItem i
        Next
        If .ListCount > 0 Then .ListIndex = .ListCount - 1
End With
End Sub
'=========================== 调整栏目的位置方向====================
Private Sub cmdDown_Click()
Dim s As String
With lsvAnalyseCol
     If .SelectedItem.Index <= 0 Then Exit Sub
     If .SelectedItem.text = "借方合计" Or .SelectedItem.text = "贷方合计" Then Exit Sub
     If .SelectedItem.Index = .ListItems.Count Then Exit Sub
     If .ListItems(.SelectedItem.Index + 1).text = "借方合计" Or .ListItems(.SelectedItem.Index + 1).text = "贷方合计" Then Exit Sub
     If .SelectedItem.SubItems(3) <> .ListItems(.SelectedItem.Index + 1).SubItems(3) Then Exit Sub
     s = .SelectedItem.SubItems(4)
     .SelectedItem.SubItems(4) = .ListItems(.SelectedItem.Index + 1).SubItems(4)
     .ListItems(.SelectedItem.Index + 1).SubItems(4) = s
     .SortKey = 4
     .Sorted = True
End With
End Sub

Private Sub cmdUp_Click()
Dim s As String
With lsvAnalyseCol
     If .SelectedItem.Index <= 1 Then Exit Sub
     If .SelectedItem.text = "借方合计" Or .SelectedItem.text = "贷方合计" Then Exit Sub
     If .SelectedItem.Index = .ListItems.Count Then Exit Sub
     If .ListItems(.SelectedItem.Index - 1).text = "借方合计" Then Exit Sub
     If Left(.SelectedItem.SubItems(4), 1) <> Left(.ListItems(.SelectedItem.Index - 1).SubItems(4), 1) Then Exit Sub
     s = .SelectedItem.SubItems(4)
     .SelectedItem.SubItems(4) = .ListItems(.SelectedItem.Index - 1).SubItems(4)
     .ListItems(.SelectedItem.Index - 1).SubItems(4) = s
     .SortKey = 4
     .Sorted = True
End With
End Sub
Private Sub cmdDirect_Click()
With lsvAnalyseCol
    If .SelectedItem.Index <= 0 Then Exit Sub
    If .SelectedItem.text = "借方合计" Or .SelectedItem.text = "贷方合计" Then Exit Sub
    If .SelectedItem.SubItems(3) = "借方" Then
       .SelectedItem.SubItems(3) = "贷方"
       .SelectedItem.SubItems(4) = "B" & Right(.SelectedItem.SubItems(4), Len(.SelectedItem.SubItems(4)) - 1)
    Else
       .SelectedItem.SubItems(3) = "借方"
        .SelectedItem.SubItems(4) = "A" & Right(.SelectedItem.SubItems(4), Len(.SelectedItem.SubItems(4)) - 1)
    End If
    .Sorted = True
    .SortKey = 4
End With
End Sub
'===========================保存到帐本===========================================
Private Sub CmdSave_Click()
Dim cmdTmp As New ADODB.Command
Dim sSQL As String
Dim sName As String
Dim sId As String
Dim i As Integer
Dim sTmp As String
sTmp = ""
With lsvAnalyseCol
     If GetListCheckCount <= 0 Then MsgBox "没有查询多栏账，不能保存！": Exit Sub
     For i = 1 To .ListItems.Count
         If .ListItems(i).Checked Then
            If .ListItems(i).text <> "借方合计" And .ListItems(i).text <> "贷方合计" Then
               sTmp = sTmp & .ListItems(i).text & ","
           End If
         End If
     Next
     If Trim(sTmp) = "" Then MsgBox "没有查询多栏账，不能保存！": Exit Sub

     If GetListCheckCount > AccountColCount Then MsgBox "查询多栏账不能超过" & AccountColCount & "，请重新选择！":  Exit Sub
     sTmp = DelLastChar(sTmp, 1)
     If m_sAccountType = "科目" Then
         If m_sSubjectCode = "" Then
            m_sSubjectCode = sTmp
         End If
     ElseIf m_sAccountType = "部门" Then
         If m_sDeptCode = "" Then
            m_sDeptCode = sTmp
         End If
     Else
         If m_sItemCodeCollect = "" Then
            m_sItemCodeCollect = sTmp
         End If
    End If
End With
sName = InputBox("多栏账账本名称", "请输入多栏账账本名称", "", Me.Top + 100, Me.Left + 100)
If sName = "" Then MsgBox "没有输入名称，不能保存！": Exit Sub
If Len(Trim(sName)) > 20 Then MsgBox "多栏账名称不能大于20个字符！": Exit Sub
If SqlStringValid(sName) = False Then MsgBox "多栏账名称不能含有非法的字符！": Exit Sub
With lsvAnalyseCol
    m_sMode = ""
    If m_bForeign Then m_sMode = "数量"
    If m_bAmount Then m_sMode = m_sMode & "外币"
    If m_sMode = "" Then m_sMode = "金额"
    m_sMode = m_sMode & "式"
    cmdTmp.ActiveConnection = glo.cnnMain
    cmdTmp.CommandType = adCmdText
    sId = GetAccountbookMaxId()
    sSQL = "insert into TFZ_MULACCOUNTBOOK(CID ,CNAME,CMode,CMonthFrom ,CMonthTo ,BIncludeNotRecordVoucher ,BShowNotMoneyCol ,CSubjectCode ,CDeptCode ,CsItemCodeCollect ,BAmount ,BForeign ,ILevel ,CAccountType )" & _
                                   "Values ('" & sId & "','" & m_sAccountName & sName & "','" & m_sMode & "','" & _
                                    m_sMonthFrom & "','" & m_sMonthTo & "'," & IIf(m_bIncludeNotRecordVoucher, -1, 0) & "," & _
                                    IIf(m_bShowNotMoneyCol, -1, 0) & ",'" & m_sSubjectCode & "','" & m_sDeptCode & "','" & _
                                    m_sItemCodeCollect & "'," & IIf(m_bAmount, -1, 0) & "," & IIf(m_bForeign, -1, 0) & "," & _
                                    m_iLevel & ",'" & m_sAccountType & "')"
    cmdTmp.CommandText = sSQL
    cmdTmp.Execute
    For i = 1 To .ListItems.Count
          If .ListItems.Item(i).Checked Then
            sSQL = "insert into TFZ_MULAccountBOOKCol(CID, CCOLCODE,CCOLNAME,ICOLLEVEL,CCOLDIRECT,CNUM) values('" & sId & "','" & .ListItems(i).text & "','" & .ListItems(i).SubItems(1) & "'," & Val(.ListItems(i).SubItems(2)) & ",'" & .ListItems(i).SubItems(3) & "','" & .ListItems(i).SubItems(4) & "')"
            cmdTmp.CommandText = sSQL
            cmdTmp.Execute
          End If
    Next
End With
Set cmdTmp = Nothing
Call LoadAccountBook
End Sub
'得到查询帐本
Private Sub GetFindAccountBook()
Dim i As Integer
Dim rstTmp As ADODB.Recordset
Dim sSQL As String
Dim sTmp As String
'''''''''''''''
'李剑
'现象：lstAccountBook无任何item点击出错
'
If lsvAccountBook.ListItems.Count <= 0 Then Exit Sub
'''''''''''''''

If lsvAccountBook.SelectedItem.Index <= 0 Then Exit Sub
Set rstTmp = New ADODB.Recordset
rstTmp.CursorLocation = adUseClient
sSQL = "select * from TFZ_MULAccountBOOK where CID='" & lsvAccountBook.SelectedItem.text & "'"
With rstTmp
    .Open sSQL, glo.cnnMain, adOpenStatic, adLockReadOnly
    If .RecordCount <= 0 Then Exit Sub
'        m_sMode = Trim("" & .Fields("CMode"))
'        m_sMonthFrom = Trim("" & .Fields("CMonthFrom"))
'        m_sMonthTo = Trim("" & .Fields("CMonthTo"))
'        m_bIncludeNotRecordVoucher = .Fields("bIncludeNotRecordVoucher")
'        m_bShowNotMoneyCol = .Fields("BShowNotMoneyCol")
        m_sSubjectCode = Trim("" & .Fields("CSubjectCode"))
'        m_sDeptCode = Trim("" & .Fields("CDeptCode"))
'        m_sItemCodeCollect = Trim("" & .Fields("CsItemCodeCollect"))
'        m_bAmount = .Fields("BAmount")
'        m_bForeign = .Fields("BForeign")
        m_iLevel = .Fields("iLevel")
        m_sAccountType = Trim("" & .Fields("CAccountType"))
    If .State = 1 Then .Close
    sSQL = "select CCOLCODE,CCOLNAME,ICOLLEVEL,CCOLDIRECT from TFZ_MULAccountBOOKCol where CID='" & lsvAccountBook.SelectedItem.text & "' order by CNUM"
    .Open sSQL, glo.cnnMain, adOpenStatic, adLockReadOnly
    If .RecordCount <= 0 Then Exit Sub
    ReDim Preserve m_arrColInformation(.RecordCount - 1)
    i = 0
    For i = 0 To .RecordCount - 1
        Set m_arrColInformation(i) = New clsSubSys
        m_arrColInformation(i).sColCode = .Fields("CCOLCODE")
        m_arrColInformation(i).sColName = rstTmp.Fields("CCOLNAME")
        m_arrColInformation(i).iColLevel = .Fields("ICOLLEVEL")
        m_arrColInformation(i).sColDirect = .Fields("CCOLDIRECT")
        m_arrColInformation(i).iColNum = i
        If .Fields("CCOLCODE") <> "借方合计" And .Fields("CCOLCODE") <> "贷方合计" Then
            sTmp = sTmp & .Fields("CCOLCODE") & ","
        End If
        .MoveNext
    Next
     sTmp = DelLastChar(sTmp, 1)
     If m_sAccountType = "科目" Then
         If m_sSubjectCode = "" Then
            m_sSubjectCode = sTmp
         End If
     ElseIf m_sAccountType = "部门" Then
         If m_sDeptCode = "" Then
            m_sDeptCode = sTmp
         End If
     Else
         If m_sItemCodeCollect = "" Then
            m_sItemCodeCollect = sTmp
         End If
    End If
End With
rstTmp.Close
Set rstTmp = Nothing
FindStar '查询
End Sub
Private Sub cmdDelete_Click()
Dim cmdTmp As New ADODB.Command
Dim sSQL As String
With lsvAccountBook
    If .ListItems.Count <= 0 Then Exit Sub
    If .SelectedItem.Index <= 0 Then Exit Sub
    cmdTmp.ActiveConnection = glo.cnnMain
    cmdTmp.CommandType = adCmdText
    sSQL = "delete TFZ_MULAccountBOOK where CID='" & .SelectedItem.text & "'"
    cmdTmp.CommandText = sSQL
    cmdTmp.Execute
    sSQL = "delete TFZ_MULAccountBOOKCol where CID='" & .SelectedItem.text & "'"
    cmdTmp.CommandText = sSQL
    cmdTmp.Execute
End With
LoadAccountBook '载入帐本
Set cmdTmp = Nothing