frmquotabook.frm

金算盘软件代码

    mblnSaving = False
    If Err.Number = 40002 Then
        strTemp = "配款项目已被删除,"
    Else
        strTemp = " 未知错误,"
    End If
    If mblnLoaded Then
        strTemp = strTemp & "程序将关闭窗体!"
    Else
        strTemp = strTemp & "不能打开窗体!"
    End If
    Utility.ShowMsg Me.hwnd, strTemp, vbExclamation + vbOKOnly, App.title
    Unload Me
End Sub
'分页
Private Function DispartPage() As Boolean
Dim intCol As Integer, intRow As Integer
Dim intRecCount As Integer
Dim lngWidth As Long, lngFixedWidth As Long
Dim intColStart() As Integer, intColEnd() As Integer, lngColExpands As Long     '临时保存模块变量
    
    '页横向扩展
    mlngPageWidth = ABook.ColCount              '得到最大页宽度
    lngColExpands = 0
    ReDim intColStart(lngColExpands)
    ReDim intColEnd(lngColExpands)
    intColStart(0) = 0
    '取固定列宽度(第一列不计算：隐藏列)
    lngFixedWidth = 0
    For intCol = 1 To msgAccount.FixedCols - 1
        lngFixedWidth = lngFixedWidth + msgAccount.ColWidth(intCol) / Screen.TwipsPerPixelX
        If lngFixedWidth > mlngPageWidth Then
            Utility.ShowMsg Me.hwnd, "固定列太宽,请减小列宽!", vbOKOnly + vbInformation, App.title
            DispartPage = False
            Exit Function
        End If
    Next intCol
    '算列宽
    lngWidth = lngFixedWidth
    For intCol = msgAccount.FixedCols To msgAccount.Cols - 1
        lngWidth = lngWidth + msgAccount.ColWidth(intCol) / Screen.TwipsPerPixelX
        If lngWidth > mlngPageWidth Then
            lngColExpands = lngColExpands + 1
            ReDim Preserve intColStart(lngColExpands)
            ReDim Preserve intColEnd(lngColExpands)
            lngWidth = lngFixedWidth + msgAccount.ColWidth(intCol) / Screen.TwipsPerPixelX
            intColEnd(lngColExpands - 1) = intCol - 1 - msgAccount.FixedCols
            intColStart(lngColExpands) = intCol - msgAccount.FixedCols
        End If
    Next intCol
    intColEnd(lngColExpands) = intCol - 1 - msgAccount.FixedCols
    mlngColExpands = lngColExpands + 1
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '页纵向扩展
    mintPageRows = GetGridheight                                    '得到最大页行数
    If mintPageRows <= msgAccount.FixedRows Then
         Utility.ShowMsg Me.hwnd, "数据行数太小,请增加行数!", vbOKOnly + vbInformation, App.title
         DispartPage = False
         cmdFormatSet_Click
         Exit Function
    End If
    If mstrLevelCond = "" Then
        intRecCount = msgAccount.Rows - msgAccount.FixedRows
        If intRecCount = 0 Then
             mlngRowExpands = 1
        ElseIf intRecCount Mod (mintPageRows - msgAccount.FixedRows) = 0 Then
             mlngRowExpands = intRecCount \ (mintPageRows - msgAccount.FixedRows)
        Else
             mlngRowExpands = intRecCount \ (mintPageRows - msgAccount.FixedRows) + 1
        End If
        
        mlngPages = mlngRowExpands * mlngColExpands
        ReDim mlngColStart(mlngPages - 1)
        ReDim mlngColEnd(mlngPages - 1)
        ReDim mlngRowStart(mlngPages - 1)
        ReDim mlngRowEnd(mlngPages - 1)
        For intRow = 0 To mlngRowExpands - 2
            For intCol = 0 To mlngColExpands - 1
                mlngColStart(intRow * mlngColExpands + intCol) = intColStart(intCol)
                mlngColEnd(intRow * mlngColExpands + intCol) = intColEnd(intCol)
                mlngRowStart(intRow * mlngColExpands + intCol) = intRow * (mintPageRows - msgAccount.FixedRows) + 1
                mlngRowEnd(intRow * mlngColExpands + intCol) = (intRow + 1) * (mintPageRows - msgAccount.FixedRows)
            Next intCol
        Next intRow
        '有最后一行记录的页
        For intCol = 0 To mlngColExpands - 1
                mlngColStart(intRow * mlngColExpands + intCol) = intColStart(intCol)
                mlngColEnd(intRow * mlngColExpands + intCol) = intColEnd(intCol)
                mlngRowStart(intRow * mlngColExpands + intCol) = intRow * (mintPageRows - msgAccount.FixedRows) + 1
                mlngRowEnd(intRow * mlngColExpands + intCol) = intRecCount
        Next intCol
    Else
        Dim intStart As Integer
        mlngPages = 0   '1 * mlngColExpands
        intRecCount = 0
        With msgAccount
            intStart = .FixedRows
            For intRow = .FixedRows To .Rows - 1
                If .RowHeight(intRow) > 0 Then
                    intRecCount = intRecCount + 1
                    If intRecCount = 1 Then
                        intStart = intRow
                    End If
                    If intRecCount = mintPageRows - msgAccount.FixedRows Then
                        mlngPages = mlngPages + mlngColExpands
                        ReDim Preserve mlngColStart(mlngPages - 1)
                        ReDim Preserve mlngColEnd(mlngPages - 1)
                        ReDim Preserve mlngRowStart(mlngPages - 1)
                        ReDim Preserve mlngRowEnd(mlngPages - 1)
                        For intCol = 0 To mlngColExpands - 1
                                mlngColStart(mlngPages - mlngColExpands + intCol) = intColStart(intCol)
                                mlngColEnd(mlngPages - mlngColExpands + intCol) = intColEnd(intCol)
                                mlngRowStart(mlngPages - mlngColExpands + intCol) = intStart
                                mlngRowEnd(mlngPages - mlngColExpands + intCol) = intRow
                        Next intCol
                        intStart = 0
                    End If
                End If
            Next intRow
            
            If intRecCount = 0 Then
                '无记录
                mlngPages = mlngPages + mlngColExpands
                ReDim Preserve mlngColStart(mlngPages - 1)
                ReDim Preserve mlngColEnd(mlngPages - 1)
                ReDim Preserve mlngRowStart(mlngPages - 1)
                ReDim Preserve mlngRowEnd(mlngPages - 1)
                For intCol = 0 To mlngColExpands - 1
                        mlngColStart(mlngPages - mlngColExpands + intCol) = intColStart(intCol)
                        mlngColEnd(mlngPages - mlngColExpands + intCol) = intColEnd(intCol)
                        mlngRowStart(mlngPages - mlngColExpands + intCol) = intStart
                        mlngRowEnd(mlngPages - mlngColExpands + intCol) = .Rows - 1
                Next intCol
                intStart = 0
            ElseIf intStart <> 0 Then
                '非满页
                mlngPages = mlngPages + mlngColExpands
                ReDim Preserve mlngColStart(mlngPages - 1)
                ReDim Preserve mlngColEnd(mlngPages - 1)
                ReDim Preserve mlngRowStart(mlngPages - 1)
                ReDim Preserve mlngRowEnd(mlngPages - 1)
                For intCol = 0 To mlngColExpands - 1
                        mlngColStart(mlngPages - mlngColExpands + intCol) = intColStart(intCol)
                        mlngColEnd(mlngPages - mlngColExpands + intCol) = intColEnd(intCol)
                        mlngRowStart(mlngPages - mlngColExpands + intCol) = intStart
                        mlngRowEnd(mlngPages - mlngColExpands + intCol) = .Rows - 1
                Next intCol
                intStart = 0
            Else
            End If
        End With
    End If
    DispartPage = True
   '''''''''''
    'Added by Hebing!!!!!
    '
    ''''''''''''''''
'    mlngCurPage = 1
    CheckPages mlngPages
    SetPageContents VSpage.Value, mlngPages
    SetCurContents mlngCurPage
    
End Function
'填充数据
Private Sub SetData()
  Dim intRow As Integer, intCol As Integer, intSum As Integer
  Dim intCount As Integer, intLoc As Integer, intIndex As Integer
  Dim blnIsData As Boolean
    If mlngPages = 0 Then Exit Sub
    ABook.NewPage                                                 '清除记录
    If mlngCurPage > mlngPages Then mlngCurPage = mlngPages
    If mlngCurPage = 0 Then mlngCurPage = 1
    
    '''''''''Added by Heing         !!!!
     SetCurContents mlngCurPage
    
    
    setMaxCol mlngColEnd(mlngCurPage - 1) - mlngColStart(mlngCurPage - 1) + 1
    SetDefColWidth 1110 / Screen.TwipsPerPixelX
    
    '设置表头区
    Caption = mclsQuota.ReportName            '窗体标题
    SetFixRow 1
    '设置栏目标题 (包括列宽)
    intCol = 0
    With msgAccount
    '第一行是栏目名称
'    SetRowInfo 0, GetDefRowheight * 1.1
    For intCount = mlngColStart(mlngCurPage - 1) To mlngColEnd(mlngCurPage - 1)
        intIndex = mclsQuota.ChoosedLoc(intCount)
        Select Case UCase(mclsQuota.FieldType(intIndex))
        Case "BYTE", "INTEGER", "SINGLE", "DOUBLE", "DECIMAL", "LONG", "CURRENCY "
            blnIsData = True
        Case Else
            blnIsData = False
        End Select
        SetColumnInfo intCol, .ColWidth(intCount) / Screen.TwipsPerPixelX, blnIsData
        SetCell intCol, 0, .TextMatrix(0, intCount), 4, True
        intCol = intCol + 1
    Next intCount
    '设置数据区
        intRow = 1
        For intSum = 1 To mlngRowEnd(mlngCurPage - 1) - mlngRowStart(mlngCurPage - 1) + 1
            intLoc = intSum + mlngRowStart(mlngCurPage - 1) - 1
            If mstrLevelCond = "" Or (mstrLevelCond <> "" And .RowHeight(intLoc) > 0) Then
                intCol = 0
                For intCount = mlngColStart(mlngCurPage - 1) To mlngColEnd(mlngCurPage - 1)
                    intIndex = mclsQuota.ChoosedLoc(intCount)
                    Select Case UCase(mclsQuota.FieldType(intIndex))
                    Case "BYTE", "INTEGER", "SINGLE", "DOUBLE", "DECIMAL", "LONG", "CURRENCY "
                        SetCell intCol, intRow, .TextMatrix(intSum + mlngRowStart(mlngCurPage - 1) - 1, intCount), 8
                    Case Else
                        SetCell intCol, intRow, .TextMatrix(intSum + mlngRowStart(mlngCurPage - 1) - 1, intCount), 2
                    End Select
                    intCol = intCol + 1
                Next intCount
                intRow = intRow + 1
            End If
        Next intSum
    End With
    ReSetTitle                                            '报表标题
    ReSetCondCell                                         '查询条件
    AddHeadTail                                           '加表头表尾
    Dim strTemp As String
    For intCount = 0 To 5
        strTemp = strReplace(mstrHF(intCount), "&[页码]", str(mlngCurPage))
        strTemp = strReplace(strTemp, "&[总页数]", str(mlngPages))
        ABook.PageHF(intCount) = strTemp
    Next
    ABook.Refresh
End Sub
Private Sub ReSetTitle()
    With mclsQuota
        SetFreeCell 0, "", .ReportName, .TitleLeft / Screen.TwipsPerPixelX, .TitleTop / Screen.TwipsPerPixelX, _
           .TitleWidth / Screen.TwipsPerPixelY, .TitleHeight / Screen.TwipsPerPixelY, , True, .TitleAlign, True, False
    End With
End Sub
Private Sub ReSetCondCell()
Dim intType As Integer
Dim lngWidth As Long, lngHeight As Long
Dim strName As String
    With mclsQuota
        intType = .CondShow
        If intType > 0 Then
            If (mlngCurPage = mlngPages And .CondShow = 2) Or (mlngCurPage = 1 And .CondShow = 1) Then
                lngWidth = .CondWidth
                lngHeight = .CondHeight
                strName = "查询条件：" & Trim(mstrCellQueryCond & mstrCellExtraCond)
                If lngWidth = -1 Then
                    GetFontWidHei lngWidth, lngHeight, strName, 0
                End If
                If lngWidth > 8000 Then
                    lngWidth = 8000
                End If
                SetFreeCell 1, , strName, .CondLeft / Screen.TwipsPerPixelX, .CondTop / Screen.TwipsPerPixelX, _
                    lngWidth / Screen.TwipsPerPixelY, lngHeight / Screen.TwipsPerPixelY, , False, .CondAlign, IIf(intType = 1, True, False)
                If Trim(mstrCellQueryCond & mstrCellExtraCond) = "" Then
                    ABook.FCHide(1) = True
                End If
            Else
                SetFreeCell 1, "查询条件："
                ABook.FCHide(1) = True
            End If
        Else
            SetFreeCell 1, "查询条件："
            ABook.FCHide(1) = True
        End If
    End With
End Sub

'加表头表尾
Private Sub AddHeadTail()
Dim intCount As Integer, intIndex As Integer
Dim intType As Integer
Dim lngWidth As Long, lngHeight As Long
Dim strName As String, strTitle As String
    With mclsQuota
        intIndex = 2
        '设置列表框
        For intCount = 0 To .ListColumns - 1
            strName = GetNoXString(LblList(intCount).Caption, 1, "(") & "："
            strTitle = cboList(intCount).Text
            lngWidth = .ColumnWidth(.ColumnListLoc(intCount))
            lngHeight = .ColumnHeight(.ColumnListLoc(intCount))
            If lngWidth = -1 Then
                GetFontWidHei lngWidth, lngHeight, strName & strTitle, 0
            End If
            SetFreeCell intIndex, strName, strTitle, _
                            .ColumnLeft(.ColumnListLoc(intCount)) / Screen.TwipsPerPixelX, .ColumnTop(.ColumnListLoc(intCount)) / Screen.TwipsPerPixelY, _
                            lngWidth / Screen.TwipsPerPixelY, lngHeight / Screen.TwipsPerPixelY, , , _
                            .ColumnAlign(.ColumnListLoc(intCount)), True
            intIndex = intIndex + 1
        Next intCount
    End With
    '设置自由单元
    With mclsCell
        For intCount = 0 To .CellUBound
            If .CellValid(intCount) Then
                Select Case .CellFunc(intCount)
                Case 0
                    strName = .CellName(intCount)
                    strTitle = ""
                Case 1
                    strName = "所有"
                    strTitle = .CellName(intCount) & "："
                Case 5
                    strName = mlngCurPage
                    strTitle = .CellName(intCount) & "："
                Case 6
                    strName = mstrCellQueryCond & mstrCellExtraCond
                    strTitle = .CellName(intCount) & "："
                Case Else
                    strName = CellFunc(.CellFunc(intCount))
                    strTitle = .CellName(intCount) & "："
                End Select
                intType = .CellType(intCount)
                lngWidth = .CellWidth(intCount)
                lngHeight = .CellHeight(intCount)
                If lngWidth = -1 Then
                    GetFontWidHei lngWidth, lngHeight, strName & strTitle, 0
                End If
                SetFreeCell .CellNo(intCount), strTitle, strName, .CellLeft(intCount) / Screen.TwipsPerPixelX, .CellTop(intCount) / Screen.TwipsPerPixelX, _
                            lngWidth / Screen.TwipsPerPixelY, lngHeight / Screen.TwipsPerPixelY, , IIf(intType = 3, True, False), _
                            .CellAlign(intCount), IIf(intType = 2, False, True)
            End If
        Next intCount
    End With
End