frmquotabook.frm

金算盘软件代码

    mclsQuota.ReportName = strName
    blnIsOK = mclsQuota.SaveTable                                '保存报表属性
    If blnIsOK = False Then GoTo ExitHandle
    mclsFormCond.KeyID = mclsQuota.ReportID
    mclsFormCond.UpdateCond                                      '保存报表条件
    mclsCell.ReportID = mclsQuota.ReportID
    mclsCell.SaveFreeCell
    Caption = mclsQuota.ReportName                               '窗体标题
    ReSetTitle
    ABook.Refresh
    gclsSys.SendMessage Me.hwnd, msgReport
    Unload MsgForm
    mblnChanged = False
    mblnSaving = False
    Exit Sub
ExitHandle:
    mblnSaving = False
    Unload MsgForm
    mclsQuota.ReportName = strOLdName
    Utility.ShowMsg Me.hwnd, "保存报表失败,请稍后重新保存!", vbCritical + vbOKOnly, App.title
End Sub
Private Sub cmdSaveAs_Click()
Dim frm As New frmReportSameName
Dim blnIsSameName As Boolean, blnIsOK As Boolean
Dim strName As String, strOLdName As String
    
    If mblnSaving Then Exit Sub
    mblnSaving = True
    If Not MyReportExist(mclsQuota.ReportID) Then
        mblnFatalErr = True
        mblnSaving = False
        Unload Me
        Exit Sub
    End If
    
    strName = mclsQuota.ReportName
    strOLdName = strName
    '是否有同名报表
    blnIsSameName = Report.ReportExist(strName, mclsQuota.ParentId, mclsQuota.ReportID, False)
    Do While blnIsSameName
       blnIsOK = frm.ShowInputBox("已有同名报表了,请输入新的报表名!", strName, , True)
       If blnIsOK Then
            blnIsSameName = Report.ReportExist(strName, mclsQuota.ParentId, mclsQuota.ReportID, False)
       Else
            Set frm = Nothing
            mblnSaving = False
            Exit Sub
       End If
    Loop
    Set frm = Nothing
    '保存
    MsgForm.PleaseWait "正在保存数据，请稍候．．．"
    mclsQuota.ReportName = strName
    blnIsOK = mclsQuota.SaveTable(True)                          '保存报表属性
    If blnIsOK = False Then GoTo ExitHandle
    
    mclsFormCond.KeyID = mclsQuota.ReportID
    mclsFormCond.UpdateCond                                      '保存报表条件
    mclsCell.ReportID = mclsQuota.ReportID
    mclsCell.SaveFreeCell
    Caption = mclsQuota.ReportName                               '窗体标题
    ReSetTitle
    ABook.Refresh
    gclsSys.SendMessage Me.hwnd, msgReport
    Unload MsgForm
    mblnChanged = False
    mblnSaving = False
    Exit Sub
ExitHandle:
    mblnSaving = False
    Unload MsgForm
    mclsQuota.ReportName = strOLdName
    Utility.ShowMsg Me.hwnd, "保存报表失败,请稍后重新保存!", vbCritical + vbOKOnly, App.title
End Sub


Private Sub Form_Activate()
    gclsSys.CurrFormName = Me.hwnd
    Utility.SetHelpID Me.HelpContextID
    Report.SetReportTlb
End Sub


Private Sub Form_Deactivate()
    frmMain.mnuFilePrint.Enabled = False
    frmMain.SetEditUnEnabled
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
    Case vbKeyPageUp
       If VScroll.Value = VScroll.Min Then
          If mlngCurPage > 1 Then
             mlngCurPage = mlngCurPage - 1
             SetData
             VScroll.Value = VScroll.Max
          End If
       Else
          VScroll.Value = IIf(VScroll.Value - VScroll.LargeChange > VScroll.Min, VScroll.Value - VScroll.LargeChange, VScroll.Min)
       End If
    Case vbKeyPageDown
       If VScroll.Value = VScroll.Max Then
          If mlngCurPage < mlngPages Then
             mlngCurPage = mlngCurPage + 1
             SetData
             VScroll.Value = VScroll.Min
          End If
       Else
          VScroll.Value = IIf(VScroll.Value + VScroll.LargeChange < VScroll.Max, VScroll.Value + VScroll.LargeChange, VScroll.Max)
       End If
    Case vbKeyLeft
         HScroll.Value = IIf(HScroll.Value - HScroll.LargeChange > HScroll.Min, HScroll.Value - HScroll.LargeChange, HScroll.Min)
    Case vbKeyRight
         HScroll.Value = IIf(HScroll.Value + HScroll.LargeChange < HScroll.Max, HScroll.Value + HScroll.LargeChange, HScroll.Max)
    Case vbKeyEscape
        Unload Me
    End Select
End Sub

Private Sub mclsMainControl_ChildActive()
    Utility.SetHelpID Me.HelpContextID
End Sub

Private Sub mclsMainControl_FilePrint()
    CmdPrint_Click
End Sub

Private Sub mclsMainControl_ListActivityMenu(ByVal intIndex As Integer)
Dim intLoc As Integer, intCell As Integer, intFunc As Integer
Dim strName As String
Dim blnOK As Boolean
    If ABook.IsMultiSel Then
        Select Case intIndex
            Case 0, 1, 2
                ABook.SetFCMultiAlignment intIndex + 1
            Case 4, 5, 6
                ABook.SetFCMultiAlignment intIndex
            Case 8, 9, 10
                ABook.SetFCMultiAlignment intIndex - 1
        End Select
        ReGetCellChanged
    Else
        mclsCell.FindLoc mintFCIndex, intLoc
        Select Case intIndex
        Case 0  '修改自由单元
            strName = mclsCell.CellName(intLoc)
            intFunc = mclsCell.CellFunc(intLoc)
            blnOK = frmFreeCell.SetCell(strName, intFunc)
            If blnOK Then
                 mclsCell.CellName(intLoc) = strName
                 mclsCell.CellFunc(intLoc) = intFunc
                 SetData
            End If
        Case 1  '删除自由单元
            intFunc = Utility.ShowMsg(Me.hwnd, "确定要删除此自由表头吗?", vbQuestion + vbYesNo, App.title)
            If intFunc = 6 Then
                mclsCell.DelCell mintFCIndex
                SetData
            End If
        End Select
    End If
    mblnChanged = True
End Sub

Private Sub mclsMainControl_ListReportMenu(ByVal intIndex As Integer)
Dim intFunc As Integer, intCond As Integer, intLists As Integer
Dim strName As String
Dim blnOK As Boolean
Dim lngWidth As Long, lngHeight As Long
    Select Case intIndex
    Case 0
        cmdAccSet_Click
    Case 1
        cmdFormatSet_Click
    Case 2
    Case 3
        cmdSave_Click
    Case 4
        cmdSaveAs_Click
    Case 5
    Case 6
        CmdPrint_Click
'    Case 9
'         '新增自由单元
'        blnOK = frmFreeCell.SetCell(strName, intFunc)
'        If blnOK Then
'            GetFontWidHei lngWidth, lngHeight, strName, intFunc
'            mclsCell.AddCell mclsQuota.ListColumns + 2 + mclsCell.FreeCells, strName, mbytCellType, intFunc, mlngCellTop, mlngCellLeft, lngWidth, lngHeight
'            SetData
'            mblnChanged = True
'        End If
    Case 10     '重新设置自由单元
        With mclsQuota
            intCond = IIf(.CondShow = 1, 1, 0)
            For intLists = 0 To .ListColumns - 1
                .ColumnAlign(.ColumnListLoc(intLists)) = StandardReport.GetAddFCAlign(.ListColumns + intCond, intLists + intCond + 1, False)
            Next
            .TitleAlign = 13
            .CondAlign = 1
        End With
        SetData
        mblnChanged = True
    Case 8    '锁定自由单元
        If ABook.FCLocked Then
            ABook.FCLocked = 0
            ABook.FCPlace = 1
            ABook.Refresh
        Else
            ABook.FCLocked = 1
            ABook.FCPlace = 0
            ABook.Refresh
        End If
    Case 9    '显示网格
        ABook.FCPlace = IIf(ABook.FCPlace = 0, 1, 0)
        ABook.Refresh
    Case 13
        mblnAutoRefresh = Not mblnAutoRefresh
    End Select
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'                      *             辅助支持                  *
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'刷新纪录
Private Sub RefreshData()
Dim blnPage As Boolean
    
    mblnSaving = True
    If mblnLoaded Then MsgForm.PleaseWait
    If ABook.IsInitSuccessed = 0 Then
        mblnSaving = False
        Utility.ShowMsg Me.hwnd, "打印机未安装!", vbOKOnly + vbInformation, App.title
        Unload MsgForm
        Unload Me
        Exit Sub
    Else
        If mclsQuota.CondShow = 2 Then
            ABook.GridBottom = mclsFset.GPaperBorder(1) + 30 + mclsFset.GPaperBorder(6)
        Else
            ABook.GridBottom = 0
        End If
    End If
    
    SetRecBook                                     '得到记录集
    If mblnFatalErr Then
'        If mblnLoaded Then mblnFatalErr = False
'        mblnSaving = False
        Unload MsgForm
        Exit Sub
    End If
    blnPage = DispartPage                          '分页
    If blnPage Then SetData                        '填充数据
    ResetPageCommamd
    Unload MsgForm
    mblnSaving = False
End Sub
'生成新记录集
Private Sub SetRecBook()
  Dim strSql As String, strWhere As String, strTemp As String
  Dim rstBook As rdoResultset

    '报表附加条件
    strWhere = mclsQuota.ReportCond
    '列表框条件
    If mstrListCond <> "" Then
        If strWhere = "" Then
            strWhere = mstrListCond
        Else
            strWhere = strWhere & " And " & mstrListCond
        End If
    End If
    '查询条件
    If mstrNormalCond <> "" Then
        If strWhere = "" Then
            strWhere = mstrNormalCond
        Else
            strWhere = strWhere & " And " & mstrNormalCond
        End If
    End If
    '剩下的特殊条件
    If mstrExtraCond <> "" Then
        If strWhere = "" Then
            strWhere = mstrExtraCond
        Else
            strWhere = strWhere & " And " & mstrExtraCond
        End If
    End If
    'View条件
    If mclsQuota.ViewCond <> "" Then
        If strWhere = "" Then
            strWhere = mclsQuota.ViewCond
        Else
            strWhere = strWhere & " And " & mclsQuota.ViewCond
        End If
    End If
     '报表向导条件
    If mstrWizardCond <> "" Then
        If strWhere = "" Then
            strWhere = mstrWizardCond
        Else
            strWhere = strWhere & " And " & mstrWizardCond
        End If
    End If
    
    strTemp = GetNoXString(mclsQuota.SalaryList, 2, Space(100))
    If strWhere <> "" Then
        strSql = mclsQuota.GetSQLPre & " WHERE lngSalaryListID = " & CLng(strTemp) & " And " & strWhere & mclsQuota.GetSQLLast
    Else
        strSql = mclsQuota.GetSQLPre & " WHERE lngSalaryListID = " & CLng(strTemp) & mclsQuota.GetSQLLast
    End If
    '得到记录集
    msgAccount.Clear
    On Error GoTo ErrHandle                       'SQL陷阱
    Set Data1.Resultset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    On Error GoTo 0
        
    msgAccount.col = 0
    msgAccount.Sort = 5
'    rstBook.Close
    AddTotal                                       '加合计数
    ReSetColWidth                                  '设置列宽
    If mclsQuota.ColumnFieldDesc(mclsQuota.ChoosedLoc(0)) = "部门编码" Then
        LevelSum 2
    End If
    Exit Sub
ErrHandle:
    mblnFatalErr = True