frmdesign.frm

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

   Begin VB.Shape Grip 
      BackColor       =   &H8000000D&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H8000000D&
      Height          =   90
      Index           =   3
      Left            =   11280
      Top             =   1230
      Visible         =   0   'False
      Width           =   90
   End
   Begin VB.Shape Grip 
      BackColor       =   &H8000000D&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H8000000D&
      Height          =   90
      Index           =   2
      Left            =   11100
      Top             =   1230
      Visible         =   0   'False
      Width           =   90
   End
   Begin VB.Shape Grip 
      BackColor       =   &H8000000D&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H8000000D&
      Height          =   90
      Index           =   0
      Left            =   10740
      Top             =   1230
      Visible         =   0   'False
      Width           =   90
   End
   Begin VB.Shape Grip 
      BackColor       =   &H8000000D&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H8000000D&
      Height          =   90
      Index           =   1
      Left            =   10920
      Top             =   1230
      Visible         =   0   'False
      Width           =   90
   End
   Begin VB.Line Lin 
      Index           =   0
      Visible         =   0   'False
      X1              =   7.458
      X2              =   8.186
      Y1              =   1.604
      Y2              =   1.604
   End
   Begin VB.Menu FileMenu 
      Caption         =   "File"
      Begin VB.Menu NewFile 
         Caption         =   "New"
      End
      Begin VB.Menu OpenFile 
         Caption         =   "Open..."
      End
      Begin VB.Menu SaveFile 
         Caption         =   "Save"
      End
      Begin VB.Menu SaveFileAs 
         Caption         =   "Save As..."
      End
      Begin VB.Menu PageSet 
         Caption         =   "Page Setup..."
      End
      Begin VB.Menu prnt 
         Caption         =   "Print..."
      End
      Begin VB.Menu PrntPrev 
         Caption         =   "Print Preview..."
      End
      Begin VB.Menu ExitProg 
         Caption         =   "Exit"
      End
   End
   Begin VB.Menu EditMenu 
      Caption         =   "Edit"
      Begin VB.Menu mnuUndo 
         Caption         =   "Undo"
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuRedo 
         Caption         =   "Redo"
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuCutObj 
         Caption         =   "Cut"
      End
      Begin VB.Menu mnuCopyObj 
         Caption         =   "Copy"
      End
      Begin VB.Menu mnuPasteObj 
         Caption         =   "Paste"
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuDelObj 
         Caption         =   "Delete..."
         Enabled         =   0   'False
      End
   End
   Begin VB.Menu ViewMenu 
      Caption         =   "View"
      Begin VB.Menu PageHdFt 
         Caption         =   "Page Header/Footer"
         Checked         =   -1  'True
      End
      Begin VB.Menu RepHdFt 
         Caption         =   "Report Header/Footer"
         Checked         =   -1  'True
      End
   End
   Begin VB.Menu ToolsMenu 
      Caption         =   "Tools"
      Begin VB.Menu GridSpacing 
         Caption         =   "Design Grid Settings..."
      End
      Begin VB.Menu DataConn 
         Caption         =   "Connect to Data Source..."
      End
   End
   Begin VB.Menu HelpMenu 
      Caption         =   "Help"
      Begin VB.Menu mnuAbout 
         Caption         =   "About..."
      End
   End
   Begin VB.Menu ReportObjectPopUp 
      Caption         =   ""
      Visible         =   0   'False
      Begin VB.Menu EditText 
         Caption         =   "Edit Text"
         Visible         =   0   'False
      End
      Begin VB.Menu EditCalc 
         Caption         =   "Edit Calculation..."
         Visible         =   0   'False
      End
      Begin VB.Menu EditSummary 
         Caption         =   "Edit Summary Field..."
         Visible         =   0   'False
      End
      Begin VB.Menu EditDatePage 
         Caption         =   "Edit Date/Page Field..."
         Visible         =   0   'False
      End
      Begin VB.Menu AssignField 
         Caption         =   "Assign Data Field..."
         Visible         =   0   'False
      End
      Begin VB.Menu FormatText 
         Caption         =   "Set Data Format..."
         Visible         =   0   'False
      End
      Begin VB.Menu CutObj 
         Caption         =   "Cut"
         Enabled         =   0   'False
      End
      Begin VB.Menu CopyObj 
         Caption         =   "Copy"
         Enabled         =   0   'False
      End
      Begin VB.Menu PasteObj 
         Caption         =   "Paste"
         Enabled         =   0   'False
      End
      Begin VB.Menu DelObj 
         Caption         =   "Delete..."
         Enabled         =   0   'False
      End
      Begin VB.Menu BringFront 
         Caption         =   "Bring to front"
      End
      Begin VB.Menu SendBack 
         Caption         =   "Send to back"
      End
      Begin VB.Menu ToggleSnap 
         Caption         =   "Grid Snap"
      End
      Begin VB.Menu SetBackColor 
         Caption         =   "Set Background Color..."
      End
      Begin VB.Menu chk3d 
         Caption         =   "Sunken"
      End
      Begin VB.Menu ChkOptions 
         Caption         =   "Display as..."
         Visible         =   0   'False
         WindowList      =   -1  'True
         Begin VB.Menu chkCheck 
            Caption         =   "Check Box"
         End
         Begin VB.Menu chkRadio 
            Caption         =   "Radio Button"
         End
         Begin VB.Menu chkX 
            Caption         =   "X Box"
         End
         Begin VB.Menu Rect 
            Caption         =   "Rectangle"
         End
         Begin VB.Menu Sqre 
            Caption         =   "Square"
         End
         Begin VB.Menu Ellipse 
            Caption         =   "Oval"
         End
         Begin VB.Menu Circ 
            Caption         =   "Circle"
         End
         Begin VB.Menu RRect 
            Caption         =   "Rounded Rectangle"
         End
         Begin VB.Menu RSqr 
            Caption         =   "Rounded Square"
         End
      End
      Begin VB.Menu TxtBordToggle 
         Caption         =   "Border"
         Visible         =   0   'False
      End
   End
End
Attribute VB_Name = "frmDesign"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim TopOfDesForm As Single
Dim ToolX As Single

'=========== Mouse Tracking ==============
Dim blnMouseIsDown As Boolean           'indicates if mouse button is pressed
Dim StartX As Single                    'mouse X-coord when button pressed
Dim StartY As Single                    'mouse Y-coord when button pressed
Dim dX1 As Single                       'saves distance from mouse to left of object (or line X1)
Dim dY1 As Single                       'saves distance from mouse to top of object (or line Y1)
Dim dX2 As Single                       'saves distance from mouse to line X2
Dim dY2 As Single                       'saves distance from mouse to line Y2
Dim blnAtLimit As Boolean

'============ Page Measurement Ruler Arrays =============
Dim recVSclText(100) As Rect             'holds values for vertical scale text rectangles
Dim recHSclText(100) As Rect             'holds values for horizontal scale text rectangles

Private Type DrawOrder  'sets/gets draw order for objects on the page
    ctlName As String
    ctlIndex As Integer
End Type

Dim DrawList() As DrawOrder
Dim dLstCount As Integer        'sets/gets the current number of control objects

Dim blnFormLoad As Boolean
Dim blnCreatingImageControl As Boolean
Dim blnCreatingBoundImageControl As Boolean
Dim blnCreatingField As Boolean
Dim SetColorMode As Integer
Dim OldBound As Integer
Dim NewBound As Integer
Dim FLen As Long
Dim PgFreeWid As Single

Dim ScaleStartX As Single
Dim ScaleStartY As Single
Dim ScaleEndX As Single
Dim ScaleEndY As Single
Dim ScaleLastX As Long
Dim ScaleLastY As Long

Private Sub GetTextFormat()
'gets the format of the currently selected text control
Dim i As Integer

    If blnControlSelected Then
        If TypeOf ctlActive Is Label Then
            cboFontSize = Round(ctlActive.FontSize, 0)
            Toolbar2.Buttons(2).value = -ctlActive.FontBold
            Toolbar2.Buttons(3).value = -ctlActive.FontItalic
            Toolbar2.Buttons(4).value = -ctlActive.FontUnderline
            For i = 6 To 8
                If Val(Toolbar2.Buttons(i).Tag) = ctlActive.Alignment Then
                    Toolbar2.Buttons(i).value = tbrPressed
                Else
                    Toolbar2.Buttons(i).value = tbrUnpressed
                End If
            Next i
            FontSelector1.FontFace = ctlActive.FontName
        End If
    End If

End Sub

Private Sub AssignField_Click()
'If a regular data field has been clicked call SetDataField
    
    If ctlActive.LinkTimeout = cDataField Then
        SetDataField
    End If

End Sub

Private Sub SetDataField()
'opens frmSelField for assigning a data source to a field - if a valid data connection exists

    If frmSelField.lstFields.ListItems.count > 0 Then   'lstFields is only filled when data source has been established
        frmSelField.Left = (ctlActive.Left + picSection(ctlActive.Tag).Left + picContainer.Left) * 1440 _
            + Me.Left
        frmSelField.Top = (ctlActive.Top + ctlActive.Height + picSection(ctlActive.Tag).Top + picContainer.Top) * 1440 _
             + Me.Top + 800
        frmSelField.lstFields.Visible = True
        frmSelField.Caption = "Select Field from [" & strTableName & "]"
        frmSelField.Show vbModal
    Else
        If lngState <> MoveGrip Then        'don't want to trigger when field is just being resized
            MsgBox "You need to connect to a database and select a" & Chr$(13) & _
            "table or query to retrieve a list of fields to use." & Chr$(13) & Chr$(13) _
            & "Click on Connect to Database in the Tools menu.", _
            vbInformation, "No Fields Available"
        End If
    End If

End Sub

Private Sub BringFront_Click()
'brings the currently selected control to the front (on top of all other controls - drawn last)

Dim i As Integer
Dim SaveName As String, SaveIndex As Integer, SaveLoc As Integer
Dim Last As Long

    ctlActive.ZOrder (0)    'set the selected controls ZOrder to 0 (puts it on top)
    SaveName = ctlActive.Name       'save the selected controls name and control array index no.
    SaveIndex = ctlActive.Index

    Last = UBound(DrawList)

    For i = 0 To Last       'loop through draw order list and find the selected control
        If DrawList(i).ctlName = SaveName And DrawList(i).ctlIndex = SaveIndex Then
            SaveLoc = i     'if found, save the location and exit the loop
            Exit For
        End If
    Next i

    For i = 0 To Last           'loop through the draw order list and move all the controls after the selected control
        If i > SaveLoc Then     'up one so that selected control can be moved to the end
            DrawList(i - 1).ctlName = DrawList(i).ctlName
            DrawList(i - 1).ctlIndex = DrawList(i).ctlIndex
        End If
    Next i

    DrawList(Last).ctlName = SaveName