frmvocherno.frm

金算盘软件代码

                            lischa.AddItem strfg1
                             
                        End If
                        a = i
                        b = i
                        If i = strDig1 Then '不连号最后记录
                            strfg1 = "                   缺号   " & strCode & "-" & Format(a, "00##")
                            lischa.AddItem strfg1
                             
                            bz2 = False
                        Else: bz2 = True
                        End If
                        
                    End If
                 End If
            Else
                If !blnIsVoid <> 0 Then
                    lngZfs = lngZfs + 1
                    If bz2 Then
                        If a = b Then
                            strfg1 = "                   缺号   " & strCode & "-" & a
                        Else
                            strfg1 = "                   缺号   " & strCode & "-" & a & " 到 " & strCode & "-" & b
                        End If
                        lischa.AddItem strfg1

                        bz2 = False
                    End If
                    If bz3 Then
                        c = i
                        d = i
                        bz3 = False
                        bz4 = True
                    Else
                        If (d = i - 1) And (d <> (strDig1 - 1)) Then
                            d = i
                        ElseIf d = strDig1 - 1 Then
                            d = i
                            strfg1 = "                   作废   " & strCode & "-" & Format(c, "00##") & " 到 " & strCode & "-" & Format(d, "00##")
                            lischa.AddItem strfg1

                            bz4 = False
                        Else
                            If bz4 Then
                                If c = d Then
                                    strfg1 = "                   作废   " & strCode & "-" & Format(c, "00##")
                                Else: strfg1 = "                   作废   " & strCode & "-" & Format(c, "00##") & " 到 " & strCode & "-" & Format(d, "00##")
                                End If
                                lischa.AddItem strfg1

                            End If
                            c = i
                            d = i
                            If i = strDig1 Then
                               strfg1 = "                   作废   " & strCode & "-" & Format(c, "00##")
                               lischa.AddItem strfg1

                               bz4 = False
                            Else: bz4 = True
                            End If
                        End If
                    End If
                End If
            End If
          
        Next i
        lngZds = lngZds + i - 1 '总单数
        If bz2 Then
            If a = b Then
                strfg1 = "                   缺号   " & strCode & "-" & Format(a, "00##")
            Else
                strfg1 = "                   缺号   " & strCode & "-" & Format(a, "00##") & " 到 " & strCode & "-" & Format(b, "00##")
            End If
            lischa.AddItem strfg1
             
        End If
        If bz4 Then
            If c = d Then
                strfg1 = "                   作废   " & strCode & "-" & Format(c, "00##")
            Else
                strfg1 = "                   作废   " & strCode & "-" & Format(c, "00##") & " 到 " & strCode & "-" & Format(d, "00##")
            End If
            lischa.AddItem strfg1

        End If
        End With
endpiont:
        recNo.Close
        
End Sub
Private Sub ReCode()
    On Error GoTo EndProc
    If Year1 <= 0 Then Exit Sub
    If Month1 <= 0 Then Exit Sub
    Dim recSql As rdoResultset
    Dim str As String
    Dim strReceiptNo1 As String
    Dim lngReceiptNO1 As Long
        gclsBase.BaseWorkSpace.BeginTrans
        stbButton.Panels(1).Text = "编号整理"
        lngZds = 0: lngQhs = 0: lngZfs = 0
        str = "intYear=" & Year1 & " and  bytPeriod=" & Month1 & " and  lngReceiptTypeID=41 ORDER BY lngReceiptTypeID,strReceiptNO"
        Set recSql = gclsBase.BaseDB.OpenResultset("SELECT strReceiptNo,lngReceiptNo from ReceiptMaxNO WHERE " & str, rdOpenStatic)
        If recSql Is Nothing Then
            Exit Sub
        End If
        If recSql.EOF Then
            recSql.Close
            Set recSql = Nothing
            Exit Sub
        End If
        With recSql
        .MoveFirst
        '取前缀,最大编号
        Do While Not .EOF
                If IsNull(!strReceiptNo) Then
                    strReceiptNo1 = ""
                Else
                    strReceiptNo1 = !strReceiptNo
                End If
                lngReceiptNO1 = !lngReceiptNo
                ReCode1 strReceiptNo1, lngReceiptNO1, lngReceiptTypeID1  '前缀，最大编号，单据类型
                .MoveNext
        Loop
        .Close
        End With
        gclsBase.BaseWorkSpace.CommitTrans
        Set recSql = Nothing
        SqlRecMaxNo
        gclsSys.SendMessage Me.hWnd, 71
        Exit Sub
EndProc:
        Set recSql = Nothing
        gclsBase.BaseWorkSpace.RollBacktrans

End Sub
'前缀,最大编号,单据类型ID
Private Sub ReCode1(strAlp1 As String, strDig1 As Long, lngRTID As Long)
     Dim recNo As rdoResultset
     Dim str1 As String
     Dim i As Integer
     Dim blnQu As Boolean
     Dim strName As String
     Dim strCode As String
     Dim recTmp As rdoResultset
     Dim strSql As String
     Dim strTmp As String
     Call BillPublic.IdToCodeAndName(xVoucherType, C2lng(strAlp1), strCode, strName)
     'bz1,bz2   控制缺号    ；bz3、bz4控制作废数
        
        str1 = "SELECT intVoucherNO,strOldReceiptNo,blnIsPrinted,strVolume,lngVoucherID FROM Voucher" & _
               " WHERE intVoucherNO > 0 AND lngVoucherTypeID=" & C2lng(strAlp1) & " AND intYear=" & Year1 & " AND bytPeriod=" & Month1 & _
               " ORDER BY intVoucherNO"
        Set recNo = gclsBase.BaseDB.OpenResultset(str1, rdOpenDynamic, rdConcurRowVer)  'rdConcurValues)

        If recNo Is Nothing Then Exit Sub
        If recNo.EOF Then
            GoTo EndPoint
        End If
        strSql = "SELECT strVolume,intNoStart,intNoEnd FROM VoucherVolume" & _
                 " WHERE intYear=" & Year1 & " AND bytPeriod=" & Month1 & " AND lngVoucherTypeID=" & C2lng(strAlp1) & _
                 " ORDER BY intNoStart"
        Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
        With recNo
        For i = 1 To CInt(strDig1)
            If i \ 300 = i / 300 Then stbButton.Panels(2).Text = strCode & Format$(i, "0000")
ReJustice:
            If recNo.EOF Then
                GoTo EndPoint
            ElseIf recNo(0) < i Then
                recNo.MoveNext
                GoTo ReJustice
            ElseIf recNo(0) = i Then
                blnQu = False
            ElseIf recNo(0) > i Then
ReFindVolume:
                If recTmp.EOF Then
                    strSql = "00"
                ElseIf recTmp(2) < i Then
                    recTmp.MoveNext
                    GoTo ReFindVolume
                Else
                    strSql = recTmp(0)
                End If
'                recNo.Edit
'                    If recNo("blnIsPrinted") = 1 Then
'                        recNo("strOldReceiptNo") = SubStr(Trim(recNo("strOldReceiptNo") & strCode & Format$(recNo("intVoucherNO"), "0000")) & " ", 1, 30)
'                    End If
'                    recNo(0) = i
'                    recNo("strVolume") = strSql
'                recNo.Update
                '蔡奇科新程序-------------------------------
                If recNo("blnIsPrinted") = 1 Then
                    strTmp = ",strOldReceiptNo='" & SubStr(Trim(recNo("strOldReceiptNo") & strCode & Format$(recNo("intVoucherNO"), "0000")) & " ", 1, 30) & "'"
                Else
                    strTmp = ""
                End If
                strTmp = "Update Voucher Set intVoucherNo=" & i & ",strVolume=" & strSql & strTmp
                strTmp = strTmp & " WHERE lngVoucherID=" & recNo("lngVoucherID")
                gclsBase.BaseDB.Execute strTmp, rdExecDirect
                '---------------------------------------
                recNo.MoveNext
                blnQu = True
            End If
        Next i
        End With
EndPoint:
        recNo.Close
        Set recNo = Nothing
        If Not recTmp Is Nothing Then
            recTmp.Close
            Set recTmp = Nothing
        End If
        BillPublic.blnMaxNODecrease Year1, Month1, 41, strAlp1, strDig1
        
End Sub

Private Sub spinMonth_Change()
    Month1 = spinMonth.Value
    If Month1 < gclsBase.PeriodOfDate(dtmStartDate) Or Month1 > gclsBase.PeriodOfDate(dtmEndDate) Then
        ShowMsg Me.hWnd, "期间已在当前帐套的开始时间和结束时间之外了！", MB_SYSTEMMODAL + MB_ICONEXCLAMATION, "警告信息"
        spinMonth.Text = Format(gclsBase.PeriodOfDate(dtmStartDate), "0#")
'        Exit Sub
    End If
    
    If bz = True Then
        bz = False
        GoTo endpiont
    End If
    
    sDate = 0
    eDate = 0
    Debug.Print "---------" & Time
    Call gclsBase.DateOfPeriod(Year1, Month1, sDate, eDate)
    SqlRecMaxNo
    Debug.Print "---------" & Time
endpiont:

End Sub

Private Sub spinMonth_KeyUp(KeyCode As Integer, Shift As Integer, bCancel As Long)
    If KeyCode = 13 Then
        lischa.SetFocus
    ElseIf KeyCode = vbKeyEscape Then
        Unload Me
    End If
End Sub

Private Sub spinYear_Change()
    Year1 = SpinYear.Value
'-------------------------------------------
'设置控件的最大值和初始化其TEXT内容
    Call GetBaseStartAndEndPeriod(Year1, dtmStartDate, dtmEndDate, PeriodNum)
    spinMonth.Max = PeriodNum '+ gclsBase.PeriodOfDate(dtmStartDate) - 1
    spinMonth.Min = gclsBase.PeriodOfDate(dtmStartDate)
'-------------------------------------------
    If Year1 < gclsBase.FYearOfDate(dtmStartDate) Or Year1 > gclsBase.FYearOfDate(dtmEndDate) Then
        ShowMsg Me.hWnd, "年度已在当前帐套的开始时间和结束时间之外了！", MB_SYSTEMMODAL + MB_ICONEXCLAMATION, "警告信息"
        SpinYear.Text = Format(gclsBase.FYearOfDate(dtmStartDate), "####")
'        Exit Sub
    End If
    If bz = True Then
        bz = False
        GoTo endpiont
    End If
    
    If C2lng(spinMonth.Text) < C2lng(spinMonth.Min) Then
        Month1 = spinMonth.Min
        spinMonth.Text = spinMonth.Min
        GoTo endpiont
    End If
    
    sDate = 0
    eDate = 0
    Call gclsBase.DateOfPeriod(Year1, Month1, sDate, eDate)
    SqlRecMaxNo
endpiont:
End Sub
'-----------------------------------------------
'从会计期间表中取出当前帐套的起始日期和结束日期(gclsbase.BaseDate)
'SDate   要返回的起始日期
'EDate   要返回的结束日期
'-----------------------------------------------
Private Function GetBaseStartAndEndPeriod(ByVal intYear As Integer, sDate As Date, eDate As Date, PeriodNo As Integer) As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    
    GetBaseStartAndEndPeriod = True
    strSql = "select * from AccountYear WHERE intYear =" & intYear
    
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    
    If recTmp Is Nothing Then
        sDate = gclsBase.BaseDate
        eDate = gclsBase.BaseDate
        Exit Function
    End If
    If recTmp.BOF And recTmp.EOF Then
        sDate = gclsBase.BaseDate
        eDate = gclsBase.BaseDate
        recTmp.Close
        Set recTmp = Nothing
        Exit Function
    End If
    recTmp.MoveFirst
    sDate = recTmp!strStartDate
    recTmp.MoveLast
    eDate = recTmp!strEndDate
    PeriodNo = recTmp!bytPeriodNO
    recTmp.Close
'--------StartDate-------
    strSql = "SELECT strStartDate from Business "
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If recTmp Is Nothing Then
    Else
        If recTmp.BOF And recTmp.EOF Then
        Else
            If gclsBase.FYearOfDate(sDate) = gclsBase.FYearOfDate(recTmp!strStartDate) Then
                sDate = recTmp!strStartDate
            End If
        End If
        recTmp.Close
    End If
    Set recTmp = Nothing
End Function
'取当前帐套的开始年度和结束年度
Private Function GetStartAndEndYear(sYear As Integer, eYear As Integer) As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    
    GetStartAndEndYear = True
    strSql = "select intYear from accountyear order by intyear"
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recTmp Is Nothing Then
        sYear = gclsBase.AccountYear
        eYear = gclsBase.AccountYear
        Exit Function
    End If
    If recTmp.BOF And recTmp.EOF Then
        sYear = gclsBase.AccountYear
        eYear = gclsBase.AccountYear
        recTmp.Close
        Set recTmp = Nothing
        Exit Function
    End If
    recTmp.MoveLast
    eYear = recTmp!intYear
    recTmp.MoveFirst
    sYear = recTmp!intYear
    recTmp.Close
    Set recTmp = Nothing
End Function

Private Sub spinYear_KeyUp(KeyCode As Integer, Shift As Integer, bCancel As Long)
    If KeyCode = 13 Then
        spinMonth.SetFocus
    ElseIf KeyCode = vbKeyEscape Then
        Unload Me
    End If
End Sub