frmadjust.frm

金算盘软件代码

        End If
        If clsBill.blnPasteRec And clsBill.blnMayChange And chkPrint(1).Value = 0 Then
            .mnuListActivityMenu(4).Enabled = True
        Else
            .mnuListActivityMenu(4).Enabled = False
        End If
        Utility.CloneMenu .mnuEditBar2, .mnuListActivityMenu(5)
        .mnuListActivityMenu(5).Visible = True
        Utility.CloneMenu .mnuEditSearch, .mnuListActivityMenu(6)   ' "搜索"
'        .mnuListActivityMenu(7).Caption = "编号查询及整理"
'        .mnuListActivityMenu(7).Enabled = True
        .SetToolBar True
    End With
End Sub


'ID号变化(单据修改进入时有效)
Public Sub ShowAOldBill(ByVal ActivityID As Long)
    On Error GoTo ErrHandle
'    ShowANewBill ActivityID, False
    blnNotRaiseEvents = True
    If chkPrint(0).Visible Then
    End If
    Unload MsgForm
    If clsBill Is Nothing Then Exit Sub
    clsBill.lngNowID = ItemAcIDOther(ActivityID)
    
    Dim recTmp As rdoResultset
    Set recTmp = gclsBase.BaseDB.OpenResultset("select lngActivityID,lngActivityTypeID FROM ItemActivity WHERE lngActivityID=" & clsBill.lngNowID, rdOpenStatic)
    If recTmp!lngActivityTypeID = 28 Then
        'clsBill.lngNowID是调出ID，则传入的是调入ID
        m_lngInActivityID = ActivityID
        m_lngOutActivityID = clsBill.lngNowID
    Else
        'clsBill.lngNowID不是调出ID，则传入的是调出ID
        m_lngInActivityID = clsBill.lngNowID
        m_lngOutActivityID = ActivityID
        clsBill.lngNowID = m_lngOutActivityID
    End If
    recTmp.Close
    Set recTmp = Nothing
    
    LoadBill ActivityID 'clsBill.lngNowID
    clsBill.blnMayChange = True
    
    blnEdit = IsCanDo(EditNO(C2lng(lblHead(2).Tag)))    '填制权限
    blnView = IsCanDo(EditNO(C2lng(lblHead(2).Tag), False)) '查询权限
    
    If blnEdit = False And blnView = False Then
        Unload Me
        blnNotRaiseEvents = False
        Exit Sub
    End If
    arrDeleteActivityDetailID = ""
    If Me.Visible = False Then
'        blnFirstIn = True
        Me.Visible = True
    End If
    Me.ZOrder 0

'设置可修改标志
    If blnEdit And C2lng(LblMemo(3).Tag) = gclsBase.OperatorID Then
            '----------------------------------------------------
            If gclsBase.PeriodClosed(lblField(2).Caption) Then
                clsBill.blnMayChange = False
            ElseIf blnPrinted And BillRePrintRight(28, True) = False Then
                clsBill.blnMayChange = False
            ElseIf clsBill.blnDateErr(, False) Then    '已调价
                clsBill.blnMayChange = False
            Else
                clsBill.blnMayChange = True
            End If
            '----------------------------------------------------
    Else
        clsBill.blnMayChange = False
    End If
    '----------------------------------------------------
    If blnPrinted And BillRePrintRight(28) = False Then
        cmdButton(6).Enabled = False
    Else
        cmdButton(6).Enabled = True
    End If
    If WanNeng Then
        tblReceipt.Buttons(7).Enabled = cmdButton(6).Enabled
    End If
    '----------------------------------------------------
    
    clsBill.blnMayDelete = clsBill.blnMayChange
    If chkPrint(1).Value <> 0 Or clsBill.blnMayChange = False Then
        chkPrint(1).Enabled = False
    Else
        chkPrint(1).Enabled = True
        clsBill.Field_Click 2, False
    End If
    blnNotRaiseEvents = False
    MakeListActivityMenu
    MakeListEditMenu
    Exit Sub
ErrHandle:
    If Errors.ErrorsDeal = edtResume Then
         Resume
    Else
         On Error Resume Next
        blnNotRaiseEvents = False
        Unload Me
    End If
End Sub

Private Sub LoadBill(ByVal ItemAcId As Long)
    clsBill.blnRefresh = False
    LoadBillOther m_lngInActivityID, m_lngOutActivityID
    clsBill.blnRefresh = True
End Sub

Public Sub ShowANewBill(Optional ByVal CurrentActivityID As Long = 0, Optional ByVal blnGetBillNo As Boolean = True)
    On Error GoTo ErrHandle
    Dim strNo As String
    Dim lngTypeID As Long
    Dim lngID As Long
    If Not IsCanDo(EditNO(28)) Then
        If Not clsBill Is Nothing Then clsBill.blnRefresh = True
        If Not IsCanDo(EditNO(28, False)) Then
            Unload MsgForm
            ShowMsg Me.hWnd, gclsBase.OperatorName & "无新增及查询本单据权限！", MB_OK + MB_ICONEXCLAMATION + MB_SYSTEMMODAL, "新增单据"
            blnNotRaiseEvents = False
            Unload Me
            Exit Sub
        Else
            Dim lngLastID As Long
            lngLastID = GetLastActivityID(28, True)
            If lngLastID > 0 Then
                ShowAOldBill lngLastID
                Exit Sub
            End If
            Unload MsgForm
            ShowMsg Me.hWnd, gclsBase.OperatorName & "无新增本单据权限，并且系统中无可查询单据！", MB_OK + MB_SYSTEMMODAL + MB_ICONHAND, "新增单据"
            blnNotRaiseEvents = False
            Unload Me
            Exit Sub
        End If
    End If
    blnNotRaiseEvents = True
    
    blnEdit = IsCanDo(EditNO(28)) ' True '填制权限
    blnView = IsCanDo(EditNO(28, False)) 'True '查询权限
    If chkPrint(0).Visible Then
    End If
    Unload MsgForm
    lngTypeID = lblHead(3 - 1).Tag
    
    If clsBill.lngNowID = 0 Then
        getPrevPlateAndBillNo lngTypeID, lngID, strNo
    Else
        strNo = lblField(1).Caption
        lngID = lblHead(5 - 1).Tag
    End If
    If Me.Visible Then
    If Not ChangeSaveNote Then
        blnNotRaiseEvents = False
        Exit Sub
    End If
    End If
'    Me.SetFocus
'    Me.WindowState = 0
    clsBill.GetANewBill lngID, lngTypeID, strNo, blnGetBillNo
    blnIsCanEventChk_Click = True
    
    '----------------------------------------------------
    cmdButton(6).Enabled = True
    If WanNeng Then
        tblReceipt.Buttons(7).Enabled = cmdButton(6).Enabled
    End If
    '----------------------------------------------------
    clsBill.blnMayChange = True
    clsBill.blnMayDelete = False
    If Me.Visible = False Then
        blnFirstIn = True
        Me.Visible = True
    End If
    Me.ZOrder
    If blnGetBillNo Then clsBill.Field_Click 2, False
    blnNotRaiseEvents = False
    MakeListActivityMenu
    MakeListEditMenu
    Exit Sub
ErrHandle:
    If Errors.ErrorsDeal = edtResume Then
         Resume
    Else
         On Error Resume Next
        blnNotRaiseEvents = False
        Unload Me
    End If
End Sub
Private Function ChangeSaveNote() As Boolean
    Dim blnT As Boolean
    Dim dtmDate As Date
    Dim intYNC As Integer
    
    If clsBill.blnIsChanged Then
        intYNC = ShowMsg(Me.hWnd, "该张调拨单数据已经发生改变，是否需要保存?", MB_YESNOCANCEL + MB_DEFBUTTON1 + MB_ICONQUESTION + MB_SYSTEMMODAL, "警告提示")
        If intYNC = IDYES Then
            blnT = SaveBill()
            If blnT Then
                clsBill.blnIsChanged = False
            End If
            ChangeSaveNote = blnT
        ElseIf intYNC = IDNO Then
            clsBill.blnIsChanged = False
            ChangeSaveNote = True
            dtmDate = C2Date(lblField(2).Caption)
            If clsBill.lngNowID = 0 Then
                clsBill.intAccountYear = gclsBase.FYearOfDate(dtmDate)
                clsBill.bytAccountPeriod = gclsBase.PeriodOfDate(dtmDate)
                blnMaxNODecrease clsBill.intAccountYear, clsBill.bytAccountPeriod, C2lng(lblHead(2).Tag), strAlphaOfStr(lblField(1).Caption), BillPublic.strDigitOfStr(lblField(1).Caption)
            End If
        Else
            ChangeSaveNote = False
        End If
    Else
        ChangeSaveNote = True
        If clsBill.lngNowID = 0 Then
            clsBill.intAccountYear = gclsBase.FYearOfDate(lblField(2).Caption)
            clsBill.bytAccountPeriod = gclsBase.PeriodOfDate(lblField(2).Caption)
            blnMaxNODecrease clsBill.intAccountYear, clsBill.bytAccountPeriod, C2lng(lblHead(2).Tag), strAlphaOfStr(lblField(1).Caption), BillPublic.strDigitOfStr(lblField(1).Caption)
        End If
    End If
End Function

Public Function SaveBill() As Boolean
'保存当前单据函数
    On Error GoTo EndProc
    Dim BlnSaveSuccess As Boolean
    blnNotRaiseEvents = True
    Dim strAlpha As String
    Dim lngDigit As Long
    Dim dtmDate As Date
    dtmDate = C2Date(lblField(2).Caption)
    clsBill.intAccountYear = gclsBase.FYearOfDate(dtmDate)
    clsBill.bytAccountPeriod = gclsBase.PeriodOfDate(dtmDate)
    
    If Not clsBill.DataValid8() Then
      SaveBill = False
      blnNotRaiseEvents = False
      Exit Function
    End If
StartSaveNewBill:
    gclsBase.BaseWorkSpace.BeginTrans
    If clsBill.lngNowID = 0 Then
        blnReceiptNoError = False
        BlnSaveSuccess = SaveNewItemActivity()
        If BlnSaveSuccess = False And blnReceiptNoError And Me.Visible And gclsBase.AutoNo Then
            '发生单据号重复的错误导致存盘失败
            gclsBase.BaseWorkSpace.RollBacktrans
            lblField(1).Caption = strAlphaOfStr(lblField(1).Caption) & Format$(C2lng(strDigitOfStr(lblField(1).Caption)) + 1, "#0000")
            blnReceiptNoError = False
            GoTo StartSaveNewBill
        End If
    Else
        BlnSaveSuccess = SaveModifyBill(clsBill.lngNowID)
    End If
    If BlnSaveSuccess Then
        gclsBase.BaseWorkSpace.CommitTrans
    Else
        gclsBase.BaseWorkSpace.RollBacktrans
    End If
    If BlnSaveSuccess Then
        '取出重用信息
        strAlpha = SubStr(strAlphaOfStr(LTrim(lblField(1).Caption)), 1, 6)
        lngDigit = C2Dbl(strDigitOfStr(LTrim(lblField(1).Caption)))
    '    修改最大编号表
        If Not blnModifyMaxNO(clsBill.intAccountYear, clsBill.bytAccountPeriod, _
                    C2lng(lblHead(3 - 1).Tag), strAlpha, CStr(lngDigit)) Then
            GoTo EndProc
        End If
        blnMaxNODecrease clsBill.intAccountYear, clsBill.bytAccountPeriod, C2lng(lblHead(2).Tag), strAlphaOfStr(lblField(1).Caption), 9999  'BillPublic.strDigitOfStr(lblField(1).Caption)
        '向主控发送消息
        gclsSys.SendMessage Me.hWnd, 30 + C2lng(lblHead(2).Tag)
        clsBill.blnIsChanged = False
    End If
EndProc:
    SaveBill = BlnSaveSuccess
    If BlnSaveSuccess Then clsBill.blnIsChanged = False
    blnNotRaiseEvents = False
End Function

Public Function getID() As Long
    If clsBill Is Nothing Then Exit Function
    getID = clsBill.lngNowID
End Function
Private Function SaveNewItemActivity() As Boolean
  On Error Resume Next
'  If Not clsBill.DataValid8() Then
'    SaveNewItemActivity = False
'    Exit Function
'  End If
  SaveNewItemActivity = False
  If SaveNewBill(False) Then
        If SaveNewBill(True) Then
            SaveNewItemActivity = True
            Exit Function
        End If
  End If
  clsBill.lngNowID = 0
End Function

Private Sub refInput1_AddNew()
    clsBill.ReferEvent 0
End Sub

Private Sub refInput1_Choose()
    If blnNotRaiseEvents = True Then Exit Sub
    clsBill.refInput_Choose
End Sub

Private Sub refInput1_Delete()
    clsBill.ReferEvent 2
End Sub

Private Sub refInput1_Edit()
    clsBill.ReferEvent 1
End Sub
Private Sub refInput_AddNew()
    clsBill.ReferEvent 0
End Sub

Private Sub refInput_Choose()
    If blnNotRaiseEvents = True Then Exit Sub
    clsBill.refInput_Choose
End Sub

Private Sub refInput_Delete()
    clsBill.ReferEvent 2
End Sub

Private Sub refInput_Edit()
    clsBill.ReferEvent 1
End Sub

Private Sub refInput_GotFocus()
    If clsBill.bytRegion = FHead Then
        refInput.Appearance = 1
    Else
        refInput.Appearance = 0
    End If
End Sub

Private Function blnDeleteRecorder(ByVal lngActivityDetailID As Long) As Boolean
    Dim i As Integer
    Dim strTmp As String
    
    strTmp = CStr(lngActivityDetailID)
    If strTmp = "" Then
        blnDeleteRecorder = True
        Exit Function
    End If
    blnDeleteRecorder = False
    If InStr(arrDeleteActivityDetailID, strTmp) > 0 Then
        blnDeleteRecorder = True
    End If
End Function
Public Function WriteForm(ByVal strReceiptInfo As String) As Integer
    Dim strTmp As String
    Dim lngReceiptTypeID As Long
    Dim lngActivityTypeID As Long
    Dim lngRowno As Long
    Dim dblFactor As Double
    Dim dblTax As Double
    Dim intCurDec As Integer
    Dim intRateDec As Integer
    Dim strNo As String
    Dim lngID As Long

    WriteForm = 0
    On Error GoTo ErrHandle
    If GetString(strReceiptInfo, strTmp, 1) = False Then Exit Function '单据类型
    lngReceiptTypeID = C2lng(strTmp)
    If lngReceiptTypeID <> 28 Then
        Exit Function
    End If
    If GetString(strReceiptInfo, strTmp, 2) = False Then Exit Function 'yewu类型
    lngActivity