Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/oledem/main.frm

Visual Basic Form | 1995-05-08 | 9.1 KB | 306 lines

VERSION 2.00
Begin Form frmMain
   Caption         =   "Save and Load Ole Objects"
   ClientHeight    =   3660
   ClientLeft      =   525
   ClientTop       =   2160
   ClientWidth     =   8250
   Height          =   4350
   Left            =   465
   LinkTopic       =   "Form1"
   ScaleHeight     =   3660
   ScaleWidth      =   8250
   Top             =   1530
   Width           =   8370
   Begin Frame Frame2
      Caption         =   "Object Loaded"
      Height          =   3375
      Left            =   3120
      TabIndex        =   3
      Top             =   120
      Width           =   4965
      Begin OLE OLE1
         DisplayType     =   1  'Icon
         fFFHk           =   -1  'True
         Height          =   2415
         Left            =   150
         TabIndex        =   4
         Top             =   690
         Width           =   4665
      End
      Begin Label LabelUnsaved
         Caption         =   "*"
         Height          =   255
         Left            =   150
         TabIndex        =   6
         Top             =   390
         Width           =   135
      End
      Begin Label LabelFormat
         Alignment       =   1  'Right Justify
         Caption         =   "LabelFormat"
         Height          =   255
         Left            =   3240
         TabIndex        =   5
         Top             =   390
         Width           =   1575
      End
      Begin Label LabelLoaded
         Caption         =   "LabelLoaded"
         Height          =   255
         Left            =   300
         TabIndex        =   0
         Top             =   390
         Width           =   2955
      End
   End
   Begin Frame Frame1
      Caption         =   "Objects in Database"
      Height          =   3375
      Left            =   120
      TabIndex        =   1
      Top             =   120
      Width           =   2775
      Begin ListBox ListObject
         Height          =   2760
         Left            =   120
         TabIndex        =   2
         Top             =   360
         Width           =   2535
      End
   End
   Begin Menu mnuRecord
      Caption         =   "&Record"
      Begin Menu mnuRecordLoad
         Caption         =   "&Load"
      End
      Begin Menu mnuRecordSave
         Caption         =   "&Save..."
      End
      Begin Menu mnuRecordDelete
         Caption         =   "&Delete"
      End
      Begin Menu mnuRecordSep1
         Caption         =   "-"
      End
      Begin Menu mnuRecordExit
         Caption         =   "&Exit"
      End
   End
   Begin Menu mnuObject
      Caption         =   "&Object"
      Begin Menu mnuObjectInsert
         Caption         =   "&Insert..."
      End
      Begin Menu mnuObjectDelete
         Caption         =   "&Delete"
      End
      Begin Menu mnuObjectEdit
         Caption         =   "&Edit"
         Begin Menu mnuObjectVerb
            Caption         =   "verb"
            Index           =   0
         End
      End
   End
Option Explicit
Function DocumentFormatDescription (iType As Integer) As String
    Select Case iType
        Case 0
            DocumentFormatDescription = "0 Access 1.x Ole"
        Case 1
            DocumentFormatDescription = "1 Ole2"
        Case 2
            DocumentFormatDescription = "2 Access 1.x Paintbrush"
    End Select
End Function
Sub Form_Load ()
    Dim Verb As Integer
    LabelLoaded.Caption = ""
    LabelFormat.Caption = ""
    LabelUnsaved.Caption = ""
    Call LoadListObject
    On Error Resume Next
    For Verb = 1 To OLE_MAX_VERBS
        Load mnuObjectVerb(Verb)
    Next Verb
    mnuObjectVerb(0).Visible = False
End Sub
Sub Form_Unload (Cancel As Integer)
    End
End Sub
Sub ListObject_DblClick ()
    Call mnuRecordLoad_Click
End Sub
Sub LoadListObject ()
    Dim sCmd As String
    Dim ss As Snapshot
    'Clear list of items
    ListObject.Clear
    'Create dynaset
    sCmd = "select DocumentName from Document"
    sCmd = sCmd + " order by DocumentName"
    Set ss = db.CreateSnapshot(sCmd)
    Do While Not ss.EOF
        ListObject.AddItem ss("DocumentName")
        ss.MoveNext
    Loop
    ss.Close
End Sub
Sub mnuObject_Click ()
    Dim Verb
    Dim LargestCurrentVerb As Integer
    If Ole1.OLEType = OLE_NONE Then
        mnuObjectDelete.Enabled = False
        mnuObjectEdit.Enabled = False
    Else
        mnuObjectDelete.Enabled = True
        mnuObjectEdit.Enabled = True
        Ole1.Action = OLE_FETCH_VERBS
        LargestCurrentVerb = Ole1.ObjectVerbsCount - 1

        For Verb = 1 To LargestCurrentVerb
            mnuObjectVerb(Verb).Caption = Ole1.ObjectVerbs(Verb)
            mnuObjectVerb(Verb).Visible = True
        Next Verb

        For Verb = LargestCurrentVerb + 1 To OLE_MAX_VERBS
            mnuObjectVerb(Verb).Visible = False
        Next Verb
    End If
End Sub
Sub mnuObjectDelete_Click ()
    Ole1.Action = OLE_DELETE
    LabelLoaded.Caption = ""
    LabelFormat.Caption = ""
    LabelUnsaved.Caption = ""
End Sub
Sub mnuObjectInsert_Click ()
    If Ole1.OLEType <> OLE_NONE Then
        If MsgBox("Delete Current Object?", 1) = 2 Then
            Exit Sub
        End If
        Ole1.Action = OLE_DELETE
        LabelLoaded.Caption = ""
        LabelFormat.Caption = ""
        LabelUnsaved.Caption = ""
    End If
    Ole1.Action = OLE_INSERT_OBJ_DLG
    If Ole1.OLEType <> OLE_NONE Then
        Ole1.HostName = "Untitled"
        LabelLoaded.Caption = Ole1.HostName
        LabelUnsaved.Caption = "*"
        Ole1.Action = OLE_ACTIVATE
    End If
End Sub
Sub mnuObjectVerb_Click (index As Integer)
    Ole1.Verb = index
    Ole1.Action = OLE_ACTIVATE
End Sub
Sub mnuRecord_Click ()
    If ListObject.ListIndex = -1 Then
        mnuRecordLoad.Enabled = False
        mnuRecordDelete.Enabled = False
    Else
        mnuRecordLoad.Enabled = True
        mnuRecordDelete.Enabled = True
    End If
    If Ole1.OLEType <> OLE_NONE Then
        mnuRecordSave.Enabled = True
    Else
        mnuRecordSave.Enabled = False
    End If
End Sub
Sub mnuRecordDelete_Click ()
    Dim sCmd As String
    If MsgBox("Delete Object " + ListObject.Text + " from Database?", 49) = 2 Then
        Exit Sub
    End If
    MousePointer = 11
    sCmd = "delete from Document"
    sCmd = sCmd + " where DocumentName = """ + ListObject.Text + """"
    db.Execute sCmd
    Call LoadListObject
    MousePointer = 0
End Sub
Sub mnuRecordExit_Click ()
    Unload Me
End Sub
Sub mnuRecordLoad_Click ()
    Dim sCmd As String
    Dim ds As Dynaset
    MousePointer = 11
    'Create dynaset
    sCmd = "select DocumentType, DocumentOle from Document"
    sCmd = sCmd + " where DocumentName = """ + ListObject.Text + """"
    Set ds = db.CreateDynaset(sCmd)
    If ds.EOF Then
        MsgBox "Could not find " + ListObject.Text + "!"
        ds.Close
        MousePointer = 0
        Exit Sub
    End If
    iDocumentType = ds("DocumentType")
    Select Case iDocumentType

        Case DOCUMENT_TYPE_ACCESS1XOLE
            Call CopyFieldToAccess1xOle(ds("DocumentOle"), Ole1)

        Case DOCUMENT_TYPE_OLE2
            Call CopyFieldToOle2(ds("DocumentOle"), Ole1)
    End Select
    ds.Close
    LabelLoaded.Caption = ListObject.Text
    LabelFormat.Caption = DocumentFormatDescription(iDocumentType)
    LabelUnsaved.Caption = ""
    Ole1.HostName = ListObject.Text
    MousePointer = 0
End Sub
Sub mnuRecordSave_Click ()
    Dim sCmd As String
    Dim ds As Dynaset
    'Set form controls
    frmDocumentName.TextDocumentName.Text = Ole1.HostName
    frmDocumentName.OptionDocumentType(iDocumentType).Value = True
    frmDocumentName.Show 1
    'Test global for good name
    If sDocumentName = "" Then
        Exit Sub
    End If
    MousePointer = 11
    sCmd = "select DocumentName, DocumentType, DocumentOle from Document"
    sCmd = sCmd + " where DocumentName = """ + sDocumentName + """"
    Set ds = db.CreateDynaset(sCmd)
    If ds.EOF Then
        ds.AddNew
        ds("DocumentName") = sDocumentName
    Else
        ds.Edit
    End If
    Ole1.HostName = sDocumentName
    ds("DocumentType") = iDocumentType
    Select Case iDocumentType
        Case DOCUMENT_TYPE_ACCESS1XOLE
            Call CopyAccess1xOleToField(Ole1, ds("DocumentOle"))
        Case DOCUMENT_TYPE_OLE2
            Call CopyOle2ToField(Ole1, ds("DocumentOle"))
    End Select
    ds.Update
    ds.Close
    'Reload list of objects
    Call LoadListObject
    'Call DoEvents so Updated event for Ole control is triggered
    DoEvents
    LabelLoaded.Caption = Ole1.HostName
    LabelFormat.Caption = DocumentFormatDescription(iDocumentType)
    LabelUnsaved.Caption = ""
    MousePointer = 0
End Sub
Sub NewOleObject ()
End Sub
Sub OLE1_Updated (Code As Integer)
    If Code = OLE_CHANGED Then
        LabelUnsaved.Caption = "*"
    End If
End Sub