frmpayable.frm

金算盘软件代码

      Height          =   285
      Index           =   1
      Left            =   750
      TabIndex        =   24
      Tag             =   "0"
      Top             =   90
      Width           =   2100
   End
   Begin VB.Label lblHead 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "类型(Y)"
      ForeColor       =   &H00000000&
      Height          =   180
      Index           =   2
      Left            =   3660
      TabIndex        =   26
      Tag             =   "1"
      Top             =   120
      Width           =   630
   End
   Begin VB.Label lblHead 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "单位(C)"
      Height          =   180
      Index           =   0
      Left            =   60
      TabIndex        =   1
      Tag             =   "0"
      Top             =   135
      Width           =   630
   End
   Begin VB.Label lblHead 
      BackColor       =   &H80000009&
      BorderStyle     =   1  'Fixed Single
      Height          =   285
      Index           =   3
      Left            =   4290
      TabIndex        =   27
      Tag             =   "1"
      Top             =   90
      Width           =   1230
   End
   Begin VB.Label lblHead 
      Appearance      =   0  'Flat
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      BackStyle       =   0  'Transparent
      Caption         =   "模板(D)"
      ForeColor       =   &H80000008&
      Height          =   180
      Index           =   4
      Left            =   6030
      TabIndex        =   16
      Tag             =   "2"
      Top             =   120
      Width           =   630
   End
   Begin VB.Label lblHead 
      BackColor       =   &H80000009&
      BorderStyle     =   1  'Fixed Single
      Height          =   285
      Index           =   5
      Left            =   6690
      TabIndex        =   25
      Tag             =   "2"
      Top             =   90
      Width           =   1530
   End
End
Attribute VB_Name = "FrmPayable"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  单据(应付单)
'  作者：王兴元
'  日期：1998.07.2
'==================================================================================

Option Explicit
Public ReceiptTypeID  As Integer
Dim clsBill As BillSet                 '
Dim clsLst As clsListMethod         '确定凭证是否存在等的类模块
Dim WithEvents mclsMainControl As MainControl       '主控对象
Attribute mclsMainControl.VB_VarHelpID = -1
Dim strColRow() As String   '单据体行复制/粘贴存储区动态数组
Dim lgID As Long
Dim srName As String
Dim srCode As String
Dim blnHaveVoucher As Boolean       '确定是否生成了凭证
Dim blnNotResize As Boolean
Dim blnIsCanEventChk_Click As Boolean       '在进行LOADBILL时确定不进行提示的标志
Dim lngOldReceiptTypeID As Long

Dim blnWriteForm As Boolean     '是否是数据引入标志(不加载 MSGFORM 窗体)
Dim blnIsClose As Boolean   '关闭标志

Dim strAlpha As String  '单据号前缀
Dim lngDigit As Long    '单据号后缀
Dim lngHeadDetailID As Long
Public lngCancelActivityID As Long '冲销单据的原单据ID存贮变量
Dim blnEdit As Boolean  '填制权限
Dim blnView As Boolean  '查询权限

'Dim blnDebit As Boolean '确定单据类型是否为借方
Dim a() As Long
Dim b() As Long
Private blnPrinted As Boolean '已打印标志
Public mlngItemActivityID As Long '现结标志（采购销售单的单据ID）

Private Sub cmbInput_Click()
    Dim lngID As Long
    Dim lngT As Long
    Dim strT As String
    Dim strC As String
    Dim strNo As String
    
    clsBill.bytRegion = FHead
    clsBill.bytIndex = 3
    clsBill.SaveInput2Form
    '-----------------------------------
'    Dim strCode As String
'    Dim strName As String
'    lngID = BillPublic.FirstId(xTemplatE, C2lng(LblHead(2).Tag))
'    Call BillPublic.IdToCodeAndName(xTemplatE, lngID, strCode, strName)
'    LblHead(5 - 1).Tag = lngID
'    LblHead(5).Caption = strName
'    '-----------------------------------
    picFooter.Refresh



'    lngid = BillPublic.ReceiptNameToTypeID(cmbInput.Text)
'    Dim lngNewReceiptTypeID As Long
'    lngNewReceiptTypeID = lngid
'    If lngNewReceiptTypeID <> lngOldReceiptTypeID Then
'        '单据类型已经改变
'        If Not ChangeSaveNote() Then
'        '取消后将，进行还原操作
'            lngid = lngOldReceiptTypeID
'            lblHead(2).Tag = lngOldReceiptTypeID
'            lblHead(3).Caption = BillPublic.ReceiptTypeIdToName(lngOldReceiptTypeID)
'            getPrevPlateAndBillNo lngid, lngT, strNo
'            lblHead(4).Tag = lngT
'            Call BillPublic.IdToCodeAndName(xTemplatE, lngT, strC, strT)
'            lblHead(5).Caption = strT
'            clsBill.bytRegion = FFooter
'            cmbInput.Move -5000
'            lngNewReceiptTypeID = lngOldReceiptTypeID
'        Else
'            '调用苏梦的方法对当前操作员最后的模版ID，单据号前缀进行设置
'            getPrevPlateAndBillNo lngid, lngT, strNo
'            clsBill.GetANewBill lngT, lngid, strNo, True, C2Lng(lblHead(0).Tag)
'        End If
'    End If

End Sub

Private Sub cmbInput_GotFocus()
    lngOldReceiptTypeID = C2lng(lblHead(2).Tag)
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    clsBill.Form_key_Down KeyCode
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If clsBill Is Nothing Then Exit Sub
    If KeyCode = 93 Then
        If clsBill.bytRegion = FGrid Or clsBill.bytRegion = FGrid1 Or clsBill.bytRegion = FPicture Then
            GrdCol_Mouseup vbRightButton, 0, 0, 0
        Else
            Form_MouseUp vbRightButton, 0, 0, 0
        End If
        Exit Sub
    End If
    
    If Shift = 2 And KeyCode = 65 Then  'CTRL+A
        If Not ChangeSaveNote() Then Exit Sub
    ElseIf Shift = 2 And KeyCode = vbKeyPageDown Then
        cmdButton_Click 0
        Exit Sub
    ElseIf Shift = 2 And KeyCode = vbKeyPageUp Then
        cmdButton_Click 1
        Exit Sub
    ElseIf Shift = 2 And KeyCode = vbKeyReturn Then
        cmdButton_Click 4
        Exit Sub
    End If
    If KeyCode <> Asc(vbTab) Then
        clsBill.Form_KeyDown KeyCode, Shift
    End If

End Sub

Private Sub Form_Load()
'-----------------------------------
'    Me.Hide
'    Me.Move -30000
    If blnWriteForm = False Then MsgForm.PleaseWait
'-----------------------------------
    ReceiptTypeID = 13    '应付单ID
    
    If gclsSys Is Nothing Then Exit Sub
    
    Dim i As Integer
    ReDim strColRow(GrdCol.Cols - 1) As String  '单据体行复制/粘贴存储区
    
    Set clsBill = New BillSet
    clsBill.ReceiptTypeID = ReceiptTypeID
    Set clsBill.Form = Me
    clsBill.blnSound = GetSetting(App.title, "13" + gclsBase.OperatorID, "Sound_Payable", "False")
    clsBill.blnTell = GetSetting(App.title, "13" + gclsBase.OperatorID, "Tell_Payable", "False")
    
    Set mclsMainControl = gclsSys.MainControls.Add(Me)
    Set clsLst = New clsListMethod
    
    Me.HelpContextID = 60004
    blnNotResize = False
    FirstReceiptTypeIDAndName ReceiptTypeID, lgID, srName
    lblHead(2).Tag = lgID
    lblHead(3).Caption = srName
    clsBill.blnNotFormActive = True
    lngCancelActivityID = 0
    Utility.LoadFormSetting Me
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If clsBill Is Nothing Then Exit Sub
    If clsBill.blnGrdCellDoing Then Exit Sub
    clsBill.blnGrdCellDoing = True
    clsBill.Form_MouseUp
    If Button = vbRightButton Then
        MakeListEditMenu
        clsBill.blnNotRespondKeyPress = True
        PopupMenu frmMain.mnuListEdit
        clsBill.blnNotRespondKeyPress = False
    End If
    clsBill.blnGrdCellDoing = True
    DoEvents
    clsBill.blnGrdCellDoing = False

End Sub

'窗体尺寸变化处理程序
Private Sub Form_Resize()
    If clsBill Is Nothing Then Exit Sub
    If Not blnNotResize Then clsBill.Form_Resize
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    On Error Resume Next
    
    If (clsBill Is Nothing) Or (gclsSys Is Nothing) Or (mclsMainControl Is Nothing) Then
        Screen.MousePointer = vbDefault
        Unload MsgForm
        Unload Me
        Exit Sub
    End If

    If clsBill.blnNotRaiseEvent Then Exit Sub
    If clsBill.blnGrdCellDoing Then
        Cancel = 1
        Exit Sub
    End If
    clsBill.SaveInput2Form
    If Not ChangeSaveNote() Then
        gblnCancel = True
        Cancel = True
         Exit Sub
    End If
    '存贮最后的GRID的各列的宽度
    BillPublic.SaveColWidthDefault Me
    gclsSys.MainControls.Remove Me
    gclsSys.SendMessage Me.hWnd, 30 + C2lng(lblHead(2).Tag)
    frmPayableList.IAmCLosed
    Set clsBill = Nothing
    Set clsLst = Nothing        '确定凭证是否存在等的类模块
    Set mclsMainControl = Nothing      '主控对象
    Unload Me
    
End Sub

Private Sub chkPrint0_Click()
'    frmMain.mnuEditShowAll.Checked = chkPrint(0).Value
End Sub

Private Sub chkPrint1_Click()
    Dim intYN As Integer
    Dim lngWriteOffID() As Long
    
    If blnIsCanEventChk_Click = False Then GoTo EndProc
    If chkPrint(1).Value = 1 Then
        blnIsCanEventChk_Click = False
        chkPrint(1).Value = 0
        blnIsCanEventChk_Click = True
        If ActivityIsHX(clsBill.lngNowID, , True) Then
            If ShowMsg(Me.hWnd, "该张已经核销过的应付单保存后将不能取消作废！您确实要作废吗？", MB_YESNO + MB_DEFBUTTON2 + MB_ICONQUESTION + MB_SYSTEMMODAL, "警告信息") <> IDYES Then
                chkPrint(1).Value = 0
                GoTo EndProc
            End If
        Else
            If ShowMsg(Me.hWnd, "该张应付单保存后将不能取消作废！您确实要作废吗？", MB_YESNO + MB_DEFBUTTON2 + MB_ICONQUESTION + MB_SYSTEMMODAL, "警告信息") <> IDYES Then
                chkPrint(1).Value = 0
                GoTo EndProc
            End If
        End If
'-------- 冲销单据  作废
        If blnIsWriteOffBill(clsBill.lngNowID) Then
            If BillPublic.blnDelWriteOffBillNote(Me.hWnd, C2lng(lblHead(2).Tag), clsBill.lngNowID, "作废") = False Then
                chkPrint(1).Value = 0
                GoTo EndProc
            End If
        Else
            If BillPublic.blnWriteOff(Me.hWnd, C2lng(lblHead(2).Tag), clsBill.lngNowID, "作废", lngWriteOffID()) Then
                chkPrint(1).Value = 0
                GoTo EndProc
            End If
        End If
        blnIsCanEventChk_Click = False
        chkPrint(1).Value = 1
        blnIsCanEventChk_Click = True
    End If

    If chkPrint(1).Value = 0 Then
        Utility.RemoveFormResPicture (1024)
        cmdButton(7 + 1).Enabled = True
        If WanNeng Then
            tblReceipt.Buttons(ToolBarIndex(8, Me.Name)).Enabled = cmdButton(8).Enabled
        End If
        cmdButton(6 + 1).Enabled = True
        If WanNeng Then
            tblReceipt.Buttons(ToolBarIndex(7, Me.Name)).Enabled = cmdButton(7).Enabled
        End If
        RefreshRect Me.hWnd, GrdCol.Left + (GrdCol.width - 140 * Screen.TwipsPerPixelX) / 2, GrdCol.top + (GrdCol.Height + 1.5 * GrdCol.RowHeight(0) - 70 * Screen.TwipsPerPixelY) / 2, GrdCol.Left + (GrdCol.width - 140 * Screen.TwipsPerPixelX) / 2 + 140 * Screen.TwipsPerPixelX, GrdCol.top + (GrdCol.Height + 1.5 * GrdCol.RowHeight(0) - 70 * Screen.TwipsPerPixelY) / 2 + 70 * Screen.TwipsPerPixelY
    Else
        RefreshRect Me.hWnd, GrdCol.Left + (GrdCol.width - 140 * Screen.TwipsPerPixelX) / 2, GrdCol.top + (GrdCol.Height + 1.5 * GrdCol.RowHeight(0) - 70 * Screen.TwipsPerPixelY) / 2, GrdCol.Left + (GrdCol.width - 140 * Screen.TwipsPerPixelX) / 2 + 140 * Screen.TwipsPerPixelX, GrdCol.top + (GrdCol.Height + 1.5 * GrdCol.RowHeight(0) - 70 * Screen.TwipsPerPixelY) / 2 + 70 * Screen.TwipsPerPixelY
        cmdButton(7 + 1).Enabled = False
        If WanNeng Then
            tblReceipt.Buttons(ToolBarIndex(8, Me.Name)).Enabled = cmdButton(8).Enabled
        End If
        cmdButton(6 + 1).Enabled = False
        If WanNeng Then
            tblReceipt.Buttons(ToolBarIndex(7, Me.Name)).Enabled = cmdButton(7).Enabled
        End If
    End If
'    frmMain.mnuEditInActive.Checked = chkPrint(1).Value
EndProc:
    Erase lngWriteOffID
End Sub

Private Sub chkPrint_Click(Index As Integer)
    If clsBill Is Nothing Then Exit Sub
    clsBill.CHK_CLICK Index
'    If clsBill.blnMayChanged = False Then Exit Sub
    Select Case Index
        Case 0
            chkPrint0_Click
        Case 1
            chkPrint1_Click
    End Select
    clsBill.SetAFocus
End Sub

Private Sub cmdButton_Click(Index As Integer)
    If clsBill Is Nothing Then Exit Sub