frmpurchasesalevoucher.frm

金算盘软件代码

    End If
End Sub

Private Sub mclsMainControl_ToolRefresh()
    Dim recTmp As rdoResultset
    
    msgReceipt.Cols = 0
    msgReceipt.Rows = 2
    msgReceipt.RowData(1) = 0
    Set recTmp = GetReceiptList()
    If Not recTmp Is Nothing Then
        Set datReceipt.Resultset = recTmp
    Else
        msgReceipt.Cols = 3
    End If
    mclsReceiptGrid.ColSort(mintColCheck) = True
    mclsReceiptGrid.ColOfs = mintColCheck + 1
    msgReceipt.ColWidth(1) = 0
    msgReceipt.ColWidth(mintColCheck) = 420
    mclsReceiptGrid.SetupStyle
    mclsReceiptGrid.ListSetToGrid
    Set recTmp = Nothing
    Set datReceipt.Resultset = Nothing
End Sub

'设置菜单可用属性
Private Sub UpdateMenuStatus()
    With frmMain
        .mnuEditCopy.Enabled = False
        .mnuEditEdit.Enabled = False
        .mnuEditNew.Enabled = False
        .mnuEditDel.Enabled = False
        .mnuEditInActive.Enabled = False
        .mnuEditShowAll.Checked = False
        .mnuEditShowAll.Enabled = False
        .mnuEditUse.Enabled = False
        .mnuEditColumn.Enabled = (stabWizard.Tab = 1)
        .mnuEditFilter.Enabled = False
        .mnuEditSearch.Enabled = False
        .mnuEditNotepad.Enabled = False
        .mnuEditShowList.Enabled = False
        .mnuEditUse.Enabled = False
        .mnuFilePrint.Enabled = False
        .mnuToolRefresh.Enabled = (stabWizard.Tab = 1)
        .SetToolBar
    End With
End Sub

Private Sub mclsReceiptGrid_AfterRefresh(lngRow As Long)
    Dim intCol1 As Integer
    Dim intCol2 As Integer
    Dim dblAmount1 As Double
    Dim dblAmount2 As Double
    Dim intDec As Integer
    
    intCol1 = GetGridCol("原币金额", msgReceipt)
    intCol2 = GetGridCol("原币税额", msgReceipt)
    intDec = GetGridValue(lngRow, 1, "Long", msgReceipt)
    If intCol1 > 0 Then
        dblAmount1 = GetGridValue(lngRow, intCol1, "Double", msgReceipt)
        msgReceipt.TextMatrix(lngRow, intCol1) = strFormat(dblAmount1, intDec)
    End If
    If intCol2 > 0 Then
        dblAmount2 = GetGridValue(lngRow, intCol2, "Double", msgReceipt)
        msgReceipt.TextMatrix(lngRow, intCol2) = strFormat(dblAmount2, intDec)
    End If
End Sub


Private Sub msgReceipt_KeyPress(KeyAscii As Integer)
    If KeyAscii <> 32 Then Exit Sub
    Dim strSql As String
    Dim errNo As Long
    
    On Error GoTo ErrHandle
    
    With msgReceipt
        If .Row < .Rows And .Row >= .FixedRows Then
            If .TextMatrix(.Row, mintColCheck) = "√" Then
                .TextMatrix(.Row, mintColCheck) = ""
                Select Case mstrFrom
                Case "商品业务"
                    If cboActivityType.Text = "结转成本" Then
                        strSql = "UPDATE ItemActivity SET lngVoucherID1 =0 WHERE lngActivityID1=" & .TextMatrix(.Row, 0)
                    Else
                        strSql = "UPDATE ItemActivity SET lngVoucherID =0 WHERE lngActivityID=" & .TextMatrix(.Row, 0)
                    End If
                Case "财务业务"
                    strSql = "UPDATE Activity SET lngVoucherID=0 WHERE lngActivityID=" & .TextMatrix(.Row, 0)
                Case "保险业务"
                    Select Case .TextMatrix(.Row, 2)
                    Case 51 '"开户"
                        strSql = "UPDATE AccOpen SET lngVoucherID=0 WHERE lngActivityID=" & .TextMatrix(.Row, 0)
                    Case 52 '"销户"
                        strSql = "UPDATE AccClose SET lngVoucherID=0 WHERE lngActivityID=" & .TextMatrix(.Row, 0)
                    Case 48 '"汇缴书"
                        strSql = "UPDATE Receive SET lngVoucherID=0 WHERE lngActivityID=" & .TextMatrix(.Row, 0)
                    Case 50 '"补缴书"
                        strSql = "UPDATE Repair SET lngVoucherID=0 WHERE lngActivityID=" & .TextMatrix(.Row, 0)
                    Case 49 '"结算单"
                        strSql = "UPDATE Polic SET lngVoucherID=0 WHERE lngActivityID=" & .TextMatrix(.Row, 0)
                    End Select
                End Select
            Else
                .TextMatrix(.Row, mintColCheck) = "√"
                Select Case mstrFrom
                Case "商品业务"
                    If cboActivityType.Text = "结转成本" Then
                        strSql = "UPDATE ItemActivity SET lngVoucherID1=-1 WHERE lngActivityID1=" & .TextMatrix(.Row, 0)
                    Else
                        strSql = "UPDATE ItemActivity SET lngVoucherID=-1 WHERE lngActivityID=" & .TextMatrix(.Row, 0)
                    End If
                Case "财务业务"
                    strSql = "UPDATE Activity SET lngVoucherID=-1 WHERE lngActivityID=" & .TextMatrix(.Row, 0)
                Case "保险业务"
                    Select Case .TextMatrix(.Row, 2)
                    Case 51 '"开户"
                        strSql = "UPDATE AccOpen SET lngVoucherID=-1 WHERE lngActivityID=" & .TextMatrix(.Row, 0)
                    Case 52 '"销户"
                        strSql = "UPDATE AccClose SET lngVoucherID=-1 WHERE lngActivityID=" & .TextMatrix(.Row, 0)
                    Case 48 '"汇缴书"
                        strSql = "UPDATE Receive SET lngVoucherID=-1 WHERE lngActivityID=" & .TextMatrix(.Row, 0)
                    Case 50 '"补缴书"
                        strSql = "UPDATE Repair SET lngVoucherID=-1 WHERE lngActivityID=" & .TextMatrix(.Row, 0)
                    Case 49 '"结算单"
                        strSql = "UPDATE Polic SET lngVoucherID=-1 WHERE lngActivityID=" & .TextMatrix(.Row, 0)
                    End Select
                End Select
            End If
            gclsBase.ExecSQL strSql
        End If
    End With
    Exit Sub
    
ErrHandle:
    errNo = Errors.ErrorsDeal(True, Me)
    Select Case errNo
    Case edtResume: Resume
    Case edtResumeNext: Resume Next
    Case edtCanNotKnown
        ShowMsg hwnd, "程序出错：" & Err.Description, vbOKOnly + vbCritical, Caption
    End Select
End Sub

Private Sub stabWizard_Click(PreviousTab As Integer)
    
    ' 若向导进入其他步骤，进行该步骤合法检查
    If stabWizard.Tab > mintStep And mintStep < mintStepNum Then
        If ValidStep(mintStep) Then
            mintStep = stabWizard.Tab
        End If
        
        '初始向导步骤
        InitStep mintStep
    Else
        mintStep = stabWizard.Tab
        InitStep mintStep
        RefreshCmd
    End If
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'向导公用过程
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 向导每步合法检查
Private Function ValidStep(ByVal TabIndex As Integer) As Boolean
    Dim strMsg As String, lngBottom As Integer
    
    Select Case TabIndex
    Case 0: ValidStep = ValidActivity(strMsg)        '业务类型
    Case 1: ValidStep = ValidReceiptRange(strMsg)    '选择单据
    Case 2: ValidStep = ValidSetVoucher(strMsg)      '设置凭证
    Case 3: ValidStep = ValidManner(strMsg)          '生成方式
    Case Else
        ValidStep = True
    End Select
    
    '返回上一步
    If Not ValidStep Then
        If mintStep < stabWizard.Tab Then
            stabWizard.Tab = mintStep
        Else
            mintStep = stabWizard.Tab
            RefreshCmd
        End If
        ShowMsg hwnd, strMsg, vbExclamation + vbOKOnly, Caption
    End If
    
    '设置每步合法性
    If TabIndex <> -1 Then
        mblnValid(TabIndex) = ValidStep
    End If
    
End Function
' 向导每步初始设置
Private Sub InitStep(ByVal TabIndex As Integer)
    Dim lngCnt As Long
    
    Select Case TabIndex
    Case 0: InitActivity      '业务类型
    Case 1: InitReceiptRange  '选择单据
    Case 2: InitSetVoucher    '设置凭证
    Case 3                    '生成方式
        For lngCnt = 0 To TabIndex - 1
            If Not mblnValid(lngCnt) Then
                ShowMsg hwnd, "没有进行" & Left$(stabWizard.TabCaption(lngCnt), 4), vbExclamation + vbOKOnly, Caption
                stabWizard.Tab = lngCnt
                Exit For
            End If
        Next lngCnt
        InitManner
    End Select
    RefreshCmd
End Sub

'调整拆卸、组装单
Private Sub ReChoose()
    Dim strSql As String
    Dim recActivity As rdoResultset
    
    strSql = "SELECT intYear,bytPeriod,strReceiptNO,lngReceiptNO,lngActivityTypeID " _
        & "FROM ItemActivity WHERE lngActivityTypeID IN (" & atInAssemble & "," & atOutApart & ") "
    If cboActivityType.Text = "结转成本" Then
        strSql = strSql & "AND lngVoucherID1=-1"
    Else
        strSql = strSql & "AND lngVoucherID=-1"
    End If
    Set recActivity = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do While Not recActivity.EOF
        Select Case recActivity!lngActivityTypeID
        Case atInAssemble
            If cboActivityType.Text = "结转成本" Then
                strSql = "UPDATE ItemActivity SET lngVoucherID1=-1 "
            Else
                strSql = "UPDATE ItemActivity SET lngVoucherID=-1 "
            End If
            strSql = strSql & "WHERE intYear=" & recActivity!intYear & " AND bytPeriod=" & recActivity!bytPeriod _
                & " AND lngActivityTypeID=" & atOutAssemble & " AND strReceiptNo='" _
                & recActivity!strReceiptNo & "' AND lngReceiptNo=" & recActivity!lngReceiptNo
            gclsBase.ExecSQL strSql
        Case atOutApart
            If cboActivityType.Text = "结转成本" Then
                strSql = "UPDATE ItemActivity SET lngVoucherID1=-1 "
            Else
                strSql = "UPDATE ItemActivity SET lngVoucherID=-1 "
            End If
            strSql = strSql & "WHERE intYear=" & recActivity!intYear & " AND bytPeriod=" & recActivity!bytPeriod _
                & " AND lngActivityTypeID=" & atInApart & " AND strReceiptNo='" _
                & recActivity!strReceiptNo & "' AND lngReceiptNo=" & recActivity!lngReceiptNo
            gclsBase.ExecSQL strSql
        End Select
        recActivity.MoveNext
    Loop
    recActivity.Close
    Set recActivity = Nothing
End Sub

' 向导完成后需执行的操作
Public Sub Execute()
    Dim strSql As String
    Dim strList As String
    Dim errNo As Long
    Dim lngCnt As Long
    Dim lngSortCol As Long
    
    On Error Resume Next
    lngSortCol = mclsReceiptGrid.SortedCol
    Set mclsReceiptGrid = Nothing
    mstrGuestID = ""
    mstrReceiptID = ""
    mstrInvoiceID = ""
    On Error GoTo ErrHandle
    
    Select Case mstrFrom
    Case "财务业务"
        strList = "QActivityList"
    Case "保险业务"
        strList = "QInsurantList"
    Case "商品业务"
        Select Case cboActivityType.Text
        Case "采购业务"
            strList = "QItemReceiptInList"
            SaveSet 1, "购销凭证", "票货同到不走采购科目", CStr(chkNoPurchase.Value)
    '        SaveSet 1, "购销凭证", "非票货同到走暂估入库", CStr(chkNoSame.Value), True, "Long"
        Case "销售业务", "结转成本"
            strList = "QItemReceiptOutList"
            SaveSet 1, "购销凭证", "根据发票确定收入", CStr(optInvoice(0).Value)
        Case Else
            strList = "QItemReceiptInList"
        End Select
    End Select
    
    strSql = "SELECT * FROM " & strList & " "
    Select Case Trim(cboActivityType.Text)
    Case "应收应付"
        '应收借项、应收贷项、应付借项、应付贷项、财务费用
        strSql = strSql & "WHERE lngActivityTypeID IN (" & atCreditAP & "," _
            & atDebitAP & "," & atCreditAR & "," & atDebitAR & "," & atFinanCharge & ")"
    Case "应收"
        '应收借项、应收贷项、财务费用
        strSql = strSql & "WHERE lngActivityTypeID IN (" & atCreditAR & "," _
            & atDebitAR & "," & atFinanCharge & ")"
    Case "应付"
        '应付借项、应付贷项
        strSql = strSql & "WHERE lngActivityTypeID IN (" & atCreditAP & "," _
            & atDebitAP & ")"
    Case "收款付款"
        '收款、付款
        strSql = strSql & "WHERE lngActivityTypeID IN (" & atPayment & "," _
            & atReceipt & ")"
    Case "采购业务"