frmpz_searchresult.frm

一个用VB写的财务软件源码

            mFg.ColAlignment(5) = 1
            Me.Show
        End If
    End With
    
End Sub


Public Sub ChangeTag(ByVal iRecordPos As Integer, ByVal sTag As String, _
            ByVal sCheckMan As String)
    Dim j As Long, FontColor As Long
    
    aryTag(iRecordPos) = sTag
    Select Case sTag
        Case "0"
            FontColor = vbBlack
        Case "1"
            FontColor = &H8000&
        Case "2"
            FontColor = vbGrayText
        Case "9"
            FontColor = vbRed
        Case Else
            FontColor = vbBlack
    End Select
    CGrid.SetRowForeColor iRecordPos, FontColor
    CGrid.SetCellText iRecordPos, 7, sCheckMan
    
End Sub

Public Function GetTag(ByVal iRecordPos As Integer) As String
    GetTag = aryTag(iRecordPos)
End Function

Public Function GetBillMan(ByVal iRecordPos As Integer) As String
    GetBillMan = CGrid.GetCellText(iRecordPos, 6)
End Function

Public Function GetCheckMan(ByVal iRecordPos As Integer) As String
    GetCheckMan = CGrid.GetCellText(iRecordPos, 7)
End Function

Private Sub frmV_Unload()
FillData , False
End Sub

Private Sub mFg_KeyPress(KeyAscii As Integer)
    Call mFg_DblClick
End Sub
'=====================================hangjh edit===================================
Private Sub mFg_DblClick()
    
    Dim bDisplayFrm As Boolean
    Dim VoucherMuster As Object '查询凭证外挂
    Dim iGlo As GlobalInterface.clsGlobal, iGlosys As GlobalInterface.clsGlobalSys
    Dim iKjqj As Integer, sPZZL As String, sPZBH As String
        If CGrid.row > 0 Then
'            Me.Hide

            Set iGlo = New GlobalInterface.clsGlobal
            Set iGlosys = New GlobalInterface.clsGlobalSys
            InitGloInface iGlo, iGlosys
            Set frmV = New frmVoucher
            Select Case Me.SearchResultFunction
                Case 1 '查询
                Set VoucherMuster = New AccountExtend.clsVoucherCollentionCx
                With VoucherMuster
                    .iGlo = iGlo
                    .iGlosys = iGlosys
                    FillKeyToList VoucherMuster '填关键字列表VoucherMuster
                    .Voucher = .Item(CGrid.row)  '当前凭证
                    .Index = CGrid.row
                    .Voucher.Load
                    
                    frmV.LoadObject = "AccountExtend.clsVoucherCollentionCx" '初始化凭证窗口的外挂对象
                    frmV.AllowAddinObject = True
                    Load frmV
                   
                    frmV.Show
                    frmV.HelpContextID = 202
                    frmV.LoadingObjects = VoucherMuster
                    frmV.Reload .Voucher
                    frmV.mnuVoucherNewclone.Enabled = False
                    frmV.mnuVoucherBounceback.Enabled = False
                   
                   ' frmV.cllVoucher.SetFixedRow 1, 1
                End With
                Case 2 '审核
                Set VoucherMuster = New AccountExtend.clsVoucherCollectionSh
                With VoucherMuster
                    
                    .iGlo = iGlo
                    .iGlosys = iGlosys
                    FillKeyToList VoucherMuster '填关键字列表VoucherMuster
                    .Voucher = .Item(CGrid.row)  '当前凭证
                    .Index = CGrid.row
                    .Voucher.Load
                    
                    frmV.LoadObject = "AccountExtend.clsVoucherCollectionSh" '初始化凭证窗口的外挂对象
                    Load frmV
                    frmV.HelpContextID = 203
                    frmV.Show
                    frmV.LoadingObjects = VoucherMuster
                    frmV.Reload .Voucher
                    frmV.lblStatus = .CheckVouState(.Voucher.sVoucherNumber, .Voucher.sVoucherType, .Voucher.iKjqj)
                    frmV.tbrSplit.Buttons("0l103").Enabled = False
                    frmV.tbrSplit.Buttons("0l104").Enabled = False
                    frmV.tbrSplit.Buttons("0l105").Enabled = False
                    Select Case frmV.lblStatus
                        Case "未审核": frmV.tbrSplit.Buttons("0l103").Enabled = True
                                       frmV.tbrSplit.Buttons("0l104").Enabled = True
                        Case "已审核": frmV.tbrSplit.Buttons("0l105").Enabled = True
                        Case "已记账":
                        Case "有错误": frmV.tbrSplit.Buttons("0l105").Enabled = True
                    End Select
                End With
                ' frmV.cllVoucher.SetFixedRow 1, 1
                Case 3 '更新
                 Set VoucherMuster = New AccountExtend.clsVoucherCollentionCx
                 With VoucherMuster
                    .iGlo = iGlo
                    .iGlosys = iGlosys
                    FillKeyToList VoucherMuster '填关键字列表VoucherMuster
                    .Voucher = .Item(CGrid.row)  '当前凭证
                    .Index = CGrid.row
                    .Voucher.Load
                    frmV.LoadObject = "AccountExtend.clsVoucherCollentionCx" '初始化凭证窗口的外挂对象
                    frmV.AllowAddinObject = True
                    Load frmV
                    frmV.HelpContextID = 204
                    frmV.Show
                    frmV.LoadingObjects = VoucherMuster
                    frmV.Reload .Voucher
                    frmV.cBr.Bands(2).Visible = False
                    frmV.mnuVoucher.Visible = False
                     frmV.cllVoucher.SetFixedRow 1, 1
                 End With
            End Select
'            Unload Me
        End If
End Sub
'填关键字到列表
Private Sub FillKeyToList(ByRef VoucherMuster As Object)
Dim i As Integer
Dim sPZBH As String, sPZZL As String, sKjqj As String
With CGrid
        For i = 1 To .Rows - 1
            sKjqj = CStr(.GetCellText(i, 4))
            sPZZL = CStr(.GetCellText(i, 2))
            sPZBH = CStr(.GetCellText(i, 3))
            VoucherMuster.Add sPZBH, sPZZL, Format(sKjqj, "yyyy-mm-dd")
        Next
End With
End Sub
'=================================edit end-================================
Private Sub mnuFileExit_Click()
    Unload Me
End Sub


Private Sub mnuFilePreview_Click()
On Error Resume Next
CGrid.PreviewGrid
    
End Sub

Private Sub mnuFilePrint_Click()
On Error Resume Next
    CGrid.PrintGrid
End Sub

Private Sub mnuOperateDelete_Click()
Dim Voucher As VoucherData.clsVoucher
Dim s As String
 Dim iGlo As GlobalInterface.clsGlobal, iGlosys As GlobalInterface.clsGlobalSys
   If Not m_Mutex.QueryObjectNotEnter(gloSys.sSubSysId, glo.sAccountID, "mnuPzUpdate", "mnuOperateDelete", "删除", Trim(mFg.TextMatrix(mFg.row, 2)) + Trim(mFg.TextMatrix(mFg.row, 3)) + Trim(mFg.TextMatrix(mFg.row, 1))) Then
      lID = m_Mutex.InsertObjectMutexID(gloSys.sSubSysId, glo.sAccountID, "mnuPzUpdate", "mnuOperateDelete", "删除", Trim(mFg.TextMatrix(mFg.row, 2)) + Trim(mFg.TextMatrix(mFg.row, 3)) + Trim(mFg.TextMatrix(mFg.row, 1)), glo.sUserID)
    If mFg.row > 0 Then
        If MsgBox("确实要删除这张凭证吗？", vbQuestion + vbYesNo) = vbYes Then
'--------------------changjh edit ----------------
            On Error GoTo Err_Exit
            glo.cnnMain.BeginTrans
            Set Voucher = New VoucherData.clsVoucher
            Set iGlo = New GlobalInterface.clsGlobal
            Set iGlosys = New GlobalInterface.clsGlobalSys
            InitGloInface iGlo, iGlosys
            Voucher.sVoucherType = mFg.TextMatrix(mFg.row, 2)
            Voucher.sVoucherDate = Format(glo.sOperateYear & "-" & mFg.TextMatrix(mFg.row, 1), "yyyy-mm")
            Voucher.sVoucherNumber = mFg.TextMatrix(mFg.row, 3)
            Voucher.iGlo = iGlo
            Voucher.iGlosys = iGlosys
            If Not Voucher.Load Then GoTo Err_Exit
            s = Voucher.IsEnabled
            If s <> "" Then
                MsgBox s, vbInformation, "提示"
                GoTo Err_Exit
            End If
            Voucher.Delete
            glo.cnnMain.CommitTrans
'--------------------edit end-----------------------
            If mFg.Rows = 2 Then
                mFg.Rows = 1
            Else
                mFg.RemoveItem mFg.row
            End If
        End If
    End If
    m_Mutex.DeleteObjectMutex gloSys.sSubSysId, glo.sAccountID, "mnuPzUpdate", "mnuOperateDelete", lID
End If
Set iGlo = Nothing
Set iGlosys = Nothing
Set Voucher = Nothing
Exit Sub
Err_Exit:
    Set iGlo = Nothing
    Set iGlosys = Nothing
    Set Voucher = Nothing
    glo.cnnMain.RollbackTrans
    m_Mutex.DeleteObjectMutex gloSys.sSubSysId, glo.sAccountID, "mnuPzUpdate", "mnuOperateDelete", lID
End Sub

Private Sub mnuOperateRenumber_Click()
   Dim rSt As New Recordset
   Dim s As String
   If Not m_Mutex.QueryObjectNotEnter(gloSys.sSubSysId, glo.sAccountID, "mnuPzUpdate", "mnuOperateRenumber", "改号", Trim(mFg.TextMatrix(mFg.row, 2)) + Trim(mFg.TextMatrix(mFg.row, 3)) + Trim(mFg.TextMatrix(mFg.row, 1))) Then
'      lID = m_Mutex.InsertObjectMutexID(gloSys.sSubSysID, glo.sAccountID, "mnuPzUpdate", "mnuOperateRenumber", "改号", Trim(mFg.TextMatrix(mFg.Row, 2)) + Trim(mFg.TextMatrix(mFg.Row, 3)) + Trim(mFg.TextMatrix(mFg.Row, 1)), glo.sUserID)
      With mFg
        If .row > 0 Then
            rSt.Open "select zdrmcode from tZW_pzsj" & glo.sOperateYear & _
                            " where kjqj=" & mFg.TextMatrix(mFg.row, 1) & " and pzzl='" & _
                            mFg.TextMatrix(mFg.row, 2) & "'" & _
                            " and pzbh='" & Trim(mFg.TextMatrix(mFg.row, 3)) & "'", glo.cnnMain, adOpenKeyset, adLockOptimistic
            If rSt.EOF = False Then
                s = rSt.Fields(0).value
            Else
                s = ""
            End If
            rSt.Close
            If s = glo.sUserID Then
                .col = 3
                '移动文本框
                txtEdit.Move .Left + .CellLeft, .Top + .CellTop, .cellWidth, .cellHeight
                txtEdit.Visible = True
                txtEdit.text = Format(.text, "0000")
                m_OldNumber = Format(.text, "0000")
                m_OldLong = .row
                '编辑文本框获得焦点
                txtEdit.SelStart = 0
                txtEdit.SelLength = Len(txtEdit.text)
                txtEdit.SetFocus
                '不允许使用其它控件
            Else
                MsgBox "非本人不能修改！", vbInformation, ""
            End If
        End If
    End With
  End If
End Sub

Private Sub tbr_ButtonClick(ByVal Button As MSComctlLib.Button)
    If txtEdit.Visible Then
        txtEdit.Visible = False
    End If
    Select Case Button.Key
        Case "Print"
            Call mnuFilePrint_Click
        Case "Preview"
            Call mnuFilePreview_Click
        Case "Renumber"
            Call mnuOperateRenumber_Click
        Case "Delete"
            Call mnuOperateDelete_Click
        Case "Quit"
            Call mnuFileExit_Click
    End Select
End Sub

Private Sub ReNumber(ByVal row As Integer)
    Dim sSQL As String
    Dim rSt As ADODB.Recordset
    Dim adoCmd As ADODB.Command
    Dim sTemp As String
    On Error GoTo errhandle
    '检查新编号的合法性
    txtEdit.text = Format(txtEdit.text, "0000")
    If Len(txtEdit.text) = 4 Then
        If m_OldNumber <> txtEdit.text Then
            sSQL = "select COUNT(*) from tZW_pzsj" & glo.sOperateYear & _
                " where kjqj=" & mFg.TextMatrix(row, 1) & " and pzzl='" & _
                mFg.TextMatrix(row, 2) & "'" & _
                " and pzbh='" & Trim(txtEdit.text) & "'"
            Set rSt = New ADODB.Recordset
            rSt.CursorLocation = adUseClient
            rSt.Open sSQL, glo.cnnMain, adOpenStatic, adLockReadOnly
            If rSt.Fields(0).value = 0 Then
                Dim lTemp As Long
                glo.cnnMain.BeginTrans
                glo.cnnMain.Execute "Update tZW_pzsj" & glo.sOperateYear & _
                        " set PZBH='" & Trim(txtEdit.text) & _
                        "' where kjqj=" & mFg.TextMatrix(row, 1) & " and pzzl='" & _
                        mFg.TextMatrix(row, 2) & "'" & _
                        " and pzbh='" & m_OldNumber & "'"
                glo.cnnMain.Execute "Update tYsyf_pzsj" & glo.sOperateYear & _
                        " set cPZcode='" & Trim(txtEdit.text) & _
                        "' where kjqj=" & mFg.TextMatrix(row, 1) & " and CKind='" & _
                        mFg.TextMatrix(row, 2) & "'" & _
                        " and cpzcode='" & m_OldNumber & "'"
                glo.cnnMain.Execute "Update tfz_xmbmpzsj" & glo.sOperateYear & _
                        " set PZBH='" & Trim(txtEdit.text) & _
                        "' where kjqj=" & mFg.TextMatrix(row, 1) & " and pzzl='" & _
                        mFg.TextMatrix(row, 2) & "'" & _
                        " and pzbh='" & m_OldNumber & "'"
                glo.cnnMain.CommitTrans
                MsgBox "成功改号！", vbInformation
                m_Mutex.DeleteObjectMutex gloSys.sSubSysId, glo.sAccountID, "mnuPzUpdate", "mnuOperateRenumber", lID
                mFg.TextMatrix(row, 3) = txtEdit.text
                txtEdit.Visible = False
                mFg.SetFocus
                '恢复其它控件可用
            Else
                MsgBox "凭证编号重复！", vbInformation
                txtEdit.SelStart = 0
                txtEdit.SelLength = Len(txtEdit.text)
            End If
            rSt.Close
        Else
            txtEdit.Visible = False
            mFg.SetFocus
            m_Mutex.DeleteObjectMutex gloSys.sSubSysId, glo.sAccountID, "mnuPzUpdate", "mnuOperateRenumber", lID
        End If
    Else
        MsgBox "凭证编号应为四位！", vbInformation
        txtEdit.text = Trim(txtEdit.text)
        txtEdit.SelStart = 0
        txtEdit.SelLength = Len(txtEdit.text)
    End If
    Exit Sub
errhandle:
    MsgBox "编号错误！", vbInformation
End Sub

Private Sub txtEdit_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    KeyAscii = 0
    ReNumber m_OldLong
    m_OldLong = 0
Else
    KeyAscii = IntegerEnabled(KeyAscii)
End If
End Sub

Private Sub txtEdit_LostFocus()
    If MsgBox("是否改号？", vbQuestion + vbYesNo, "询问") = vbYes Then
        ReNumber m_OldLong
    Else
        m_OldLong = 0
    End If
    txtEdit.Visible = False
    m_Mutex.DeleteObjectMutex gloSys.sSubSysId, glo.sAccountID, "mnuPzUpdate", "mnuOperateRenumber", lID
    'txtEdit.text = ""
End Sub

Public Property Get MutexID() As Long
MutexID = iID
End Property

Public Property Let MutexID(ByVal vNewValue As Long)
iID = vNewValue
End Property

Public Property Get MutexName() As String
MutexName = sFunctionName
End Property

Public Property Let MutexName(ByVal vNewValue As String)
sFunctionName = vNewValue
End Property

Public Sub uPreview()
mnuFilePreview_Click
End Sub

Public Sub uPrint()
mnuFilePrint_Click
End Sub