freecellset.cls

金算盘软件代码

        '新增空间
        intLoc = mvarFreeCells
        ReDim Preserve mvarCellName(intLoc)
        ReDim Preserve mvarCellNo(intLoc)
        ReDim Preserve mvarCellType(intLoc)
        ReDim Preserve mvarCellFunc(intLoc)
        ReDim Preserve mvarCellAlign(intLoc)
        ReDim Preserve mvarCellTop(intLoc)
        ReDim Preserve mvarCellLeft(intLoc)
        ReDim Preserve mvarCellHeight(intLoc)
        ReDim Preserve mvarCellWidth(intLoc)
        ReDim Preserve mvarCellValid(intLoc)
    End If
    
    '赋值
    mvarCellName(intLoc) = strName
    mvarCellNo(intLoc) = intNo
    mvarCellType(intLoc) = intType
    mvarCellFunc(intLoc) = intFunc
    mvarCellHeight(intLoc) = lngHeight
    mvarCellWidth(intLoc) = lngWidth
    mvarCellTop(intLoc) = lngTop * Screen.TwipsPerPixelY
    mvarCellLeft(intLoc) = lngLeft * Screen.TwipsPerPixelX
    mvarCellAlign(intLoc) = 255
    mvarCellValid(intLoc) = True
    If intType = 1 Then
        mvarFreeHeads = mvarFreeHeads + 1
    ElseIf intType = 2 Then
        mvarFreeTails = mvarFreeTails + 1
    End If
    mvarFreeCells = mvarFreeCells + 1
    SetCanAddCell
End Sub

'取自由单元
Public Sub LoadFreeCell()
Dim intCount As Integer, intSum As Integer
Dim strSql As String, strName As String
Dim rstCell As rdoResultset
Dim blnHaveTitle As Boolean
    
   On Error Resume Next
   mvarFreeHeads = 0
   mvarFreeTails = 0
          
        '自由单元
        strSql = "SELECT * FROM ReportHeadTail WHERE lngReportID = " & mvarReportID & " ORDER BY intFieldNO"
        Set rstCell = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If rstCell.EOF Then
            mvarFreeCells = 0
            InitArr 0
        Else
        With rstCell
             .MoveLast
             .MoveFirst
             intSum = .RowCount
             InitArr intSum - 1
             intSum = 0
             Do Until .EOF
                mvarCellName(intSum) = Trim(!strFieldDesc)
                mvarCellNo(intSum) = !intFieldNo
                mvarCellType(intSum) = !bytFieldType
                mvarCellFunc(intSum) = !intFuncIndex
                mvarCellAlign(intSum) = !intAlign
                mvarCellHeight(intSum) = !lngFieldHeight
                mvarCellWidth(intSum) = !lngFieldWidth
                mvarCellLeft(intSum) = !lngFieldLeft
                mvarCellTop(intSum) = !lngFieldTop
                mvarCellValid(intSum) = True
                intSum = intSum + 1
                
                If !bytFieldType = 1 Then
                   mvarFreeHeads = mvarFreeHeads + 1
                ElseIf !bytFieldType = 2 Then
                   mvarFreeTails = mvarFreeTails + 1
                ElseIf !bytFieldType = 4 Then
                    mvarCellNo(intSum - 1) = mvarDateCellNo
                End If
                .MoveNext
             Loop
        End With
            mvarFreeCells = UBound(mvarCellName) + 1
        End If
        Set rstCell = Nothing
        
   
   SetCanAddCell
End Sub

'保存自由单元
Public Sub SaveFreeCell()
Dim intCount As Integer
Dim strSql As String
Dim rstCell As rdoResultset
  
    On Error GoTo clsErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    
    '删除报表自由单元
    strSql = "SELECT * FROM ReportHeadTail WHERE lngReportID = " & mvarReportID
    Set rstCell = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If rstCell.RowCount > 0 Then
        strSql = "Delete  FROM ReportHeadTail WHERE lngReportID = " & mvarReportID
        gclsBase.ExecSQL strSql
    End If
    
    '添加报表报表自由单元
    Set rstCell = gclsBase.BaseDB.OpenResultset("SELECT * FROM ReportHeadTail")
    With rstCell
          For intCount = 0 To UBound(mvarCellValid)
              If mvarCellValid(intCount) Then
                  .AddNew
                  !lngReportID = mvarReportID
                  !strFieldDesc = mvarCellName(intCount)
                  !intFieldNo = mvarCellNo(intCount)
                  !bytFieldType = mvarCellType(intCount)
                  !intFuncIndex = mvarCellFunc(intCount)
                  !intAlign = mvarCellAlign(intCount)
                  !lngFieldTop = mvarCellTop(intCount)
                  !lngFieldLeft = mvarCellLeft(intCount)
                  !lngFieldHeight = mvarCellHeight(intCount)
                  !lngFieldWidth = mvarCellWidth(intCount)
                  .Update
               End If
          Next intCount
     End With
     Set rstCell = Nothing
    gclsBase.BaseWorkSpace.CommitTrans
    Exit Sub
clsErrHandle:
    Set rstCell = Nothing
    gclsBase.BaseWorkSpace.RollBacktrans
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                私有过程
'新增自由单元属性赋值
Private Sub SetCanAddCell()
    If mvarFreeHeads < MaxHeadCells Then
        mvarCanAddHead = True
    Else
        mvarCanAddHead = False
    End If
    If mvarFreeTails < MaxTailCells Then
        mvarCanAddTail = True
    Else
        mvarCanAddTail = False
    End If
End Sub
'重新对索引排序
Private Sub ReSort(ByVal intStart As Integer)
Dim intCount As Integer
    For intCount = intStart + 1 To UBound(mvarCellNo)
        If mvarCellValid(intCount) = True Then
            mvarCellNo(intCount) = mvarCellNo(intCount) - 1
        End If
    Next intCount
End Sub
'重新设置自由单元的序号
Public Sub ReSetCellNo(ByVal intChange As Integer)
Dim intCount As Integer
    For intCount = 0 To UBound(mvarCellNo)
        If mvarCellValid(intCount) = True Then
            mvarCellNo(intCount) = mvarCellNo(intCount) + intChange
        End If
    Next intCount
End Sub
'重新设置日期自由单元的位置
Public Sub ReSetDateCellLoc()
    mvarCellAlign(0) = 5
    If UBound(mvarCellNo) > 0 Then
        mvarCellAlign(1) = 10
    End If
End Sub
'是否日期自由单元
Public Function IsDateCell(ByVal intIndex As Integer) As Boolean
Dim intLoc As Integer
    FindLoc intIndex, intLoc
    If intLoc = 0 Then
        IsDateCell = True
    Else
        IsDateCell = False
    End If
End Function
'初始化数组
Private Sub InitArr(ByVal intTop As Integer)
    ReDim mvarCellName(intTop)
    ReDim mvarCellNo(intTop)
    ReDim mvarCellType(intTop)
    ReDim mvarCellFunc(intTop)
    ReDim mvarCellAlign(intTop)
    ReDim mvarCellTop(intTop)
    ReDim mvarCellLeft(intTop)
    ReDim mvarCellHeight(intTop)
    ReDim mvarCellWidth(intTop)
    ReDim mvarCellValid(intTop)
End Sub
'类的初始化
Private Sub Class_Initialize()
    mvarFreeCells = 0
    InitArr 0
    mvarCellValid(0) = False
End Sub

'类的终止
Private Sub Class_Terminate()
    Erase mvarCellName
    Erase mvarCellNo
    Erase mvarCellType
    Erase mvarCellFunc
    Erase mvarCellAlign
    Erase mvarCellTop
    Erase mvarCellLeft
    Erase mvarCellHeight
    Erase mvarCellWidth
    Erase mvarCellValid
End Sub