budgetsetcard1.frm

金算盘软件代码

        & IIf(chkBudgetObject(2).Value = 1, 1, 0) & ",blnIsSaleAmount=" _
        & IIf(chkBudgetObject(3).Value = 1, 1, 0) & ",blnIsSaleCost=" _
        & IIf(chkBudgetObject(4).Value = 1, 1, 0) & ",blnIsSaleProfit=" _
        & IIf(chkBudgetObject(5).Value = 1, 1, 0) & ",blnIsStockQuantity=" _
        & IIf(chkBudgetObject(6).Value = 1, 1, 0) & ",blnIsStockAmount=" _
        & IIf(chkBudgetObject(7).Value = 1, 1, 0) & ",blnIsBorrowQuantity=" _
        & IIf(chkBudgetObject(8).Value = 1, 1, 0) & ",blnIsBorrowAmount=" _
        & IIf(chkBudgetObject(9).Value = 1, 1, 0) & ",blnIsLendQuantity=" _
        & IIf(chkBudgetObject(10).Value = 1, 1, 0) & ",blnIsLendAmount=" _
        & IIf(chkBudgetObject(11).Value = 1, 1, 0) & ",blnIsStageQuantity=" _
        & IIf(chkBudgetObject(12).Value = 1, 1, 0) & ",blnIsStageAmount=" _
        & IIf(chkBudgetObject(13).Value = 1, 1, 0) & ",blnIsEntrustQuantity=" _
        & IIf(chkBudgetObject(14).Value = 1, 1, 0) & ",blnIsEntrustAmount=" _
        & IIf(chkBudgetObject(15).Value = 1, 1, 0) & ",blnIsUseQuantity="
    strSql = strSql & IIf(chkBudgetObject(16).Value = 1, 1, 0) & ",blnIsUseAmount=" _
        & IIf(chkBudgetObject(17).Value = 1, 1, 0) & ",blnIsReceiveQuantity=" _
        & IIf(chkBudgetObject(18).Value = 1, 1, 0) & ",blnIsReceiveAmount=" _
        & IIf(chkBudgetObject(19).Value = 1, 1, 0) & ",blnIsPayQuantity=" _
        & IIf(chkBudgetObject(20).Value = 1, 1, 0) & ",blnIsPayAmount=" _
        & IIf(chkBudgetObject(21).Value = 1, 1, 0) & ",blnIsPOQuantity=" _
        & IIf(chkBudgetObject(22).Value = 1, 1, 0) & ",blnIsPOAmount=" _
        & IIf(chkBudgetObject(23).Value = 1, 1, 0) & ",blnIsSOQuantity=" _
        & IIf(chkBudgetObject(24).Value = 1, 1, 0) & ",blnIsSOAmount=" _
        & IIf(chkBudgetObject(25).Value = 1, 1, 0) _
        & " WHERE lngBudgetID=" & mlngID
    On Error GoTo errhandel:
    gclsBase.BaseWorkSpace.BeginTrans
    If strSql1 <> "" Then gclsBase.BaseDB.Execute strSql1
    If strSql <> "" Then gclsBase.BaseDB.Execute strSql
    gclsBase.BaseWorkSpace.CommitTrans
    '发出预算方案消息
    gclsSys.SendMessage CStr(Me.hwnd), Message.msgBudgetPlan
    UpdateBudget = True
    mblnSuccess = True
    Exit Function
errhandel:
    Select Case Err.Number
        Case 3022
            If Visible Then ShowMsg Me.hwnd, "计划预算名称已经存在，修改失败！", vbOKOnly + vbCritical, Me.Caption
        Case Else
            If Visible Then ShowMsg Me.hwnd, "修改计划预算失败！", vbOKOnly + vbCritical, Me.Caption
    End Select
    gclsBase.BaseWorkSpace.RollBacktrans
    UpdateBudget = False
    Exit Function
End Function

'保存计划预算
Private Function SaveBudget(lngID As Long) As Boolean
    Dim strSql As String
    Dim recTemp As rdoResultset
    Dim intCount As Integer
    Dim blnTmp As Boolean
    
    If tedBudget.Text = "" Then
        If Visible Then ShowMsg Me.hwnd, "预算名称不能为空！", vbOKOnly + vbInformation, Me.Caption
        SaveBudget = False
        Exit Function
    Else
        If ContainErrorChar(tedBudget.Text) Then
            If Visible Then ShowMsg Me.hwnd, "预算名称含有非法字符，请重新输入！", vbOKOnly + vbInformation, Me.Caption
            SaveBudget = False
            Exit Function
        End If
    End If
    blnTmp = False
    For intCount = 0 To 10
        If intCount <> 7 And chkBudgetitem(intCount) = 1 Then
            blnTmp = True
            Exit For
        End If
    Next
    If Not blnTmp Then
        If Visible Then ShowMsg Me.hwnd, "预算项目中至少要选择一项！", vbInformation, Me.Caption
        SaveBudget = False
        Exit Function
    End If
    For intCount = 0 To 25
        If chkBudgetObject(intCount) = 1 Then Exit For
    Next
    If intCount > 25 Then
        If Visible Then ShowMsg Me.hwnd, "预算对象中至少要选择一项！", vbInformation, Me.Caption
        SaveBudget = False
        Exit Function
    End If
    If lngID = 0 Then   '新增
        If InsertBudget() Then
            strSql = "SELECT lngBudgetID FROM Budget WHERE strBudgetName='" & tedBudget.Text & "'"
            Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If Not recTemp.EOF Then
                lngID = recTemp("lngBudgetID")
                SaveBudget = True
            Else
                lngID = 0
                SaveBudget = False
            End If
            recTemp.Close
        Else
            lngID = 0
            SaveBudget = False
        End If
    Else     '修改
        SaveBudget = UpdateBudget()
    End If
End Function

Public Function DelCard(hwnd As Long, lngID As Long, ByRef lngYesNo As Long) As Boolean
    Dim strSql As String
    Dim recTemp As rdoResultset
    Dim lngResult As Long
    Dim strBudgetName As String
    
    On Error GoTo errhandel:
    If lngID > 0 Then
        strSql = "SELECT strBudgetName FROM Budget WHERE lngBudgetID=" & lngID
        Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recTemp.EOF Then
            strBudgetName = recTemp("strBudgetName")
            lngResult = ShowMsg(hwnd, "你确实要删除预算方案“" & strBudgetName & "”吗？", _
                vbYesNo + vbDefaultButton2 + vbQuestion, "删除计划预算")
            lngYesNo = lngResult
            If lngResult = vbYes Then
                strSql = "SELECT lngBudgetID FROM BudgetBalance WHERE lngBudgetID=" & lngID
                Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                If recTemp.EOF Then
                    strSql = "DELETE  FROM Budget WHERE lngBudgetID=" & lngID
                    gclsBase.BaseDB.Execute strSql
                    '发出预算方案消息
                    gclsSys.SendMessage CStr(Me.hwnd), Message.msgBudgetPlan
                    DelCard = True
                Else
                    ShowMsg hwnd, "“" & strBudgetName & "”正在使用，不能删除！", vbInformation, "删除计划预算"
                End If
            End If
        Else
            DelCard = True
        End If
    End If
    Exit Function
errhandel:
    ShowMsg Me.hwnd, "数据库错误，删除失败！", vbCritical, "删除计划预算"
    DelCard = False
End Function

Private Sub cboBudget_Click()
    mblnChanged = True
End Sub

Private Sub chkBudgetItem_Click(Index As Integer)
    mblnChanged = True
    If Index = 0 Then UpdateQuantity
End Sub

Private Sub chkBudgetObject_Click(Index As Integer)
    Dim intNum As Integer
    
    intNum = GetNum
    If intNum > 3 Then
        ShowMsg Me.hwnd, "最多只能同时选择三个预算对象！", vbInformation, Me.Caption
        chkBudgetObject(Index).Value = 0
    Else
        mblnChanged = True
    End If
End Sub

Private Sub cmdBudget_Click(Index As Integer)
    Select Case Index
        Case 0      '确认
            If mblnChanged Then
                If SaveBudget(mlngID) Then
                    mblnChanged = False
                    Unload Me
                Else
                    tedBudget.SetFocus
                End If
            Else
                Unload Me
            End If
        Case 1      '取消
            mblnChanged = False
            Unload Me
        Case 2      '新增
            If mblnChanged Then
                If SaveBudget(mlngID) Then
                    mlngID = 0
                    mblnChanged = False
                    tedBudget.Text = ""
                    tedBudget.SetFocus
                Else
                    tedBudget.SetFocus
                End If
            End If
    End Select
End Sub

Private Sub Form_Activate()
    SetHelpID HelpContextID
    frmMain.SetEditUnEnabled
End Sub

Private Sub Form_Load()
    Set Me.Icon = GetFormResPicture(139, vbResIcon)
    Set cmdBudget(0).Picture = GetFormResPicture(1001, vbResBitmap)
    Set cmdBudget(1).Picture = GetFormResPicture(1002, vbResBitmap)
    Set cmdBudget(2).Picture = GetFormResPicture(1009, vbResBitmap)
    UpdateQuantity
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = 27 Then
        cmdBudget_Click 1
    End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Dim lngResult As Long
    
    If UnloadMode = vbFormControlMenu Then
        If mblnChanged Then
            lngResult = ShowMsg(Me.hwnd, "是否保存当前计划预算？", vbYesNoCancel + vbQuestion, Me.Caption)
            Select Case lngResult
                Case vbYes
                    If Not SaveBudget(mlngID) Then
                        tedBudget.SetFocus
                        Cancel = True
                    End If
                Case vbCancel
                    Cancel = True
            End Select
        End If
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Utility.RemoveFormResPicture 139
    Utility.RemoveFormResPicture 1001
    Utility.RemoveFormResPicture 1002
    Utility.RemoveFormResPicture 1009
End Sub

Private Sub tedBudget_Change()
    If ContainErrorChar(tedBudget.Text) Then
        SendKeys "{BACKSPACE}"
    Else
        mblnChanged = True
    End If
End Sub

'更新数量选择状态
Private Sub UpdateQuantity()
    Dim intCount As Integer
    
    For intCount = 0 To 12
        If chkBudgetitem(0).Value = 1 Then
            If intCount <> 2 Then
                chkBudgetObject(intCount * 2).Enabled = True
            End If
        Else
            If intCount <> 2 Then
                chkBudgetObject(intCount * 2).Value = 0
                chkBudgetObject(intCount * 2).Enabled = False
            End If
        End If
    Next
End Sub

'得到已选预算对象数量
Private Function GetNum() As Integer
    Dim intCount As Integer
    Dim intNum As Integer
    
    For intCount = 0 To 25
        If chkBudgetObject(intCount).Value = 1 Then
            intNum = intNum + 1
        End If
    Next
    GetNum = intNum
End Function

Private Sub tedBudget_GotFocus()
    mblnChanged = True
End Sub