save.frm

VB6数据库开发指南》的配套源程序

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.1#0"; "COMDLG32.OCX"
Begin VB.Form frmReportWriter 
   BackColor       =   &H00C0C0C0&
   Caption         =   "Visual Report Writer"
   ClientHeight    =   5190
   ClientLeft      =   1110
   ClientTop       =   1530
   ClientWidth     =   7320
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   5190
   ScaleWidth      =   7320
   Begin VB.PictureBox picHead 
      Align           =   1  'Align Top
      Appearance      =   0  'Flat
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   540
      Left            =   0
      ScaleHeight     =   540
      ScaleWidth      =   7320
      TabIndex        =   4
      Top             =   0
      Width           =   7320
      Begin VB.CommandButton cmdQuit 
         Caption         =   "&Quit"
         Height          =   495
         Left            =   6240
         TabIndex        =   2
         Top             =   0
         Width           =   972
      End
      Begin VB.CommandButton cmdReport 
         Caption         =   "&Create Report"
         Default         =   -1  'True
         Height          =   495
         Left            =   120
         TabIndex        =   0
         Top             =   0
         Width           =   1212
      End
      Begin VB.Label lblStatus 
         Alignment       =   2  'Center
         BorderStyle     =   1  'Fixed Single
         Height          =   375
         Left            =   1440
         TabIndex        =   1
         Top             =   120
         Width           =   3375
      End
   End
   Begin MSComDlg.CommonDialog dlgChapter10 
      Left            =   6240
      Top             =   0
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   327680
      CancelError     =   -1  'True
      DefaultExt      =   "MDB"
      DialogTitle     =   "BIBLIO.MDB Location"
      FileName        =   "Chapter10.mdb"
      Filter          =   "Chapter10 Database (Chapter10.mdb)|Chapter10.mdb|All Files (*.*)|*.*|"
   End
   Begin VB.OLE oleWord 
      Class           =   "Word.Document.8"
      Height          =   4452
      Left            =   120
      OLETypeAllowed  =   1  'Embedded
      TabIndex        =   3
      Top             =   600
      Width           =   7092
   End
   Begin VB.Menu mnuFratsaBlatz 
      Caption         =   "&FratsaBlatz"
      NegotiatePosition=   1  'Left
      Visible         =   0   'False
   End
End
Attribute VB_Name = "frmReportWriter"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim mobjWord As Object

Dim strColumnTabs(6) As String
Dim strColumnHeaders(7) As String
Dim strColumnWidths(7) As String

'OLE Control Constants
Const OLE_Activate As Integer = 7
Const OLE_Deactivate As Integer = 9


Sub PrintColHeaders(Tabs() As String, ColHeaders() As String)
    Dim intIdx As Integer
    
    'Assumes cursor is at the beginning of the proper location
    mobjWord.InsertPara
    mobjWord.LineUp
    mobjWord.FormatParagraph Before:="12 pt", _
        After:="6 pt"
    For intIdx = 0 To UBound(Tabs)
        mobjWord.FormatTabs Position:=Tabs(intIdx) + Chr$(34), _
            Align:=0
    Next
    For intIdx = 0 To UBound(ColHeaders) - 1
        mobjWord.Insert ColHeaders(intIdx) + Chr$(9)
    Next
    
    With mobjWord
        .StartOfLine
        .SelectCurSentence
        .CharRight 1, 1
        .FormatFont Points:="12", _
            Font:="Times New Roman", _
            Bold:=1
        .FormatBordersAndShading ApplyTo:=0, _
            BottomBorder:=2
        .LineDown
    End With
End Sub

Sub PrintFooter(Company As String)

    'Insert the report footer
    mobjWord.ViewFooter
    mobjWord.FormatTabs ClearAll:=1
    mobjWord.FormatTabs Position:="7.0" + Chr$(34), _
        DefTabs:="0.5" + Chr$(34), _
        Align:=2, _
        Leader:=0
    mobjWord.StartOfLine
    mobjWord.Insert Company + Chr$(9) + "Page "
    mobjWord.InsertPageField
    mobjWord.SelectCurSentence
    mobjWord.FormatFont Points:="12", _
        Font:="Times New Roman", _
        Bold:=1

    mobjWord.ViewFooter
End Sub

Sub PrintReportTitle(Title As String)
    With mobjWord
        .StartOfDocument
        .InsertPara
        .StartOfDocument
        .Insert Title
        .StartOfLine
        .SelectCurSentence
        .FormatFont Points:="18", _
            Font:="Times New Roman", _
            Bold:=1, _
            Italic:=1
        .CenterPara
    
        .FormatBordersAndShading ApplyTo:=0, _
            Shadow:=0
    
        'Leave the cursor on the following line
        .LineDown
    End With
End Sub

Sub SetColumns()
    Dim intIdx As Integer
    
    strColumnHeaders(0) = "ID"
    strColumnTabs(0) = "0.5"
    strColumnHeaders(1) = "Employee"
    strColumnTabs(1) = "1.25"
    strColumnHeaders(2) = "Type"
    strColumnTabs(2) = "2.0"
    strColumnHeaders(3) = "Amount"
    strColumnTabs(3) = "2.75"
    strColumnHeaders(4) = "Description"
    strColumnTabs(4) = "4.0"
    strColumnHeaders(5) = "Purchased"
    strColumnTabs(5) = "5.0"
    strColumnHeaders(6) = "Submitted"
    strColumnTabs(6) = "6.5"
    
    For intIdx = LBound(strColumnTabs) To UBound(strColumnTabs)
        If intIdx Then
            strColumnWidths(intIdx) = Str$(Val(strColumnTabs(intIdx)) - Val(strColumnTabs(intIdx - 1)))
        Else
            strColumnWidths(intIdx) = strColumnTabs(intIdx)
        End If
    Next
End Sub

Sub Status(txtCaption)
    lblStatus.Caption = txtCaption
    lblStatus.Refresh
End Sub

Private Sub cmdQuit_Click()
    
    Status "Ending application"
    Unload Me
    
End Sub

Private Sub cmdReport_Click()
    Dim strTitle As String
    Dim intIdx As Integer
    Dim strInsertText As String
    Dim strFileName As String
    Dim uexpExpDetail As New ExpenseDetail
    Dim strResponse As String
    
    Status "Opening database table"
    
    'If this is the first time running, put the application
    'path in the common dialog as the initial directory
    If dlgChapter10.InitDir = "" Then
        dlgChapter10.InitDir = App.Path
        dlgChapter10.filename = dlgChapter10.InitDir & "\" & dlgChapter10.filename
    End If
    
    dlgChapter10.InitDir = App.Path
    On Error GoTo ExpDetailError
    Do While Dir(dlgChapter10.filename) = ""
        dlgChapter10.ShowOpen
    Loop

    uexpExpDetail.strDbName = dlgChapter10.filename
    
    Status "Creating a new Word document"
    
    mobjWord.FileNew
    strTitle = "Expense Details"
    
    Status "Inserting header and footer information"
    PrintHeader strTitle, strColumnTabs(), strColumnHeaders()
    PrintFooter "Enlighthened Software, Inc."
    PrintReportTitle strTitle
    PrintColHeaders strColumnTabs(), strColumnHeaders()
    
    'Start printing the report
    Status "Adding data to report"
    mobjWord.TableInsertTable NumColumns:=7, _
        NumRows:=2, _
        InitialColWidth:="2 in"
    For intIdx = 0 To 7
        With mobjWord
            .TableSelectColumn
            .TableColumnWidth ColumnWidth:=strColumnWidths(intIdx)
            .NextCell
            .NextCell
        End With
    Next
    
    'Format the paragraph height
    mobjWord.TableSelectTable
    mobjWord.FormatParagraph Before:="6 pt"
    
    'Select the first cell in the table
    'mobjWord.TableSelectColumn
    mobjWord.NextCell
    
    strResponse = uexpExpDetail.MoveFirst
    
    Do While "EOF" <> strResponse
        With mobjWord
            strInsertText = CStr(uexpExpDetail.lngExpenseId)
            .Insert strInsertText
            .NextCell
            strInsertText = uexpExpDetail.strEmployeeId
            .Insert strInsertText
            .NextCell
            strInsertText = uexpExpDetail.strExpenseType
            .Insert strInsertText
            .NextCell
            strInsertText = Format$(uexpExpDetail.curAmountSpent, "Currency")
            .Insert strInsertText
            .NextCell
            strInsertText = uexpExpDetail.strDescription
            .Insert strInsertText
            .NextCell
            strInsertText = Format$(uexpExpDetail.dtmDatePurchased, "General Date")
            .Insert strInsertText
            .NextCell
            strInsertText = Format$(uexpExpDetail.dtmDateSubmitted, "General Date")
            .Insert strInsertText
            .NextCell
            .TableInsertRow
        End With
        strResponse = uexpExpDetail.MoveNext
    Loop
    
    'Save the Word document
    mobjWord.ToolsOptionsSave SummaryPrompt:=0
    
    strFileName = App.Path & "\TempRpt.doc"
    'Word won't let us save a file over an existing document
    If Len(Dir(strFileName)) Then
        Kill strFileName
    End If
    mobjWord.FileSaveAs Name:=strFileName
    
    oleWord.CreateEmbed strFileName
    oleWord.Refresh
    
    Status "Report complete"
    
    Exit Sub
    
ExpDetailError:
    MsgBox Err.Description & Chr(13) & "from " & Err.Source _
            & " -- Number: " & CStr(Err.Number)
    Exit Sub
    
End Sub


Sub PrintHeader(Title As String, Tabs() As String, ColHeaders() As String)
    Dim intIdx As Integer

    With mobjWord
        'For now, set DifferentFirstPage to no
        .FilePageSetup TopMargin:="0.8" + Chr$(34), _
            BottomMargin:="0.8" + Chr$(34), _
            LeftMargin:="0.75" + Chr$(34), _
            RightMargin:="0.75" + Chr$(34), _
            ApplyPropsTo:=4, _
            DifferentFirstPage:=0
    End With
                            
    'Insert the report header
    With mobjWord
        .ViewHeader
        .FormatTabs ClearAll:=1
        .FormatTabs Position:="7.0" + Chr$(34), _
            DefTabs:="0.5" + Chr$(34), _
            Align:=2
        .StartOfLine
        .SelectCurSentence
        .CharRight 1, 1
        .FormatFont Points:="12", _
            Font:="Times New Roman", _
            Bold:=1
        .StartOfLine
        .Insert Title + Chr$(9)
        .InsertDateTime DateTimePic:="d' 'MMMM', 'yyyy", _
            InsertAsField:=0
        .InsertPara
        .InsertPara
    End With
    
    PrintColHeaders Tabs(), ColHeaders()
    
    mobjWord.ViewHeader   'Closes if it is open
    
    'Now set DifferentFirstPage
    mobjWord.FilePageSetup DifferentFirstPage:=1
    
End Sub

Private Sub cmdSave_Click()
    WordFileSave oleWord
End Sub


Sub WordFileSave(OLECtrl As Control)
    Dim objWord As Object
    Dim objWordBasic As Object
    
    'Activate the OLE control, and copy to the Clipboard
    Status "Copying report to clipboard"
    Screen.MousePointer = vbHourglass
    
    'Set up the properties for the FileSave common dialog
    'and open to get the file save name
    Status "Setting up file save"
    dlgChapter10.Filter = "Word Document (*.Doc)|*.doc"
    dlgChapter10.DefaultExt = "doc"
    dlgChapter10.filename = oleWord.SourceDoc
    On Error GoTo FileSaveCancel:
    dlgChapter10.Action = 2
    
    'Check to see if the file exists - if it does, need new
    'name for the file - Word can't overwrite an existing file
    Do While Len(Dir$(dlgChapter10.filename))
        MsgBox "Please choose a new name for the file."
        dlgChapter10.Action = 2
    Loop
    On Error GoTo 0

    
    
    oleWord.Action = OLE_Activate
    oleWord.object.ActiveDocument.SaveAs dlgChapter10.filename
    Set objWordBasic = CreateObject("Word.Basic")
    objWordBasic.EditSelectAll
    objWordBasic.EditCopy
    oleWord.Action = OLE_Deactivate
    
    
    'Use a new instance of Word to save the document
    Status "Saving Word document"
    Set objWordBasic = Nothing
    Set objWord = GetObject("", "Word.Document.6")
    Set objWordBasic = objWord.Application.WordBasic
    objWordBasic.FileNew
    objWordBasic.EditPaste
    objWordBasic.FileSaveAs dlgChapter10.filename
    objWordBasic.FileClose
    
    'Release the objects created in this procedure
    Status "Report saved"
    Set objWordBasic = Nothing
    Set objWord = Nothing
    
    Exit Sub
    
FileSaveCancel:
    Select Case Err.Number
        Case 32755
            'User pressed cancel
            Status "Save canceled by user"
            Exit Sub
        Case Else
            Error Err.Number
    End Select
End Sub

Private Sub Form_Load()
    Status "Creating a Word object"
    Me.Show
    Me.Refresh
    
    'Create a Microsoft Word object
    Set mobjWord = GetObject("", "Word.Basic")
    mobjWord.AppMinimize ("Microsoft Word")
    
    cmdReport.Enabled = True
    cmdQuit.Enabled = True
    
    'Set up standard layout information
    Call SetColumns
    
    Status "Click on Create Report to create the report."
End Sub

Private Sub Form_Resize()
    Dim intBorder As Integer
    Dim intWindowWidth As Integer
    
    intBorder = picHead.Height
    intWindowWidth = Me.ScaleWidth
    
    cmdReport.Height = intBorder
    cmdQuit.Height = intBorder
    
    cmdQuit.Left = intWindowWidth - cmdQuit.Width - cmdReport.Left
'fix    cmdSave.Left = cmdQuit.Left - cmdReport.Left - cmdSave.Width
    lblStatus.Width = cmdQuit.Left - lblStatus.Left - cmdReport.Left
    lblStatus.Top = (picHead.Height - lblStatus.Height) / 2
    
    oleWord.Left = intBorder
    oleWord.Width = Me.ScaleWidth - 2 * intBorder
    oleWord.Height = Me.ScaleHeight - oleWord.Top - intBorder
    
End Sub


Private Sub Form_Unload(Cancel As Integer)
    'Shut down Word
    Set mobjWord = Nothing
End Sub