frmstandardbook.frm

金算盘软件代码

    End If
    frmMain.ZOrder 0
End Sub
Private Sub cmdSave_Click()
Dim frm As New frmReportSameName
Dim blnIsSameName As Boolean, blnIsOK As Boolean, blnErr As Boolean
Dim strName As String, strErr As String
    
    If mblnSaving Then Exit Sub
    If mblnChanged = False Then Exit Sub
    mblnSaving = True
    If Not MyReportExist(mclsStandard.ReportID) Then
        mblnFatalErr = True
        mblnSaving = False
        Unload Me
        Exit Sub
    End If
    
    If mclsStandard.ReportPrep = 0 Then
        cmdSaveAs_Click
        mblnSaving = False
        Exit Sub
    End If
    '是否有同名报表
    strName = IIf(mblnStandard, mclsStandard.ReportName, mclsCross.ReportName)
    blnErr = Report.NameIsErr(strName, strErr)
    If blnErr Then
        blnIsOK = frm.ShowInputBox("报表不能有非法字符:'" & strErr & "',请输入新的报表名!", strName, , True)
        If Not blnIsOK Then
            mblnSaving = False
            Exit Sub
        End If
    End If
    blnIsSameName = Report.ReportExist(strName, mclsStandard.ParentId, mclsStandard.ReportID)
    Do While blnIsSameName
       blnIsOK = frm.ShowInputBox("已有同名报表了,请输入新的报表名!", strName, , True)
       If blnIsOK Then
            blnIsSameName = Report.ReportExist(strName, mclsStandard.ParentId, mclsStandard.ReportID)
       Else
            mblnSaving = False
            Exit Sub
       End If
    Loop
    Set frm = Nothing
    '保存
    MsgForm.PleaseWait "正在保存数据，请稍候．．．"
    If mblnStandard Then
        mclsStandard.ReportName = strName
        blnIsOK = mclsStandard.SaveStandard                             '保存报表属性
        If blnIsOK = False Then GoTo ExitHandle
        mclsFormCond.KeyID = mclsStandard.ReportID
        mclsCell.ReportID = mclsStandard.ReportID
    Else
        mclsCross.ReportName = strName
        blnIsOK = mclsCross.SaveCross                                   '保存报表属性
        If blnIsOK = False Then GoTo ExitHandle
        mclsFormCond.KeyID = mclsCross.ReportID
        mclsCell.ReportID = mclsCross.ReportID
    End If
    
    mclsFormCond.UpdateCond                                             '保存报表条件
    mclsCell.SaveFreeCell                                               '保存自由单元
    Caption = strName
    ReSetTitle
    ABook.Refresh
    gclsSys.SendMessage Me.hWnd, msgReport
    Unload MsgForm
    mblnChanged = False
    mblnSaving = False
    Exit Sub
ExitHandle:
    mblnSaving = False
    Unload MsgForm
    If mblnStandard Then
        mclsStandard.ReportName = mclsCross.ReportName
    Else
        mclsCross.ReportName = mclsStandard.ReportName
    End If
    Utility.ShowMsg Me.hWnd, "保存报表失败,请稍后重新保存!", vbCritical + vbOKOnly, App.title
End Sub

Private Sub cmdSaveAs_Click()
Dim intCount As Integer
Dim frm As New frmReportSameName
Dim blnIsSameName As Boolean, blnIsOK As Boolean
Dim strName As String
    
    If mblnSaving Then Exit Sub
    mblnSaving = True
    If Not MyReportExist(mclsStandard.ReportID) Then
        mblnFatalErr = True
        mblnSaving = False
        Unload Me
        Exit Sub
    End If
    
    strName = IIf(mblnStandard, mclsStandard.ReportName, mclsCross.ReportName)
    '是否有同名报表
    blnIsSameName = Report.ReportExist(strName, mclsStandard.ParentId, mclsStandard.ReportID, False)
    Do While blnIsSameName
       blnIsOK = frm.ShowInputBox("已有同名报表了,请输入新的报表名!", strName, , True)
       If blnIsOK Then
            blnIsSameName = Report.ReportExist(strName, mclsStandard.ParentId, mclsStandard.ReportID, False)
       Else
            mblnSaving = False
            Exit Sub
       End If
    Loop
    Set frm = Nothing
    '保存
    MsgForm.PleaseWait "正在保存数据，请稍候．．．"
    If mblnStandard Then
        mclsStandard.ReportName = strName
        blnIsOK = mclsStandard.SaveStandard(True)                        '保存标准表
        If blnIsOK = False Then GoTo ExitHandle
        mclsFormCond.KeyID = mclsStandard.ReportID
        mclsCell.ReportID = mclsStandard.ReportID
        mclsCross.ReportID = mclsStandard.ReportID
    Else
        mclsCross.ReportName = strName
        blnIsOK = mclsCross.SaveCross(True)                              '保存交叉表
        If blnIsOK = False Then GoTo ExitHandle
        mclsFormCond.KeyID = mclsCross.ReportID
        mclsCell.ReportID = mclsCross.ReportID
        mclsStandard.ReportID = mclsCross.ReportID
        For intCount = 0 To mclsCross.Columns - 1
            mclsStandard.ReportFieldID(intCount) = mclsCross.ReportFieldID(intCount)
        Next intCount
    End If
    
    mclsFormCond.UpdateCond                                             '保存报表条件
    mclsCell.SaveFreeCell                                               '保存自由单元
    Caption = strName
    ReSetTitle
    ABook.Refresh
    gclsSys.SendMessage Me.hWnd, msgReport
    Unload MsgForm
    mblnChanged = False
    mblnSaving = False
    Exit Sub
ExitHandle:
    mblnSaving = False
    Unload MsgForm
    If mblnStandard Then
        mclsStandard.ReportName = mclsCross.ReportName
    Else
        mclsCross.ReportName = mclsStandard.ReportName
    End If
    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
'            intLists = IIf(mblnStandard, mclsStandard.ListColumns, mclsCross.ListColumns)
'            mclsCell.AddCell intLists + 2 + mclsCell.FreeCells, strName, mbytCellType, intFunc, mlngCellTop, mlngCellLeft, lngWidth, lngHeight
'            SetData
'            mblnChanged = True
'        End If
    
    Case 8    '锁定自由单元
        If ABook.FCLocked Then
            ABook.FCLocked = 0
        Else
            ABook.FCLocked = 1
            ABook.FCPlace = 0
            ABook.Refresh
        End If
    Case 9    '显示网格
        ABook.FCPlace = IIf(ABook.FCPlace = 0, 1, 0)
        ABook.Refresh
    Case 10     '重新设置自由单元
        If mblnStandard Then
            With mclsStandard
                intCond = IIf(.CondShow = 1, 1, 0)
                For intLists = 0 To .ListColumns - 1
                    .ColumnAlign(.ColumnListLoc(intLists)) = StandardReport.GetAddFCAlign(.ListColumns + intCond + 1, intLists + intCond + 1)
                Next
                .TitleAlign = 13
                .CondAlign = 1
            End With
        Else
            With mclsCross
                intCond = IIf(.CondShow = 1, 1, 0)
                For intLists = 0 To .ListColumns - 1
                    .ColumnAlign(.ColumnListLoc(intLists)) = StandardReport.GetAddFCAlign(.ListColumns + intCond + 1, intLists + intCond + 1)
                Next
                .TitleAlign = 13
                .CondAlign = 1
            End With
        End If
        mclsCell.ReSetDateCellLoc
        SetData
        mblnChanged = True
    Case 11
        mblnCrossSameWidth = Not mblnCrossSameWidth
        If mblnCrossSameWidth Then
            lngWidth = mclsCross.DefWidth 'msgTitle.ColWidth(mclsCross.RowColumns)
            For intCond = mclsCross.RowColumns To msgTitle.Cols - 1
                msgTitle.ColWidth(intCond) = lngWidth
            Next intCond
            SetData
        End If
    Case 13
        mblnAutoRefresh = Not mblnAutoRefresh
    End Select
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'                      *             辅助支持                  *
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'得到列表框条件
Private Sub GetListCond()
Dim intCount As Integer, intLists As Integer
Dim strCode As String, strTemp As String
    mstrListCond = ""
    If mblnStandard Then
        intLists = mclsStandard.ListColumns
    Else
        intLists = mclsCross.ListColumns
    End If
    For intCount = 0 To intLists - 1
        strTemp = Trim(cboList(intCount).Text)
        strCode = GetNoXString(strTemp, 1)
        Select Case Left(LblList