frmcreatestdvoucher.frm

金算盘软件代码

VERSION 5.00
Begin VB.Form frmCreateStdVoucher 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "生成样板凭证"
   ClientHeight    =   1650
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5730
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1650
   ScaleWidth      =   5730
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton cmdButton 
      Cancel          =   -1  'True
      Height          =   345
      Index           =   1
      Left            =   4410
      Style           =   1  'Graphical
      TabIndex        =   3
      Top             =   570
      Width           =   1185
   End
   Begin VB.CommandButton cmdButton 
      Height          =   375
      Index           =   0
      Left            =   4410
      Style           =   1  'Graphical
      TabIndex        =   2
      Top             =   150
      Width           =   1185
   End
   Begin VB.Frame famVoucher 
      Caption         =   "样板凭证"
      Height          =   1425
      Left            =   60
      TabIndex        =   4
      Top             =   60
      Width           =   4215
      Begin VB.TextBox txtInput 
         Height          =   345
         Index           =   1
         Left            =   840
         MaxLength       =   30
         TabIndex        =   1
         Top             =   840
         Width           =   3225
      End
      Begin VB.TextBox txtInput 
         Height          =   345
         Index           =   0
         Left            =   840
         MaxLength       =   10
         TabIndex        =   0
         Top             =   300
         Width           =   3225
      End
      Begin VB.Label lblNote 
         Caption         =   "名称(&N)"
         Height          =   195
         Index           =   1
         Left            =   150
         TabIndex        =   6
         Top             =   900
         Width           =   645
      End
      Begin VB.Label lblNote 
         Caption         =   "编号(&C)"
         Height          =   195
         Index           =   0
         Left            =   150
         TabIndex        =   5
         Top             =   390
         Width           =   645
      End
   End
End
Attribute VB_Name = "frmCreateStdVoucher"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'   WXY
'   1999-08-19
'   Create StdVoucher Form
Private frm As Form
Private lngstdVoucherID As Long
Private blnSaved As Boolean

'//////////////////////////////////////////////////////////////////////////////////
'                                                                                 /
'                               接         口                                     /
'                                                                                 /
'//////////////////////////////////////////////////////////////////////////////////
'入口：  凭证窗体
'出口：  如果成功 则返回样板凭证的ID号，否则返回为0
Public Function CreateVoucher(ByVal frmName As Form) As Long
    
    Set frm = frmName
    
    If frm.grdCol.Rows < 3 Then
        ShowMsg Me.hwnd, "当前凭证至少要定义一个借方科目和一个贷方科目，请重新定义当前凭证！", MB_SYSTEMMODAL + MB_ICONINFORMATION, "提示信息"
        CreateVoucher = 0
        Exit Function
    End If
    Me.Show vbModal
    
    CreateVoucher = lngstdVoucherID
    
End Function

'//////////////////////////////////////////////////////////////////////////////////
Private Sub cmdButton_Click(index As Integer)
    Select Case index
    Case 0      '确定
        If SaveStdVoucher = False Then Exit Sub
    Case 1      '取消
        lngstdVoucherID = 0
        blnSaved = True
    End Select
    Unload Me
End Sub

Private Function SaveStdVoucher() As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    Dim intRow As Integer
    Dim blnFound As Boolean
    Dim lngVoucherTmpID As Long
    
    On Error GoTo Err_Handle
    
    If DataValid = False Then Exit Function
    
    gclsBase.BaseWorkSpace.BeginTrans
    
    '先存贮凭证头
    strSql = "SELECT * FROM StdVoucher WHERE strVoucherNO = '" & Trim(txtInput(0)) & "'"
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
    With recTmp
        If .BOF And .EOF Then
            .AddNew
            lngstdVoucherID = GetNewID("stdVoucher")
            !lngVoucherID = lngstdVoucherID                       '
        Else
            .Edit
            lngstdVoucherID = !lngVoucherID
        End If
        !lngVoucherTypeID = frm.getFieldID(0)                   '凭证类型ID
        !strVoucherNo = Trim(txtInput(0))                       '样板凭证编码
        !strVoucherName = Trim(txtInput(1))                     '样板凭证名称
        !lngTemplateID = C2lng(frm.lblHead(2).Tag)              '模板ID
        !intNumber = CInt(Val(Left(frm.lblField(3).Caption, 4))) '附单数
        .Update
        .Close
    End With
    '再存贮凭证体
    strSql = "SELECT * FROM StdVoucherDetail"
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
    
    If frm.grdCol.Rows >= 2 Then
        With recTmp
            If Not (.BOF And .EOF) Then
                .MoveLast
                .MoveFirst
            End If
            For intRow = 1 To frm.grdCol.Rows - 1
                If blnNotNullRow(intRow) Then
                    If Not (.BOF And .EOF) Then .MoveFirst
                    blnFound = False
'                    .FindFirst "lngVoucherDetailID = " & C2lng(frm.grdCol.TextMatrix(intRow, 0))
                    Do While Not .EOF
                        If !lngVoucherDetailID = C2lng(frm.grdCol.TextMatrix(intRow, 0)) Then
                            blnFound = True
                            Exit Do
                        End If
                        .MoveNext
                    Loop
                    If blnFound = False Then
                        .AddNew
                        !lngVoucherDetailID = GetNewID("stdVoucherDetail")
                    Else
                        .Edit
                    End If
                    !lngVoucherID = lngstdVoucherID                                             '样板凭证ID
                    !lngRowID = intRow                                                          '行号
                    !strRemark = IIf(frm.grdCol.TextMatrix(intRow, 1) = "", " ", frm.grdCol.TextMatrix(intRow, 1)) '摘要
                    !lngAccountID = C2lng(frm.grdCol.TextMatrix(intRow, 16))                    '科目ID
                    !intDirection = IIf(C2Dbl(frm.grdCol.TextMatrix(intRow, 26)) = 0, -1, 1)    '借贷方向
                    !lngCurrencyID = C2lng(frm.grdCol.TextMatrix(intRow, 17))                   '币种ID
                    !lngClassID1 = C2lng(frm.grdCol.TextMatrix(intRow, 22))                     '统计ID
                    !lngClassID2 = C2lng(frm.grdCol.TextMatrix(intRow, 23))                     '项目ID
                    !lngCustomerID = C2lng(frm.grdCol.TextMatrix(intRow, 18))                   '单位ID
                    !lngDepartmentID = C2lng(frm.grdCol.TextMatrix(intRow, 19))                 '部门ID
                    !lngEmployeeID = C2lng(frm.grdCol.TextMatrix(intRow, 20))                   '职员ID
                    !lngPaymentMethodID = C2lng(frm.grdCol.TextMatrix(intRow, 30))              '付款方法ID
                    !strCheckNumber = IIf(frm.grdCol.TextMatrix(intRow, 28) = "", " ", frm.grdCol.TextMatrix(intRow, 28)) '票据号
                    .Update
                End If
            Next intRow
        End With
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveStdVoucher = True
    blnSaved = True
EndProc:
    Set recTmp = Nothing
    Exit Function
Err_Handle:
    gclsBase.BaseWorkSpace.RollBacktrans
    GoTo EndProc
End Function

'确定是否是空行
Private Function blnNotNullRow(ByVal lngRow As Long) As Boolean
    blnNotNullRow = False
    
    If frm.Visible Then
        If frm.grdCol.TextMatrix(lngRow, 2) <> "" And C2lng(frm.grdCol.TextMatrix(lngRow, 16)) > 0 Then
            blnNotNullRow = True
            Exit Function
        End If
    Else
        If C2lng(frm.grdCol.TextMatrix(lngRow, 16)) > 0 Then
            blnNotNullRow = True
            Exit Function
        End If
    End If
End Function

Private Function DataValid() As Boolean
    Dim strSql  As String
    Dim recTmp As rdoResultset
    Dim intResult As Integer
    
    If Trim(txtInput(0)) = "" Then
        ShowMsg Me.hwnd, "编号不能为空！", MB_SYSTEMMODAL + MB_ICONEXCLAMATION, "警告信息"
        txtInput(0).SetFocus
        Exit Function
    End If
    If Trim(txtInput(1)) = "" Then
        ShowMsg Me.hwnd, "名称不能为空！", MB_SYSTEMMODAL + MB_ICONEXCLAMATION, "警告信息"
        txtInput(1).SetFocus
        Exit Function
    End If
    
    strSql = "SELECT strVoucherNO FROM StdVoucher WHERE strVoucherNO = '" & Trim(txtInput(0)) & "'"
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If Not (recTmp.BOF And recTmp.EOF) Then
        intResult = ShowMsg(Me.hwnd, "您所录入的编号已经重复，要替换原来这个编号对应的样板凭证吗？", _
                            MB_SYSTEMMODAL + MB_ICONQUESTION + vbYesNoCancel, "警告信息")
        If intResult = vbYes Then
            DataValid = True
        ElseIf intResult = vbNo Then
            blnSaved = True
            Unload Me
        Else
            DataValid = False
            txtInput(0).SetFocus
        End If
        Exit Function
    End If
    DataValid = True
End Function

Private Sub Form_Load()
    Set Me.Icon = Utility.GetFormResPicture(139, vbResIcon)
    Me.top = (Screen.Height - Me.Height) / 2
    Me.Left = (Screen.width - Me.width) / 2
    
    cmdButton(0).Picture = Utility.GetFormResPicture(1001, 0)
    cmdButton(1).Picture = Utility.GetFormResPicture(1002, 0)
    
    blnSaved = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim intResult As Integer
    
    If (Trim(txtInput(0)) <> "" Or Trim(txtInput(1)) <> "") And blnSaved = False Then
        intResult = ShowMsg(Me.hwnd, "样板凭证“" & txtInput(0) & "  " & txtInput(1) & "”还没有保存，要保存当前录入的数据吗？", MB_SYSTEMMODAL + MB_ICONQUESTION + MB_YESNOCANCEL, "提示信息")
        If intResult = vbYes Then
            If SaveStdVoucher = False Then
                Cancel = 1
                Exit Sub
            End If
        ElseIf intResult = vbCancel Then
            Cancel = 1
            Exit Sub
        End If
    End If
    Utility.RemoveFormResPicture 1022
    Utility.RemoveFormResPicture 1010
    Utility.RemoveFormResPicture (139)
End Sub

Private Sub txtInput_KeyPress(index As Integer, KeyAscii As Integer)
    If KeyAscii = 13 Then
        Select Case index
        Case 0      '进入“名称录入框”
            txtInput(1).SetFocus
        Case 1      '进入“确定”按钮
            cmdButton(0).SetFocus
        End Select
    End If
End Sub