olefrmmain.frm

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

VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "OLE Container Project"
   ClientHeight    =   6600
   ClientLeft      =   150
   ClientTop       =   720
   ClientWidth     =   5580
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6600
   ScaleWidth      =   5580
   StartUpPosition =   3  '窗口缺省
   Begin VB.OLE ole 
      AutoVerbMenu    =   0   'False
      Height          =   6540
      Left            =   173
      TabIndex        =   0
      Top             =   0
      Width           =   5235
   End
   Begin VB.Menu mnuBar 
      Caption         =   "&File"
      Index           =   0
      Begin VB.Menu mnuFile 
         Caption         =   "&Open Object"
         Index           =   0
      End
      Begin VB.Menu mnuFile 
         Caption         =   "&Save Object"
         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
      Begin VB.Menu mnuEdit 
         Caption         =   "-"
         Index           =   6
      End
      Begin VB.Menu mnuEdit 
         Caption         =   "&Info"
         Index           =   7
      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 oleChanged As Long
Private Const cAppTitle = "OLE container Project"

Private Sub Form_Load()
    Me.Caption = cAppTitle
    ole.HostName = cAppTitle
    ole.DisplayType = vbOLEDisplayContent
    ole.AutoVerbMenu = True
    'ole.SizeMode = 1
End Sub

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

Private Sub mnuEdit_Click(Index As Integer)
    frmMain.MousePointer = vbHourglass
    
    Dim ctlScrnControl As Control
    Set ctlScrnControl = Screen.ActiveControl
    Select Case Index
        Case 0
            If Not ctlScrnControl.AppIsRunning Then
                ctlScrnControl.DoVerb vbOLEShow
            End If
            ctlScrnControl.Copy
            ctlScrnControl.Delete
        Case 1
            If Not ctlScrnControl.AppIsRunning Then
                ctlScrnControl.DoVerb vbOLEShow
            End If
            ctlScrnControl.Copy
        Case 2
            ctlScrnControl.Class = "Temp"
            ctlScrnControl.Paste
        Case 3
        Case 4
            ctlScrnControl.PasteSpecialDlg
        Case 5
            ctlScrnControl.InsertObjDlg
        Case 6
        Case 7
            PrintInfo ctlScrnControl
    End Select
    If ctlScrnControl.OLEType <> vbOLENone Then
        ctlScrnControl.Close
        ctlScrnControl.Refresh
    End If
    frmMain.MousePointer = vbDefault
    MsgBox ctlScrnControl.OLEType
End Sub

Private Sub mnuFile_Click(Index As Integer)
    Dim fileNum As Long, i As Long
    
    Select Case Index
    Case 0
        fileNum = FreeFile
        Open App.Path & "\oleobj.dat" For Binary As fileNum
        'If ole.OLEType <> vbOLENone Then
            ole.ReadFromFile fileNum
        'End If
        oleChanged = False
        Close fileNum
        MsgBox ole.OLEType
    Case 1
        fileNum = FreeFile
        Open App.Path & "\oleobj.dat" For Binary As fileNum
        If ole.OLEType <> vbOLENone Then
            ole.SaveToFile fileNum
        End If
        oleChanged = False
        Close fileNum
        MsgBox ole.OLEType
    Case 2
    Case 3
        Unload Me
    End Select
End Sub

Private Sub ole_Resize(HeightNew As Single, WidthNew As Single)
    If HeightNew > 2772 Then HeightNew = 2772
    If WidthNew > 2532 Then WidthNew = 2532
End Sub

Private Sub ole_Updated(Code As Integer)
    If Code = 0 Then oleChanged = True
End Sub
Private Sub PrintInfo(ctlScrnControl As Control)
    Dim i As Long
    
    If Not ctlScrnControl.AppIsRunning Then
        ctlScrnControl.DoVerb vbOLEShow
    End If
    
    frmInfo.Cls
    frmInfo.Show
    frmInfo.Print
    frmInfo.Print "Class:";
    frmInfo.Print Tab(20); ctlScrnControl.Class
    frmInfo.Print
    frmInfo.Print "Accept Formats:";
    For i = 0 To ctlScrnControl.ObjectAcceptFormatsCount - 1
        frmInfo.Print Tab(20); ctlScrnControl.ObjectGetFormats(i)
    Next i
    frmInfo.Print
    frmInfo.Print "Verbs:";
    ctlScrnControl.FetchVerbs
    '索引为0的是缺省动词，好果合适缺省动词可能在ObjectVerbs数组中出现两次
    For i = 0 To ctlScrnControl.ObjectVerbsCount - 1
        frmInfo.Print Tab(20); ctlScrnControl.ObjectVerbs(i); Tab(40);
        Select Case ctlScrnControl.ObjectVerbFlags(i)
        Case vbOLEFlagChecked
            frmInfo.Print "Checked"
        Case 0
            frmInfo.Print "Enabled"
        Case vbOLEFlagGrayed
            frmInfo.Print "Grayed"
        Case vbOLEFlagSeparator
            frmInfo.Print "Separator"
        End Select
    Next i
    
    frmInfo.Print
    frmInfo.Print "Long Pointer:";
    frmInfo.Print Tab(20); Hex(ctlScrnControl.LpOleObject)
    frmInfo.Left = frmMain.Width + frmMain.Left
End Sub