VB开发的ERP系统

            intMonth = .Fields("Period")
        End If
    End With
    adoRec.Close
    Set adoRec = Nothing
End Function

Private Sub FillWare(L As ListBox, Czybm As String, ChkFlag As Boolean)
    '填充仓库(001-listbox,002-操作员编码,003-结帐与恢复结帐标志)
    
    Dim strQuery As String
    Dim strTemp As String
    Dim i As Integer
    Dim adoWare As New ADODB.Recordset
    Dim adoTemp As New ADODB.Recordset
    Dim JZFlag As Boolean
    
    strTemp = "SELECT KFjzbz FROM GY_KJRLB WHERE KjYear=" & ChkYear & " and Period=" & ChkMonth
    Set adoTemp = Cw_DataEnvi.DataConnect.Execute(strTemp)
    
    If Not adoTemp.EOF Then
        JZFlag = CBool(adoTemp.Fields("kfjzbz"))
    End If
    adoTemp.Close
    Set adoTemp = Nothing
    
    If ChkFlag = True Then
        If JZFlag = True Then
            strQuery = "SELECT  whcode,whname FROM kf_v_whlimit WHERE 1=2"
        Else
            strQuery = "SELECT  whcode,whname FROM kf_v_whlimit WHERE czybm='" & Trim(Czybm) & "' AND EndDealFlagWh=0"
        End If
    Else
        If JZFlag = True Then
            strQuery = "SELECT  whcode,whname FROM kf_v_whlimit WHERE czybm='" & Trim(Czybm) & "' AND EndDealFlagWh=0"
        Else
            strQuery = "SELECT  whcode,whname FROM kf_v_whlimit WHERE czybm='" & Trim(Czybm) & "' AND EndDealFlagWh=1"
        End If
    End If
    
    Set adoWare = Cw_DataEnvi.DataConnect.Execute(strQuery)
    
    With adoWare
        If Not .EOF Then
            ReDim strWhCode(adoWare.RecordCount)
        End If
    End With
    
    L.Clear
    With L
        For i = 0 To adoWare.RecordCount - 1
             .AddItem Trim(adoWare.Fields("whcode")) + "-" + Trim(adoWare.Fields("whname"))
             strWhCode(i) = Trim(adoWare.Fields("whcode"))
             adoWare.MoveNext
        Next i
    End With
    
    adoWare.Close
    Set adoWare = Nothing

End Sub

Private Sub Form_Load()

    '填充会计期间
    Call FillKjYear(True, ChkYear, ChkMonth)
    lblCheckYear.Caption = CStr(ChkYear) & "." & CStr(ChkMonth)
    '填充结帐仓库
    Call FillWare(Lst_Check, Xtczybm, True)
    PB.Visible = False
    Me.Height = Me.Height - 500
    
End Sub


Private Sub QdAll_Click()
    '结帐全选
    
    If QdAll.Caption = "全选" Then
        QdAll.Tag = "全消"
        For i = 0 To Lst_Check.ListCount - 1
            Lst_Check.Selected(i) = True
        Next i
    Else
        For i = 0 To Lst_Check.ListCount - 1
          Lst_Check.Selected(i) = False
        Next i
    End If
    
    strTemp = QdAll.Caption
    QdAll.Caption = QdAll.Tag
    QdAll.Tag = strTemp
End Sub

Private Sub QdAllU_Click()
    '恢复结帐全选
    If QdAllU.Caption = "全选" Then
        QdAllU.Tag = "全消"
        For i = 0 To Lst_Uncheck.ListCount - 1
            Lst_Uncheck.Selected(i) = True
        Next i
    Else
        For i = 0 To Lst_Uncheck.ListCount - 1
          Lst_Uncheck.Selected(i) = False
        Next i
    End If
       
    strTemp = QdAllU.Caption
    QdAllU.Caption = QdAllU.Tag
    QdAllU.Tag = strTemp
End Sub

Private Sub QdOk_Click()
    '结帐处理
    
    If Not B_Status(Lst_Check) Then
        Tsxx = "您没有选仓库,请先选择!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
    
    On Error GoTo Swcwcl
    Me.Height = Me.Height + 500
    Me.Refresh
    PB.Visible = True
    PB.Max = Lst_Check.ListCount
    PB.Min = 0: PB.Value = 0
    Cw_DataEnvi.DataConnect.BeginTrans
         For i = 0 To Lst_Check.ListCount - 1
            If Lst_Check.Selected(i) Then
                Cw_DataEnvi.DataConnect.Execute ("KF_SP_Check   '" & Trim(Xtczy) & "'," & ChkYear & "," & ChkMonth & ",'" & Trim(strWhCode(i)) & "'")    '实物帐结帐
                Cw_DataEnvi.DataConnect.Execute ("KF_SP_MateCheck   '" & Trim(Xtczy) & "'," & ChkYear & "," & ChkMonth & ",'" & Trim(strWhCode(i)) & "'")   '材料帐结帐
            End If
            PB.Value = i + 1
            Lb.Caption = "已完成" & CStr(Int(PB.Value * 100 / PB.Max)) & "%"
            Lb.Refresh
         Next i
     Cw_DataEnvi.DataConnect.CommitTrans
    Tsxx = "月末结帐成功!"
    Call Xtxxts(Tsxx, 0, 4)
    Call SSTab1_Click(0)
    Lb.Caption = ""
    PB.Visible = False
    Me.Height = Me.Height - 500
    Exit Sub
Swcwcl:
    Cw_DataEnvi.DataConnect.RollbackTrans
    Tsxx = "月末结帐失败,系统恢复到初始状态!"
    Call Xtxxts(Tsxx, 0, 1)
    Me.Height = Me.Height - 500
    Exit Sub
End Sub

Private Sub QdOkU_Click()
    '恢复结帐
    
    Dim adoRec As New ADODB.Recordset
    Dim strSQL As String
        If Not B_Status(Lst_Uncheck) Then
        Tsxx = "您没有选仓库,请先选择!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
    
    On Error GoTo Swcwcl
    '如果核算系统已经完成结账,则不允许恢复结账
    strSQL = "SELECT KfJzbz,ChhsJzbz FROM Gy_Kjrlb WHERE KjYear=" & ChkYear & " AND Period=" & ChkMonth
    Set adoRec = Cw_DataEnvi.DataConnect.Execute(strSQL)
    If adoRec.Fields("chhsjzbz") Then
        Tsxx = "存货核算系统已经完成本月结帐,不允许恢复月末结帐!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
    
    adoRec.Close
    Set adoRec = Nothing
    
    Me.Height = Me.Height + 500
    Me.Refresh
    PB.Visible = True
    PB.Max = Lst_Uncheck.ListCount
    PB.Min = 0: PB.Value = 0
    Cw_DataEnvi.DataConnect.BeginTrans
         For i = 0 To Lst_Uncheck.ListCount - 1
            If Lst_Uncheck.Selected(i) Then
                Cw_DataEnvi.DataConnect.Execute ("KF_SP_UnCheck   '" & Trim(Xtczy) & "'," & ChkYear & "," & ChkMonth & ",'" & Trim(strWhCode(i)) & "'")
                Cw_DataEnvi.DataConnect.Execute ("KF_SP_UnMateCheck   '" & Trim(Xtczy) & "'," & ChkYear & "," & ChkMonth & ",'" & Trim(strWhCode(i)) & "'")
            Else
                Cw_DataEnvi.DataConnect.Execute ("Update Gy_Warehouse SET EndDealFlagWh=1 WHERE WhCode='" & Trim(strWhCode(i)) & "'")
            End If
            PB.Value = i + 1
            Lb.Caption = "已完成" & CStr(Int(PB.Value * 100 / PB.Max)) & "%"
            Lb.Refresh
         Next i
    Cw_DataEnvi.DataConnect.CommitTrans
    Tsxx = "恢复月末结帐成功!"
    Call Xtxxts(Tsxx, 0, 4)
    Call SSTab1_Click(1)
    Lb.Caption = ""
    PB.Visible = False
    Me.Height = Me.Height - 500
    Exit Sub
Swcwcl:
    Cw_DataEnvi.DataConnect.RollbackTrans
    Tsxx = "恢复月末结帐失败,系统恢复到初始状态!"
    Call Xtxxts(Tsxx, 0, 1)
    Me.Height = Me.Height - 500
    Exit Sub
End Sub

Private Sub QdQuit_Click()
    Unload Me
End Sub

Private Sub QdQuitU_Click()
    Unload Me
End Sub

Private Sub SSTab1_Click(PreviousTab As Integer)
    If SSTab1.Tab = 1 Then
        QdAllU.Caption = "全选"
        Call FillKjYear(False, ChkYear, ChkMonth)
        lblUnYear.Caption = CStr(ChkYear) & "." & CStr(ChkMonth)
        '填充结帐仓库
        Call FillWare(Lst_Uncheck, Xtczybm, False)
    Else
        QdAll.Caption = "全选"
        '填充会计期间
        Call FillKjYear(True, ChkYear, ChkMonth)
        lblCheckYear.Caption = CStr(ChkYear) & "." & CStr(ChkMonth)
        '填充结帐仓库
        Call FillWare(Lst_Check, Xtczybm, True)
    End If
End Sub


Private Function B_Status(L As ListBox) As Boolean
    For i = 0 To L.ListCount - 1
          B_Status = B_Status Or L.Selected(i)
    Next
End Function