Liren Large Software Subsidy 10/10.iso/l/l406/3.ddi/OLEMAIN.FR_/OLEMAIN.bin

Visual Basic Form | 1992-10-21 | 8.9 KB | 330 lines

VERSION 2.00
Begin Form frmMain
   Caption         =   "OLE Client Demo"
   Height          =   4725
   Left            =   615
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   ScaleHeight     =   71.173
   ScaleMode       =   6  'Millimeter
   ScaleWidth      =   139.7
   Top             =   1740
   Width           =   8040
   Begin OleClient OleClient1
      Class           =   ""
      Focus           =   -1  'True
      Height          =   30
      HostName        =   ""
      Left            =   0
      Protocol        =   "StdFileEditing"
      ServerShow      =   -1  'True
      ServerType      =   0  'Linked
      SourceDoc       =   ""
      SourceItem      =   ""
      Timeout         =   32767
      Top             =   0
      Verb            =   0
      Width           =   30
   End
   Begin Menu mnuFile
      Caption         =   "&File"
      Begin Menu mnuOpenObject
         Caption         =   "&Open..."
      End
      Begin Menu mnuSaveObject
         Caption         =   "Save &As..."
      End
      Begin Menu sep4
         Caption         =   "-"
      End
      Begin Menu mnuFileExit
         Caption         =   "E&xit Demo"
      End
      Begin Menu mnuAbout
         Caption         =   "A&bout..."
      End
   End
   Begin Menu mnuEdit
      Caption         =   "&Edit"
      Begin Menu mnuCut
         Caption         =   "Cu&t"
      End
      Begin Menu mnuCopyObject
         Caption         =   "&Copy"
      End
      Begin Menu mnuPasteObject
         Caption         =   "&Paste"
      End
      Begin Menu mnuPasteLink
         Caption         =   "Paste &Link"
      End
      Begin Menu sep3
         Caption         =   "-"
         Index           =   3
      End
      Begin Menu mnuDeleteObject
         Caption         =   "&Delete"
      End
      Begin Menu separator2
         Caption         =   "-"
         Index           =   1
      End
      Begin Menu mnuLinks
         Caption         =   "&Links..."
      End
      Begin Menu mnuEditObject
         Caption         =   "EditObject"
         Index           =   0
         Visible         =   0   'False
         Begin Menu mnuEditObjVerb
            Caption         =   "Edit"
            Index           =   0
         End
      End
      Begin Menu mnuEditObject
         Caption         =   "&Object"
         Enabled         =   0   'False
         Index           =   1
      End
      Begin Menu mnuUpdate
         Caption         =   "&Update"
      End
   End
   Begin Menu mnuInsert
      Caption         =   "&Insert"
      Begin Menu mnuInsertObject
         Caption         =   "&Object"
      End
   End
Sub Form_Resize ()
    OleClient1.Move 0, 0, frmMain.ScaleWidth, frmMain.ScaleHeight
End Sub
Sub Form_Unload (Cancel As Integer)
    End
End Sub
Sub mnuAbout_Click ()
  CenterForm Me, AboutBox
  AboutBox.Show 1
End Sub
Sub mnuCopyObject_Click ()
  'copy object to Clipboard
  OleClient1.Action = OLE_COPY
End Sub
Sub mnuCut_Click ()
  Call mnuCopyObject_Click
  Call mnuDeleteObject_Click
End Sub
Sub mnuDeleteObject_Click ()
  On Error Resume Next
  ' if object needs to be saved
  If Save = True Then
    response% = MsgBox("Save Object?", 19)
    Select Case response%
    ' user pressed Yes
    Case 6
      Call mnuSaveObject_Click
    ' user pressed Cancel
    Case 2
      Exit Sub
    End Select
  End If
  ' delete the object
  OleClient1.Action = OLE_DELETE
  If Err Then
    MsgBox Error$
    Exit Sub
  End If
    'reset flags, object no longer contains an object
    ContainsObject = False
    LinkFlag = False
    'reset edit object menu
    mnuEditObject(0).Visible = False
    mnuEditObject(1).Caption = "&Object"
    mnuEditObject(1).Enabled = False
    mnuEditObject(1).Visible = True
End Sub
Sub mnuEdit_Click ()
'enable/disable menu items
  'if OleClient contains an object
  If ContainsObject Then
    mnuDeleteObject.Enabled = True
    mnuCopyObject.Enabled = True
    mnuCut.Enabled = True
    mnuEditObject(0).Enabled = True
    mnuEditObject(1).Enabled = True
  Else
    mnuDeleteObject.Enabled = False
    mnuCopyObject.Enabled = False
    mnuCut.Enabled = False
    mnuEditObject(0).Enabled = False
    mnuEditObject(1).Enabled = False
  End If
  'check if it's ok to paste embedded object
  OleClient1.ServerType = OLE_EMBEDDED
  OleClient1.Protocol = "StdFileEditing"
  If OleClient1.PasteOK Then
    mnuPasteObject.Enabled = True
  Else
    mnuPasteObject.Enabled = False
  End If
  'check if it's ok to paste linked object
  OleClient1.ServerType = OLE_LINKED
  If OleClient1.PasteOK Then
    mnuPasteLink.Enabled = True
  Else
    mnuPasteLink.Enabled = False
  End If
  mnuUpdate.Enabled = False
  'check if object is linked
  If LinkFlag Then
    mnuLinks.Enabled = True
   'check if current object is a manual (frozen) link
   'if so, allow user to update
   If OleClient1.UpdateOptions = OLE_FROZEN Then mnuUpdate.Enabled = True
  Else
    mnuLinks.Enabled = False
  End If
End Sub
Sub mnuEditObject_Click (Index As Integer)
  'If single verb menu is selected
  If Index = 1 Then
    Call OleClient1_DblClick
  End If
End Sub
Sub mnuEditObjVerb_Click (Index As Integer)
    On Error Resume Next
    ' Set the verb to perform when activated
    frmMain.OleClient1.Verb = Index
    ' Activate the object
    frmMain.OleClient1.Action = OLE_ACTIVATE
    If (Err) Then
        MsgBox Error$
   End If
End Sub
Sub mnuFile_Click ()
  If Save And ContainsObject Then
    mnuSaveObject.Enabled = True
  Else
    mnuSaveObject.Enabled = False
  End If
End Sub
Sub mnuFileExit_Click ()
  End
End Sub
Sub mnuInsert_Click ()
  If ContainsObject Then
    mnuInsertObject.Enabled = False
  Else
    mnuInsertObject.Enabled = True
  End If
End Sub
Sub mnuInsertObject_Click ()
  On Error Resume Next
  'display insert dialog
  Call CenterForm(frmMain, dlgInsert)
  dlgInsert.Show 1
  If CancelFlag Then 'user cancelled insert operation
    CancelFlag = False   'reset flag
  Else
    'create new object
    frmMain.OleClient1.Action = OLE_CREATE_NEW
    If Err Then
      MsgBox Error$
    Else
      'set object flag
      ContainsObject = True
    End If
  End If
  'initialize edit menu
  Call InitEditObjectMenu
  'restore cursor
  Screen.MousePointer = 0
End Sub
Sub mnuLinks_Click ()
  ' display Links dialog
  Call CenterForm(frmMain, Links)
  Links.Show 1
End Sub
Sub mnuOpenObject_Click ()
    Dim FileNum As Integer
    Fileform.Caption = "File Open"
    Call CenterForm(frmMain, Fileform)
    Fileform.Show 1

End Sub
Sub mnuPasteLink_Click ()
  On Error Resume Next
  'linked object
  OleClient1.ServerType = OLE_LINKED
  'paste object
  Screen.MousePointer = 11
  OleClient1.Action = OLE_PASTE
  If (Err) Then
    MsgBox Error$
  Else
    ContainsObject = True
    'call FindDisplayName to set RegIndex for the new object
    DisplayName$ = FindDisplayName(OleClient1.Class)
    'initialize edit menu
    Call InitEditObjectMenu
  End If
  Screen.MousePointer = 0
  'set flag, OleClient contains a linked object
  LinkFlag = True
End Sub
Sub mnuPasteObject_Click ()
  On Error Resume Next
  ' set to embedded object
  OleClient1.ServerType = OLE_EMBEDDED
  ' paste object
  Screen.MousePointer = 11
  OleClient1.Action = OLE_PASTE
  If (Err) Then
    MsgBox Error$
  Else
    ContainsObject = True
    ' call FindDisplayName to set RegIndex for the new object
    DisplayName$ = FindDisplayName(OleClient1.Class)
    ' initialize edit menu
    Call InitEditObjectMenu
  End If
  ' since link wasn't pasted, disable links menu item
  LinkFlag = False
  Screen.MousePointer = 0
End Sub
Sub mnuSaveObject_Click ()
    Dim FileNum As Integer
    Fileform.Caption = "Save File As"
    Fileform.filFiles.Refresh
    Call CenterForm(frmMain, Fileform)
    Fileform.Show 1
End Sub
Sub mnuUpdate_Click ()
    OleClient1.Action = OLE_UPDATE
End Sub
Sub OleClient1_DblClick ()
  On Error Resume Next
  '0 is primary verb for each object in reg database
  OleClient1.Verb = 0
  OleClient1.Action = OLE_ACTIVATE
  If (Err) Then
    MsgBox Error$
  End If
End Sub
Sub OleClient1_Updated (Code As Integer)
  Dim RetVal As Integer
  'set flag to enable save object menu
  Save = True
  RetVal = OleQueryBounds(OleClient1.LpOleObject, OleRect)
  ' If the query function is successful
  If RetVal = 0 Then
    ' Set the ole client control's height and width to the
    ' optimal size as specified by the server application
    ' Remember to set the form's scalemode to millimeters
    ' since the OleQueryBounds API returns the Rect structure
    ' elements in 1/100 millimeters.
    OleClient1.Width = OleRect.right / 100
    OleClient1.Height = Abs(OleRect.bottom / 100)
  End If
End Sub