oleautomationfrmmain.frm

个人VB学习源码精选,自己学习时的一些编程小程序,希望对大家有帮助

VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "OLE Automation Project"
   ClientHeight    =   5775
   ClientLeft      =   150
   ClientTop       =   720
   ClientWidth     =   7890
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5775
   ScaleWidth      =   7890
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton cmdReport 
      Caption         =   "Create &Report"
      Height          =   330
      Left            =   1980
      TabIndex        =   4
      Top             =   5175
      Width           =   1365
   End
   Begin VB.CommandButton cmdGraph 
      Caption         =   "Create &Graph"
      Height          =   330
      Left            =   315
      TabIndex        =   3
      Top             =   5175
      Width           =   1365
   End
   Begin VB.OLE ole 
      Height          =   3075
      Index           =   0
      Left            =   3555
      SizeMode        =   1  'Stretch
      TabIndex        =   2
      Top             =   1710
      Width           =   4110
   End
   Begin VB.OLE ole 
      Height          =   3075
      Index           =   1
      Left            =   210
      SizeMode        =   1  'Stretch
      TabIndex        =   1
      Top             =   1710
      Width           =   3165
   End
   Begin VB.OLE ole 
      Class           =   "Excel.Sheet.8"
      Height          =   1275
      Index           =   2
      Left            =   210
      OleObjectBlob   =   "OLEAutomationfrmMain.frx":0000
      SourceDoc       =   "D:\My Documents\DataBase_VBCode\ObjChp27.xls"
      TabIndex        =   0
      Top             =   225
      Width           =   7440
   End
   Begin VB.Menu mnuBar 
      Caption         =   "&File"
      Index           =   0
      Begin VB.Menu mnuFile 
         Caption         =   "&Open Objects"
         Index           =   0
      End
      Begin VB.Menu mnuFile 
         Caption         =   "&Save Objects"
         Index           =   1
      End
      Begin VB.Menu mnuFile 
         Caption         =   "-"
         Index           =   2
      End
      Begin VB.Menu mnuFile 
         Caption         =   "E&xit"
         Index           =   3
      End
   End
   Begin VB.Menu mnuBar 
      Caption         =   "&Edit"
      Index           =   1
      Begin VB.Menu mnuEdit 
         Caption         =   "Cu&t"
         Index           =   0
      End
      Begin VB.Menu mnuEdit 
         Caption         =   "&Copy"
         Index           =   1
      End
      Begin VB.Menu mnuEdit 
         Caption         =   "&Paste"
         Index           =   2
      End
      Begin VB.Menu mnuEdit 
         Caption         =   "-"
         Index           =   3
      End
      Begin VB.Menu mnuEdit 
         Caption         =   "Paste &Special"
         Index           =   4
      End
      Begin VB.Menu mnuEdit 
         Caption         =   "Insert &Object"
         Index           =   5
      End
   End
   Begin VB.Menu mnuDoc 
      Caption         =   "(POPUP)"
      Visible         =   0   'False
      Begin VB.Menu mnuDocPop 
         Caption         =   "&Generate"
         Index           =   0
      End
      Begin VB.Menu mnuDocPop 
         Caption         =   "&Copy"
         Index           =   1
      End
      Begin VB.Menu mnuDocPop 
         Caption         =   ""
         Index           =   2
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Enum eOLEContainer
    icWordDoc = 0
    icMSGGraph = 1
    icExcelSheet = 2
End Enum
Dim oleChanged(3) As Integer
Private Const cAppTitle = "OLE Automation Project"
Private Function CreateSpiel(a1 As Long, a2 As Long) As String
    Dim res As String
    Dim spiel As String
    
    Select Case Sgn(a1 - a2)
        Case -1
            res = " Although sales declined overall for the year, "
            res = res & "we anticipate phenomenal growth next year! "
        Case 0
            res = " Sales were declined overall for the year. "
            res = res & "The strengthening economy will help us set "
            res = res & "new productivity records next year! "
        Case 1
            res = "Sales were up, up, up! We had a fantastic year, with "
            res = res & "even better prospects for next year! "
    End Select
    spiel = "Our five year goals have been met."
    spiel = spiel & "PSA has experienced tremendous growth over the past "
    spiel = spiel & "five years,and our higher level of partnership with "
    spiel = spiel & "of growth in the future!" & Chr(13)
    spiel = spiel & "Set your sights high! The past year's sales results "
    spiel = spiel & "are quite encouraging."
    spiel = spiel & res
    
    CreateSpiel = spiel
End Function

Private Sub cmdGraph_Click()
    Dim QuarterlyFigures As String
    
    ole(icExcelSheet).DoVerb vbOLEHide
    ole(icExcelSheet).object.Sheets("Sheet1").Range("QuarterlyFigures").Copy
    AppActivate cAppTitle
    QuarterlyFigures = Clipboard.GetText()
    
    ole(icMSGGraph).CreateEmbed "", "MSGraph.Chart"
    ole(icMSGGraph).DoVerb vbOLEHide
    ole(icMSGGraph).Format = "CF_TEXT"
    ole(icMSGGraph).DataText = QuarterlyFigures
    ole(icMSGGraph).Update
End Sub

Private Sub cmdReport_Click()
    MousePointer = vbHourglass
    ReDim q(4) As Long
    Dim wordProc As Object
    Dim avg1 As Long, avg2 As Long
    Static bCreateOrGet As Long
    Dim i As Long
    Dim textToSet As String
    
    ole(icExcelSheet).DoVerb vbOLEHide
    
    For i = 1 To 4
        q(i) = ole(icExcelSheet).object.Sheets("Sheet1").Range("SalesFigures").Cells(1, i).Value
    Next i
    AppActivate cAppTitle
    avg1 = (q(1) + q(2)) / 2
    avg2 = (q(3) + q(4)) / 2
    textToSet = CreateSpiel(avg1, avg2)
    'bCreateOrGet = True
    If bCreateOrGet = False Then
        Set wordProc = CreateObject("Word.Basic")
        wordProc.filenew
    Else
        Set wordProc = GetObject(App.Path & "\CHP27BLK.doc", "Word.Basic")
        bCreateOrGet = False
    End If
    DoEvents
    wordProc.filepagesetup 0, 0, 0.2, 0.2, 0.2, 0.2, 0, "1.6 in", "10 in"
    wordProc.Insert textToSet
    wordProc.editselectall
    wordProc.formatparagraph 0.1, 0.1, 0.1, 8, 0, 0, 3
    wordProc.formatfont 8
    wordProc.startofdocument
    wordProc.formatdropcap 1, , 2, 1
    wordProc.filesaveas App.Path & "\oledoc.dat"
    wordProc.filecloseall 2
    
    ole(icWordDoc).OLETypeAllowed = vbOLEEither
    ole(icWordDoc).CreateEmbed App.Path & "\oledoc.dat", "Word.Document"
    MousePointer = vbDefault
End Sub

Private Sub Form_Load()
    Dim i As Long
    
    For i = icWordDoc To icExcelSheet
        ole(i).HostName = cAppTitle
        ole(i).DisplayType = vbOLEDisplayContent
    Next i
    
    ole(icWordDoc).AutoVerbMenu = False
    ole(icMSGGraph).AutoVerbMenu = True
    ole(icExcelSheet).AutoVerbMenu = True
End Sub

Private Sub mnuBar_Click(Index As Integer)
    Dim i As Long
    
    Select Case Index
        Case 0
            mnuFile(1).Enabled = False
            For i = icWordDoc To icExcelSheet
                If oleChanged(i) = True Then
                    mnuFile(i).Enabled = True
                End If
            Next i
        Case 1
            For i = 0 To 5
                If (i <> 3) Then mnuEdit(i).Enabled = False
            Next i
            
            Dim s As Control
            Set s = Screen.ActiveControl
            If TypeOf s Is ole Then
                mnuEdit(5).Enabled = True
                If s.OLEType <> vbOLENone Then
                    mnuEdit(0).Enabled = True
                    mnuEdit(1).Enabled = True
                End If
                If s.PasteOK Then
                    mnuEdit(2).Enabled = True
                    mnuEdit(4).Enabled = True
                End If
            End If
    End Select
End Sub

Private Sub mnuDocPop_Click(Index As Integer)
    Dim i As Long
    
    On Error GoTo noMoreItems
    i = 3
    Do
        Unload mnuDocPop(i)
        i = i + 1
    Loop
noMoreItems:
    On Error GoTo 0
    Select Case Index
        Case 0
            cmdReport_Click
        Case 1
            mnuEdit_Click 1
        Case 2
        Case Is > 2
            ole(icWordDoc).DoVerb Index - 2
    End Select
End Sub

Private Sub mnuEdit_Click(Index As Integer)
    frmMain.MousePointer = vbHourglass
    
    Dim s As Control
    Set s = Screen.ActiveControl
    If TypeOf s Is ole Then
    Select Case Index
        Case 0
            If Not s.AppIsRunning Then
            '此处用 s.DoVerb vbOLEHide 显示错误对象没有运行
                s.DoVerb vbOLEShow
            End If
            s.Copy
            s.Delete
        Case 1
            If Not s.AppIsRunning Then
                s.DoVerb vbOLEShow
            End If
            s.Copy
        Case 2
            s.Class = "temp"
            s.Paste
        Case 3
        Case 4
            s.PasteSpecialDlg
        Case 5
            s.InsertObjDlg
        Case 6
    End Select
    If s.OLEType <> vbOLENone Then
        s.Close
        s.Refresh
    End If
    End If
    frmMain.MousePointer = vbDefault
End Sub

Private Sub mnuFile_Click(Index As Integer)
    Dim fileNum As Long
    Dim i As Long
    
    Select Case Index
        Case 0
            fileNum = FreeFile
            Open App.Path & "\oleobject1.dat" For Binary As fileNum
            For i = icWordDoc To icExcelSheet
                If ole(i).OLEType <> vbOLENone Then
                    ole(i).ReadFromFile fileNum
                End If
                oleChanged(i) = False
            Next i
            Close fileNum
        Case 1
            fileNum = FreeFile
            Open App.Path & "\oleobject1.dat" For Binary As fileNum
            For i = icWordDoc To icExcelSheet
                If ole(i).OLEType <> vbOLENone Then
                '此处重复保存，保存的为第一次保存的结果
                    ole(i).SaveToFile fileNum
                End If
                oleChanged(i) = False
            Next i
            Close fileNum
        Case 2
        Case 3
            Unload Me
    End Select
End Sub

Private Sub ole_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim i As Long
    
    If Button = 2 And Index = icWordDoc And ole(icWordDoc).OLEType <> vbOLENone Then
        ole(icWordDoc).FetchVerbs
        For i = 1 To ole(icWordDoc).ObjectVerbsCount - 1
            Load mnuDocPop(2 + i)
            mnuDocPop(2 + i).Caption = ole(icWordDoc).ObjectVerbs(i)
        Next i
        PopupMenu mnuDoc
    End If
End Sub


Private Sub ole_Resize(Index As Integer, HeightNew As Single, WidthNew As Single)
    If Index = icWordDoc Then
        If HeightNew > 2600 Then HeightNew = 2600
        If WidthNew > 3900 Then WidthNew = 3900
    End If
End Sub

Private Sub ole_Updated(Index As Integer, Code As Integer)
    If Code = 0 Then oleChanged(Index) = True
End Sub