mundo.bas

VB做的报表设计源程序,非常不错,可以自定义模版

Attribute VB_Name = "mUndo"
'type descriptor for undo information
Public Type UndoStep
    UndoCategory As Integer
    Type As Integer
    OnPlace As Boolean
End Type

'array for storing undo information
Public UndoList() As UndoStep
'stores current position in Undo list
Public CurrUndoPos As Integer
Public blnFirstUndo As Boolean
Public LastType As Integer

'undo category constants
Public Const unControl = 1
Public Const unSection = 2
Public Const unPage = 3

'undo step type constants
Public Const unPlace = 1
Public Const unMove = 2
Public Const unResize = 3
Public Const unFormat = 4
Public Const unEdit = 5
Public Const unCut = 6
Public Const unPaste = 7
Public Const unSendBack = 8
Public Const unBringFront = 9
Public Const unDelete = 10
Public Const unSectWidth = 11
Public Const unSectHeight = 12
Public Const unPageSize = 13
Public Const unPageOrient = 14
Public Const unPageMargin = 15

'type for undone control
Public Type ControlUndoInfo
    UndoIDNo As Long
    ctl As ControlInfo
End Type

'array to store undone control information
Public UndoCtl() As ControlUndoInfo

'array for storing deleted controls
Public DeletedCtl() As ControlUndoInfo

'type for undo page section
Public Type SectUndoInfo
    UndoIDNo As Long
    sectUndoType As Integer
    SectNo As Integer
    SectWidth As Single
    SectHeight As Single
End Type

'array to store undo page section information
Public UndoSect() As SectUndoInfo

'type for undo page information
Public Type PageUndoInfo
    UndoIDNo As Long
    PageWidth As Single
    PageHeight As Single
    PageOrient As Integer
    PageLMarg As Single
    PageTMarg As Single
    PageRMarg As Single
    PageBMarg As Single
End Type

'array to store undo page information
Public UndoPage() As PageUndoInfo

Public Sub InitUndoArrays()

    ReDim UndoList(0)
    ReDim UndoCtl(0)
    ReDim UndoSect(0)
    ReDim UndoPage(0)
    CurrUndoPos = 0

End Sub

Public Sub WriteToUndoList(UndoCat As Integer, UndoType As Integer)
Dim i As Integer
Dim NewPos As Integer
Dim NewNum As Integer

    For i = 0 To UBound(UndoCtl)
        If UndoCtl(i).UndoIDNo > CurrUndoPos Then
            ReDim Preserve UndoCtl(i)
            Exit For
        End If
    Next i

    CurrUndoPos = CurrUndoPos + 1
    NewPos = CurrUndoPos
    ReDim Preserve UndoList(NewPos)

    UndoList(NewPos).UndoCategory = UndoCat
    UndoList(NewPos).Type = UndoType
    UndoList(NewPos).OnPlace = (UndoType = unPlace)
        
    If UndoCat = unControl Then
        If blnControlSelected Then
            NewNum = UBound(UndoCtl) + 1
            ReDim Preserve UndoCtl(NewNum)
            UndoCtl(NewNum).UndoIDNo = NewPos
            StoreUndoControlInfo ctlActive, NewNum
        ElseIf blnGroupSelected Then
            For i = 0 To UBound(SelectedCtl)
                NewNum = UBound(UndoCtl) + 1
                ReDim Preserve UndoCtl(NewNum)
                UndoCtl(NewNum).UndoIDNo = NewPos
                StoreUndoControlInfo SelectedCtl(i).ctl, NewNum
            Next i
        End If
    
    ElseIf UndoCat = unSection Then
        NewNum = UBound(UndoSect) + 1
        ReDim Preserve UndoSect(NewNum)
        UndoSect(NewNum).UndoIDNo = NewPos
        UndoSect(NewNum).SectNo = CurrSection
        UndoSect(NewNum).SectHeight = frmDesign.picSection(CurrSection).ScaleHeight
        UndoSect(NewNum).SectWidth = frmDesign.picSection(CurrSection).ScaleWidth
        
    ElseIf UndoCat = unPage Then
        NewNum = UBound(UndoPage) + 1
        ReDim Preserve UndoPage(NewNum)
        UndoPage(NewNum).UndoIDNo = NewPos
        UndoPage(NewNum).PageWidth = PageWd
        UndoPage(NewNum).PageHeight = PageHt
        UndoPage(NewNum).PageOrient = PageOrient
        UndoPage(NewNum).PageLMarg = LeftMarg
        UndoPage(NewNum).PageRMarg = RightMarg
        UndoPage(NewNum).PageTMarg = TopMarg
        UndoPage(NewNum).PageBMarg = BottomMarg
    End If
    
    blnFirstUndo = True
    LastType = UndoType
    
End Sub

Private Sub StoreUndoControlInfo(GetCtl As Control, GetUndoNo As Integer)

    If TypeOf GetCtl Is Line Then
        With UndoCtl(GetUndoNo).ctl
            .Name = GetCtl.Name
            .Index = GetCtl.Index
            .Type = cLine
            .SecNo = GetCtl.Tag
            .X1 = GetCtl.X1
            .Y1 = GetCtl.Y1
            .X2 = GetCtl.X2
            .Y2 = GetCtl.Y2
            .BdrClr = GetCtl.BorderColor
            .BdrStl = GetCtl.BorderStyle
            .BdrWd = GetCtl.BorderWidth
        End With
    ElseIf TypeOf GetCtl Is Shape Then
        With UndoCtl(GetUndoNo).ctl
            .Name = GetCtl.Name
            .Index = GetCtl.Index
            .Type = cBox
            .Left = GetCtl.Left
            .Top = GetCtl.Top
            .width = GetCtl.width
            .Height = GetCtl.Height
            .BckClr = GetCtl.BackColor
            .BckStl = GetCtl.BackStyle
            .BdrClr = GetCtl.BorderColor
            .BdrStl = GetCtl.BorderStyle
            .BdrWd = GetCtl.BorderWidth
            .SecNo = GetCtl.Tag
            .DisplayType = GetCtl.Shape
        End With
    ElseIf TypeOf GetCtl Is Label Then
        With UndoCtl(GetUndoNo).ctl
            .Name = GetCtl.Name
            .Index = GetCtl.Index
            .Left = GetCtl.Left
            .Top = GetCtl.Top
            .width = GetCtl.width
            .Height = GetCtl.Height
            .strText = GetCtl.Caption
            .Align = GetCtl.Alignment
            .BckClr = GetCtl.BackColor
            .BdrStl = GetCtl.BorderStyle
            .FntNam = GetCtl.FontName
            .FntBld = GetCtl.FontBold
            .FntItl = GetCtl.FontItalic
            .FntUnd = GetCtl.FontUnderline
            .FntSiz = GetCtl.FontSize
            .ForClr = GetCtl.ForeColor
            .SecNo = GetCtl.Tag
            .Fieldname = GetCtl.DataField
            .Type = GetCtl.LinkTimeout
        End With
    End If

End Sub

Public Sub RestoreFromUndoList(IsUndo As Boolean)
Dim i As Integer, j As Integer
    
    ReDim SelectedCtl(0)
    blnGroupSelected = False
    
    If IsUndo Then
        If CurrUndoPos > 0 Then
            CurrUndoPos = CurrUndoPos - 1
        End If
    Else
        If CurrUndoPos < UBound(UndoList) Then
            If UndoList(CurrUndoPos).Type <> unPlace Then
                CurrUndoPos = CurrUndoPos + 1
            End If
        Else
            Exit Sub
        End If
    End If
    
    If UndoList(CurrUndoPos).UndoCategory = unControl Then
        For i = 1 To UBound(UndoCtl)
            If UndoCtl(i).UndoIDNo = CurrUndoPos Then
                If UndoList(CurrUndoPos).Type = unPlace And IsUndo = False Then
                    ReCreateControl UndoCtl(i).ctl, False
                    Exit For
                End If
                For j = 0 To frmDesign.Controls.count - 1
                    If frmDesign.Controls(j).Tag = UndoCtl(i).ctl.SecNo Then
                        If frmDesign.Controls(j).Name = UndoCtl(i).ctl.Name And _
                            frmDesign.Controls(j).Index = UndoCtl(i).ctl.Index Then
                            If UndoList(CurrUndoPos).Type = unPlace Then
                                If IsUndo Then
                                    Unload frmDesign.Controls(j)
                                End If
                            ElseIf UndoList(CurrUndoPos).Type = unMove Then
                                If TypeOf frmDesign.Controls(j) Is Line Then
                                    frmDesign.Controls(j).X1 = UndoCtl(i).ctl.X1
                                    frmDesign.Controls(j).Y1 = UndoCtl(i).ctl.Y1
                                    frmDesign.Controls(j).X2 = UndoCtl(i).ctl.X2
                                    frmDesign.Controls(j).Y2 = UndoCtl(i).ctl.Y2
                                Else
                                    frmDesign.Controls(j).Left = UndoCtl(i).ctl.Left
                                    frmDesign.Controls(j).Top = UndoCtl(i).ctl.Top
                                End If
                            ElseIf UndoList(CurrUndoPos).Type = unResize Then
                                If TypeOf frmDesign.Controls(j) Is Line Then
                                    frmDesign.Controls(j).X1 = UndoCtl(i).ctl.X1
                                    frmDesign.Controls(j).Y1 = UndoCtl(i).ctl.Y1
                                    frmDesign.Controls(j).X2 = UndoCtl(i).ctl.X2
                                    frmDesign.Controls(j).Y2 = UndoCtl(i).ctl.Y2
                                Else
                                    frmDesign.Controls(j).Left = UndoCtl(i).ctl.Left
                                    frmDesign.Controls(j).Top = UndoCtl(i).ctl.Top
                                    frmDesign.Controls(j).width = UndoCtl(i).ctl.width
                                    frmDesign.Controls(j).Height = UndoCtl(i).ctl.Height
                                End If
                            End If
                        End If
                    End If
                Next j
            End If
        Next i
    ElseIf UndoList(CurrUndoPos).UndoCategory = unSection Then
        If UndoList(CurrUndoPos).Type = unSectWidth Then
        End If
    End If
    
    If UndoList(CurrUndoPos).Type = unPlace And IsUndo = False Then
        CurrUndoPos = CurrUndoPos + 1
    End If
    
    blnFirstUndo = False
    
End Sub

Private Sub ReCreateControl(ctl As ControlInfo, FromDelete As Boolean)
Dim i As Integer

    For i = 0 To frmDesign.Controls.count - 1
        If frmDesign.Controls(i).Name = ctl.Name Then
            If frmDesign.Controls(i).Index = ctl.Index Then
                Exit Sub
            End If
        End If
    Next i

    If ctl.Type = cLine Then
        With ctl
            Load frmDesign.Lin(.Index)
            Set frmDesign.Lin(.Index).Container = frmDesign.picSection(.SecNo)
            frmDesign.Lin(.Index).X1 = .X1
            frmDesign.Lin(.Index).Y1 = .Y1
            frmDesign.Lin(.Index).X2 = .X2
            frmDesign.Lin(.Index).Y2 = .Y2
            frmDesign.Lin(.Index).BorderColor = .BdrClr
            frmDesign.Lin(.Index).BorderStyle = .BdrStl
            frmDesign.Lin(.Index).BorderWidth = .BdrWd
            frmDesign.Lin(.Index).Tag = .SecNo
            frmDesign.Lin(.Index).Visible = True
        End With
    ElseIf ctl.Type = cBox Then
        With ctl
            Load frmDesign.Shape(.Index)
            Set frmDesign.Shape(.Index).Container = frmDesign.picSection(.SecNo)
            frmDesign.Shape(.Index).Left = .Left
            frmDesign.Shape(.Index).Top = .Top
            frmDesign.Shape(.Index).width = .width
            frmDesign.Shape(.Index).Height = .Height
            frmDesign.Shape(.Index).BorderColor = .BdrClr
            frmDesign.Shape(.Index).BorderStyle = .BdrStl
            frmDesign.Shape(.Index).BorderWidth = .BdrWd
            frmDesign.Shape(.Index).BackColor = .BckClr
            frmDesign.Shape(.Index).BackStyle = .BckStl
            frmDesign.Shape(.Index).Tag = .SecNo
            frmDesign.Shape(.Index).Shape = .DisplayType
            frmDesign.Shape(.Index).Visible = True
        End With
    ElseIf ctl.Type = cLabel Or ctl.Type = cDataField Or ctl.Type = cDatePageField Or _
        ctl.Type = cSumField Or ctl.Type = cCalcField Then
        Dim ctlLoaded As Control
        If ctl.Type = cLabel Then
            Load frmDesign.Label(ctl.Index)
            Set ctlLoaded = frmDesign.Label(ctl.Index)
        Else
            Load frmDesign.Field(ctl.Index)
            Set ctlLoaded = frmDesign.Field(ctl.Index)
        End If
        With ctl
            Set ctlLoaded.Container = frmDesign.picSection(.SecNo)
            ctlLoaded.Left = .Left
            ctlLoaded.Top = .Top
            ctlLoaded.width = .width
            ctlLoaded.Height = .Height
            ctlLoaded.BorderStyle = .BdrStl
            ctlLoaded.BackColor = .BckClr
            ctlLoaded.BackStyle = .BckStl
            ctlLoaded.FontName = .FntNam
            ctlLoaded.FontSize = .FntSiz
            ctlLoaded.FontBold = .FntBld
            ctlLoaded.FontItalic = .FntItl
            ctlLoaded.FontUnderline = .FntUnd
            ctlLoaded.Alignment = .Align
            ctlLoaded.Tag = .SecNo
            ctlLoaded.Caption = .strText
            ctlLoaded.LinkTimeout = .Type
            ctlLoaded.DataField = .Fieldname
            ctlLoaded.Visible = True
        End With
    End If

End Sub