budgetsetcard.frm

金算盘软件代码

        chkBudget(8).Value = IIf(recTemp("blnIsQuantity"), 1, 0)
        chkBudget(9).Value = IIf(recTemp("blnIsAlarm"), 1, 0)
        cboBudget.ListIndex = recTemp("bytBudgetType") - 1
        GetBudget = True
    Else
        If Visible Then ShowMsg Me.hwnd, "该预算方案已经被其他用户删除！", vbInformation, Me.Caption
        GetBudget = False
    End If
End Function

'新增计划预算
Private Function InsertBudget() As Boolean
    Dim strSql As String
    Dim lngTmpID As Long
    
    On Error GoTo errhandel:
    'strSql = "INSERT INTO Budget (strBudgetName,bytBudgetType,blnIsAccount,blnIsCustomer" _
        & ",blnIsDepartment,blnIsEmployee,blnIsClass1,blnIsClass2" _
        & ",blnIsNatualCurrency,blnIsOriginalCurrency,blnIsQuantity,blnIsAlarm) VALUES('" _
        & tedBudget.Text & "'," & cboBudget.ListIndex + 1 & "," & IIf(chkBudget(0).Value = 1, True, False) & "," _
        & IIf(chkBudget(1).Value = 1, True, False) & "," & IIf(chkBudget(2).Value = 1, True, False) & "," _
        & IIf(chkBudget(3).Value = 1, True, False) & "," & IIf(chkBudget(4).Value = 1, True, False) & "," _
        & IIf(chkBudget(5).Value = 1, True, False) & "," & IIf(chkBudget(6).Value = 1, True, False) & "," _
        & IIf(chkBudget(7).Value = 1, True, False) & "," & IIf(chkBudget(8).Value = 1, True, False) & "," _
        & IIf(chkBudget(9).Value = 1, True, False) & ")"
    lngTmpID = BillPublic.GetNewID("Budget")
    strSql = "INSERT INTO Budget (lngBudgetID,strBudgetName,bytBudgetType,blnIsAccount,blnIsCustomer" _
        & ",blnIsDepartment,blnIsEmployee,blnIsClass1,blnIsClass2" _
        & ",blnIsNatualCurrency,blnIsOriginalCurrency,blnIsQuantity,blnIsAlarm) VALUES(" & lngTmpID & ",'" _
        & tedBudget.Text & "'," & cboBudget.ListIndex + 1 & "," & IIf(chkBudget(0).Value = 1, 1, 0) & "," _
        & IIf(chkBudget(1).Value = 1, 1, 0) & "," & IIf(chkBudget(2).Value = 1, 1, 0) & "," _
        & IIf(chkBudget(3).Value = 1, 1, 0) & "," & IIf(chkBudget(4).Value = 1, 1, 0) & "," _
        & IIf(chkBudget(5).Value = 1, 1, 0) & "," & IIf(chkBudget(6).Value = 1, 1, 0) & "," _
        & IIf(chkBudget(7).Value = 1, 1, 0) & "," & IIf(chkBudget(8).Value = 1, 1, 0) & "," _
        & IIf(chkBudget(9).Value = 1, 1, 0) & ")"
    gclsBase.BaseDB.Execute strSql
    '发出预算方案消息
    gclsSys.SendMessage CStr(Me.hwnd), Message.msgBudgetPlan
    InsertBudget = True
    Exit Function
errhandel:
    If InStr(UCase(Err.Description), "ORA-00001") > 1 Then
        If Visible Then ShowMsg Me.hwnd, "计划预算名称已经存在，新增失败！", vbOKOnly + vbCritical, Me.Caption
    Else
        If Visible Then ShowMsg Me.hwnd, "新增计划预算失败！", vbOKOnly + vbCritical, Me.Caption
    End If
    InsertBudget = False
    Exit Function
End Function

'修改计划预算
Private Function UpdateBudget() As Boolean
    Dim strSql As String
    Dim lngResult As Long
    Dim strSql1 As String
    Dim recTemp As rdoResultset
    Dim blnResult As Boolean
    
    Set recTemp = gclsBase.BaseDB.OpenResultset("SELECT * FROM Budget WHERE lngBudgetID=" & mlngID, rdOpenStatic)
    With recTemp
        If Not .EOF Then
            'If !blnIsCustomer And chkBudget(1).Value <> 1 Then blnResult = True
            'If !blnIsDepartment And chkBudget(2).Value <> 1 Then blnResult = True
            'If !blnIsEmployee And chkBudget(3).Value <> 1 Then blnResult = True
            'If !blnIsClass1 And chkBudget(4).Value <> 1 Then blnResult = True
            'If !blnIsClass2 And chkBudget(5).Value <> 1 Then blnResult = True
            If !blnIsCustomer = 1 And chkBudget(1).Value <> 1 Then blnResult = True
            If !blnIsDepartment = 1 And chkBudget(2).Value <> 1 Then blnResult = True
            If !blnIsEmployee = 1 And chkBudget(3).Value <> 1 Then blnResult = True
            If !blnIsClass1 = 1 And chkBudget(4).Value <> 1 Then blnResult = True
            If !blnIsClass2 = 1 And chkBudget(5).Value <> 1 Then blnResult = True
            If !blnIsNatualCurrency = 1 And chkBudget(6).Value <> 1 Then blnResult = True
            If !blnIsOriginalCurrency = 1 And chkBudget(7).Value <> 1 Then blnResult = True
            If blnResult Then
                lngResult = ShowMsg(Me.hwnd, "改变预算方案将清除原方案所有预算数据，你确实要改变预算方案吗？" _
                    , vbQuestion + vbYesNo + vbDefaultButton2, Me.Caption)
                If lngResult = vbNo Then
                    UpdateBudget = False
                    If GetBudget Then
                        mblnChanged = False
                    End If
                    Exit Function
                Else
                    strSql1 = "DELETE FROM BudgetBalance WHERE lngBudgetID=" & mlngID
                End If
            End If
        End If
    End With
    
    'strSql = "UPDATE Budget Set strBudgetName='" & tedBudget.Text & "',bytBudgetType=" _
        & cboBudget.ListIndex + 1 & ",blnIsAccount=" _
        & IIf(chkBudget(0).Value = 1, True, False) & ",blnIsCustomer=" _
        & IIf(chkBudget(1).Value = 1, True, False) & ",blnIsDepartment=" _
        & IIf(chkBudget(2).Value = 1, True, False) & ",blnIsEmployee=" _
        & IIf(chkBudget(3).Value = 1, True, False) & ",blnIsClass1=" _
        & IIf(chkBudget(4).Value = 1, True, False) & ",blnIsClass2=" _
        & IIf(chkBudget(5).Value = 1, True, False) & ",blnIsNatualCurrency=" _
        & IIf(chkBudget(6).Value = 1, True, False) & ",blnIsOriginalCurrency=" _
        & IIf(chkBudget(7).Value = 1, True, False) & ",blnIsQuantity=" _
        & IIf(chkBudget(8).Value = 1, True, False) & ",blnIsAlarm=" _
        & IIf(chkBudget(9).Value = 1, True, False) & " WHERE lngBudgetID=" & mlngID
    strSql = "UPDATE Budget Set strBudgetName='" & tedBudget.Text & "',bytBudgetType=" _
        & cboBudget.ListIndex + 1 & ",blnIsAccount=" _
        & IIf(chkBudget(0).Value = 1, 1, 0) & ",blnIsCustomer=" _
        & IIf(chkBudget(1).Value = 1, 1, 0) & ",blnIsDepartment=" _
        & IIf(chkBudget(2).Value = 1, 1, 0) & ",blnIsEmployee=" _
        & IIf(chkBudget(3).Value = 1, 1, 0) & ",blnIsClass1=" _
        & IIf(chkBudget(4).Value = 1, 1, 0) & ",blnIsClass2=" _
        & IIf(chkBudget(5).Value = 1, 1, 0) & ",blnIsNatualCurrency=" _
        & IIf(chkBudget(6).Value = 1, 1, 0) & ",blnIsOriginalCurrency=" _
        & IIf(chkBudget(7).Value = 1, 1, 0) & ",blnIsQuantity=" _
        & IIf(chkBudget(8).Value = 1, 1, 0) & ",blnIsAlarm=" _
        & IIf(chkBudget(9).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
    
    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
    If chkBudget(6).Value = 0 And chkBudget(7).Value = 0 Then
        If Visible Then ShowMsg Me.hwnd, "预算项目中本币和原币至少要选择一项！", vbInformation, Me.Caption
        SaveBudget = False
        Exit Function
    End If
    If chkBudget(0).Value = 1 Or chkBudget(1).Value = 1 Or chkBudget(2).Value = 1 Or chkBudget(3).Value = 1 _
        Or chkBudget(4).Value = 1 Or chkBudget(5).Value = 1 Then
        If lngID = 0 Then   '新增
            If InsertBudget() Then
                strSql = "SELECT lngBudgetID FROM Budget WHERE strBudgetName='" & tedBudget.Text & "'"
                Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                If recTemp.RowCount > 0 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
    Else
        If Visible Then ShowMsg Me.hwnd, "预算项目中除本币、原币、数量外至少还要选择一项！", vbOKOnly + vbInformation, Me.Caption
        SaveBudget = False
    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
                    If Visible Then ShowMsg hwnd, "“" & strBudgetName & "”正在使用，不能删除！", vbInformation, "删除计划预算"
                End If
            End If
        Else
            DelCard = True
        End If
    
    End If
    Exit Function
errhandel:
    If Visible Then ShowMsg Me.hwnd, "数据库错误，删除失败！", vbCritical, "删除计划预算"
    DelCard = False
End Function

Private Sub cboBudget_Click()
    mblnChanged = True
End Sub

Private Sub chkBudget_Click(Index As Integer)
    mblnChanged = True
    UpdateAlarm
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)
    InitBudgetType
End Sub

Private Sub Form_Paint()
    FrameBox Me.hwnd, 120, 1050, 3360, 2100
    FrameBox Me.hwnd, 120, 2280, 3360, 2970
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
            If Visible Then
                lngResult = ShowMsg(Me.hwnd, "是否保存当前计划预算？", vbYesNoCancel + vbQuestion, Me.Caption)
            Else
                lngResult = vbYes
            End If
            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 InitBudgetType()
    cboBudget.Clear
    cboBudget.AddItem "发生净额"
    cboBudget.AddItem "借方发生额"
    cboBudget.AddItem "贷方发生额"
    cboBudget.AddItem "余额"
End Sub

'更新自动报警状态
Private Sub UpdateAlarm()
    Dim intCount As Integer
    
    For intCount = 1 To 5
        If chkBudget(intCount).Value = 1 Then Exit For
    Next
    If intCount > 5 Then
        chkBudget(9).Enabled = True
    Else
        chkBudget(9).Value = 0
        chkBudget(9).Enabled = False
    End If
End Sub

Private Sub tedBudget_GotFocus()
    mblnChanged = True
End Sub