frmfixedmethodlistcard.frm

金算盘软件代码

    If Me.WindowState = 1 Then Me.WindowState = 0
    
    cmdOKCancel(2).Default = False
    cmdOKCancel(0).Default = True
    Show intModal
    
    If intModal <> vbModal Then
       Refresh
       ZOrder 0
    End If
End Sub

'查找出想修改的固资变动方式编码记录，存放在自定义类型变量中，设置想修改项
Private Sub SelectRecord(ByVal lngRecordID As Long)
    Dim strSql As String
    Dim recSetting As rdoResultset
    Dim lngID As Long
    
    With mfmrFixedMethod
        .lngFixedMethodID = lngRecordID
        strSql = "SELECT * FROM FixedMethod WHERE lngFixedMethodID=" & .lngFixedMethodID
        Set recSetting = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If recSetting.EOF Then
            mblnAddRecord = True
            InitAddCard
            recSetting.Close
            Exit Sub
        End If
        .strFixedMethodName = recSetting!strFixedMethodName
        .strFixedMethodCode = recSetting!strFixedMethodCode
        .blnIsInActive = recSetting!blnIsInActive
        .strFixedMethodType = recSetting!strFixedMethodType
        .lngAccountID = recSetting!lngAccountID
        .lngTemplateID = recSetting!lngTemplateID
        .lngVoucherTypeID = recSetting!lngVoucherTypeID
        .strRemark = recSetting!strRemark
        
        txtInput(0).Text = .strFixedMethodCode
        txtInput(1).Text = .strFixedMethodName
        If .blnIsInActive Then
            chkPause.Value = Checked
        Else
            chkPause.Value = Unchecked
        End If
        If .strFixedMethodType = "1" Then
            optType(0).Value = True
        Else
            optType(1).Value = True
        End If
        strSql = "SELECT lngAccountID FROM Account WHERE lngAccountID =" & .lngAccountID
        Set recSetting = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recSetting.EOF Then
          ' lstMethod(0).Text = recSetting!strAccountName
           lngID = recSetting!lngAccountID
           msetlistbox lstMethod(0), 0
           lstMethod(0).SeekCol = "1,2,3"
           lstMethod(0).SeekId lngID
        End If
        strSql = "SELECT lngTemplateID FROM Template  WHERE lngTemplateID=" & .lngTemplateID
        Set recSetting = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recSetting.EOF Then
           'lstMethod(1).Text = recSetting!strTemplateName
           lngID = recSetting!lngTemplateID
           msetlistbox lstMethod(1), 1
           lstMethod(1).SeekCol = "1,2"
           lstMethod(1).SeekId lngID
        End If
        strSql = "SELECT lngVoucherTypeID FROM VoucherType WHERE lngVoucherTypeID=" _
            & .lngVoucherTypeID
        Set recSetting = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If Not recSetting.EOF Then
               'lstMethod(2).Text = recSetting!strVoucherTypeName
               lngID = recSetting!lngVoucherTypeID
               msetlistbox lstMethod(2), 2
               lstMethod(2).SeekCol = "1,2,3"
               lstMethod(2).SeekId lngID
            End If
'        Strsql = "select * from remark where strRemarkCode='" & .strRemark & "'"
'        Set recSetting = gclsBase.BaseDB.OpenRecordset(Strsql, dbOpenSnapshot)
'        If Not recSetting.EOF Then
'           lngID = recSetting!lngRemarkID
           msetlistbox lstMethod(3), 3
'           lstMethod(3).SeekCol = "1,2,3"
'           lstMethod(3).SeekId lngID
'        Else
'           lstMethod(3).Text = ""
'        End If
        lstMethod(3).Text = .strRemark
        mtext = .strRemark
        InitBuffer '清空暂时存储数据库操作的数组
        txtInput(0).SelStart = 0
        txtInput(0).SelLength = strLen(txtInput(0).Text)
'        txtInput(0).SetFocus
        
        recSetting.Close
    End With
End Sub

'进入删除固资变动方式，判断记录是否是末级和被使用，删除记录
Public Function DelCard(ByVal lngID As Long) As Boolean
    Dim strSql As String
    Dim recSelect As rdoResultset
    Dim intMsgReturn As Integer
    Dim blnSQLExec As Boolean

    DelCard = False
    strSql = "SELECT * FROM FixedMethod WHERE lngFixedMethodID=" & lngID
    Set recSelect = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recSelect.EOF Then
        recSelect.Close
        Exit Function
    End If
    If frmFixedTypeList.IsShowCard(1) Then
       If lngID = frmFixedMethodListCard.FixedMethodID Then
          ShowMsg 0, "不能删除正在修改的固资变动方式！", _
                     vbExclamation + MB_TASKMODAL, "删除固资变动方式"
          frmFixedMethodListCard.Show
          Exit Function
       End If
    End If
    If CodeUsed(lngID) Then
        intMsgReturn = ShowMsg(0, "“" & recSelect!strFixedMethodName & "”固资变动方式已经有业务发生，不能删除！", _
            vbExclamation + MB_TASKMODAL, "删除固资变动方式")
    Else
        intMsgReturn = ShowMsg(0, "你确实要删除" & recSelect!strFixedMethodName & "固资变动方式吗？", _
            vbQuestion + vbYesNo + MB_TASKMODAL, "删除固资变动方式")
        If intMsgReturn = vbYes Then
            strSql = "DELETE FROM FixedMethod  WHERE lngFixedMethodID = " & lngID
            blnSQLExec = gclsBase.ExecSQL(strSql)
            If blnSQLExec Then
              ' gclsSys.SendMessage CStr(Me.hwnd), Message.msgFixedMethod
            End If
        End If
    End If
    DelCard = blnSQLExec
    'frmFixedMethodList.IsShowCard = False
    recSelect.Close
End Function

'判断记录是否被使用（可能有多张表会使用此编码）
Private Function CodeUsed(lngID As Long) As Boolean
    CodeUsed = True
    If CheckIDUsed("FixedAlter", "lngFixedMethodID", lngID) Then Exit Function
    CodeUsed = False
End Function


Private Sub chkPause_Click()
    mblnIsChanged = True
End Sub

Private Sub cmdOKCancel_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    If Index = 1 Then mblnIsCancel = True
End Sub

Private Sub Form_Activate()
    gclsSys.CurrFormName = Me.hwnd
    frmMain.mnuEditShowList.Enabled = True
End Sub

Private Sub Form_Load()
    On Error GoTo ErrHandle
    SetHelpID Me.hwnd, 30049
    
'    Set cmdOKCancel(0).Picture = LoadResPicture(1001, vbResBitmap)
'    Set cmdOKCancel(1).Picture = LoadResPicture(1002, vbResBitmap)
'    Set cmdOKCancel(2).Picture = LoadResPicture(1009, vbResBitmap)
    Set mclsMainControl = gclsSys.MainControls.Add(Me)
    
    frmFixedTypeList.IsShowCard(1) = True
    Exit Sub
    Dim edtErrReturn As ErrDealType
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload Me
    End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Dim intMsgReturn As Integer

    If UnloadMode = vbFormControlMenu Then
       If mblnIsChanged = True Then
          intMsgReturn = ShowMsg(0, "当前固资变动方式已被修改，是否保存？", _
                 vbQuestion + vbYesNoCancel + MB_TASKMODAL, Me.Caption)
          If intMsgReturn = vbYes Then
             Cancel = Not SaveCard(True)
          ElseIf intMsgReturn = vbCancel Then
             Cancel = True
          End If
       End If
    End If
    If Not Cancel Then mblnIsChanged = False
End Sub

Private Sub Form_Resize()
    If Me.Left + Me.Width < 0 Or Me.Left > Screen.Width Then
       Me.Left = 300
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    If FrmNewTemplate Is Nothing Then
    'If FrmNewTemplate.Visible = True Then
       Unload FrmNewTemplate
    End If
    mblnIsCancel = False
    frmFixedTypeList.IsShowCard(1) = False
    gclsSys.CurrFormName = ""
    gclsSys.MainControls.Remove Me
    Set mclsMainControl = Nothing
End Sub

Private Sub Form_Paint()
    FrameBox Me.hwnd, 90, 90, 4395, 3285 '画边框
    FrameBox Me.hwnd, 240, 2490, 4185, 3105
End Sub

Private Sub lstMethod_AddNew(Index As Integer)
          '  lstMethod(Index).Text = mstrListTextBuffer(Index)
            mblnIsEditAdd = True
            Select Case Index
                Case 0
                   mlngListIDBuffer(Index) = Card.AddCard(Message.msgAccount) ', mstrListTextBuffer(Index))
                Case 1
                   mlngListIDBuffer(Index) = FrmNewTemplate.AddCard(, , 17, 41)
                Case 2
                   mlngListIDBuffer(Index) = Card.AddCard(Message.msgVoucherType) ', mstrListTextBuffer(Index))
                Case 3
                   mlngListIDBuffer(Index) = Card.AddCard(Message.msgRemark) ', mstrListTextBuffer(Index))
            End Select
            msetlistbox lstMethod(Index), Index
            lstMethod(Index).SeekId mlngListIDBuffer(Index)
End Sub



Private Sub lstMethod_Delete(Index As Integer)
            Dim blnDel As Boolean
            
            Select Case Index
                Case 0
                    blnDel = Card.DelCard(Message.msgAccount, mlngListIDBuffer(Index))
                Case 1
                    blnDel = Card.DelCard(Message.msgTemplate, mlngListIDBuffer(Index))
                Case 2
                    blnDel = Card.DelCard(Message.msgVoucherType, mlngListIDBuffer(Index))
                Case 3
                    If lstMethod(3).ID <> 0 Then
                       blnDel = Card.DelCard(Message.msgRemark, mlngListIDBuffer(Index))
                    Else
                       lstMethod(3).Text = mtext
                       Exit Sub
                    End If
            End Select
            If blnDel = True Then
               msetlistbox lstMethod(Index), Index
            Else
               lstMethod(Index).SeekId mlngListIDBuffer(Index)
            End If
End Sub

Private Sub lstMethod_Edit(Index As Integer)
     mblnIsEditAdd = True
     lstMethod(Index).SeekId mlngListIDBuffer(Index)
     If Index <> 3 Then
        If mlngListIDBuffer(Index) = 0 Then
           lstMethod(Index).Text = ""
           ShowMsg 0, "当前没有记录，不能修改！", vbExclamation + MB_TASKMODAL, Me.Caption
           lstMethod(Index).SetFocus
           Exit Sub
        End If
     End If
     Select Case Index
        Case 0
            Card.EditCard Message.msgAccount, mlngListIDBuffer(Index)
        Case 1
            Card.EditCard Message.msgTemplate, mlngListIDBuffer(Index), , 41
        Case 2
            Card.EditCard Message.msgVoucherType, mlngListIDBuffer(Index)
        Case 3
            If lstMethod(3).ID <> 0 Then
               Card.EditCard Message.msgRemark, mlngListIDBuffer(Index)
            Else
               lstMethod(3).Text = mtext
               Exit Sub
            End If
     End Select
     msetlistbox lstMethod(Index), Index
     lstMethod(Index).SeekId mlngListIDBuffer(Index)
End Sub

'当第一次进入列表框时，设置它的选项
Private Sub lstMethod_GotFocus(Index As Integer)
  cmdOKCancel(0).Default = False
  cmdOKCancel(2).Default = False
'  If Index = 3 Then Exit Sub
  If lstMethod(Index).Referrows <= 1 Then
       msetlistbox lstMethod(Index), Index
  End If
End Sub

'设置列表框选项
Private Sub msetlistbox(lstSetting As ListText, Index As Integer)
    Dim strSql As String

    With mfmrFixedMethod
        Select Case Index
            Case 0
                setlistbox lstSetting, 0  ', .lngAccountID
                lstSetting.SeekCol = "1,2,3"
            Case 1
                setlistbox lstSetting, 12   ', .lngTemplateID
                lstSetting.SeekCol = "1,2"
            Case 2
                setlistbox lstSetting, 13  ', .lngVoucherTypeID
                lstSetting.SeekCol = "1,2,3"
            Case 3
                setlistbox lstSetting, 14
                lstSetting.SeekCol = "1,2,3"
               ' lstMethod(3).Text = .strRemark
        End Select
    End With
End Sub

Private Sub InputAgain()
    txtInput(0).SelStart = 0
    txtInput(0).SelLength = strLen(txtInput(0).Text)
    txtInput(0).SetFocus
End Sub

'根据列表框选择结果来调用卡片或存储调用卡片的参数
Private Sub lstMethod_Choose(Index As Integer)
       mlngListIDBuffer(Index) = lstMethod(Index).ID
End Sub

'根据列表框输入信息来调用卡片
Private Sub lstMethod_ItemNotExist(Index As Integer)
    Dim intMsgReturn As Integer
    Dim strSql As String
    Dim blnSQLExec As Boolean

    If mblnIsCancel = True Then Exit Sub
    Select Case Index
        Case 0
            intMsgReturn = frmMsgAdd.MsgAddShow("对应科目不存在", "科目列表中没有“" _
                & lstMethod(Index).Text & "”！")
        Case 1
             intMsgReturn = frmMsgAdd.MsgAddShow("凭证模版不存在", "凭证模版列表中没有“" _
                & lstMethod(Index).Text & "”！")
        Case 2
            intMsgReturn = frmMsgAdd.MsgAddShow("凭证类型不存在", "凭证类型列表中没有“" _
                & lstMethod(Index).Text & "”！")
        Case 3
            
            'intMsgReturn = frmMsgAdd.MsgAddShow("凭证摘要不存在", "摘要列表中没有“" _
                & lstMethod(Index).Text & "”！")
    End Select
    Select Case intMsgReturn
        Case vbOK
            mstrListTextBuffer(Index) = lstMethod(Index).Text
            Select Case Index
                Case 0
                    mlngListIDBuffer(Index) = Card.AddCard(Message.msgAccount, mstrListTextBuffer(Index))
                Case 1
                   mlngListIDBuffer(Index) = FrmNewTemplate.AddCard(mstrListTextBuffer(Index), vbModal, 17, 41)
                Case 2
                   mlngListIDBuffer(Index) = Card.AddCard(Message.msgVoucherType, mstrListTextBuffer(Index))
                Case 3
                   mlngListIDBuffer(Index) = Card.AddCard(Message.msgRemark, mstrListTextBuffer(Index))
            End Select
            msetlistbox lstMethod(Index), Index
            lstMethod(Index).SeekId mlngListIDBuffer(Index)
            'lstMethod(Index).Text = mstrListTextBuffer(Index)
        Case vbCancel
            lstMethod(Index).SelStart = 0