connect.dsr

此源码为vb圣经编码

VERSION 5.00
Begin {AC0714F6-3D04-11D1-AE7D-00A0C90F26F4} Connect 
   ClientHeight    =   7950
   ClientLeft      =   1740
   ClientTop       =   1545
   ClientWidth     =   6585
   _ExtentX        =   11615
   _ExtentY        =   14023
   _Version        =   393216
   Description     =   "#101"
   DisplayName     =   "#100"
   AppName         =   "Visual Basic"
   AppVer          =   "Visual Basic 6.0"
   LoadName        =   "None"
   RegLocation     =   "HKEY_CURRENT_USER\Software\Microsoft\Visual Basic\6.0"
   SatName         =   "EditTLB"
   CmdLineSupport  =   -1  'True
End
Attribute VB_Name = "Connect"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private WithEvents MenuHandler As CommandBarEvents   'command bar event handler
Attribute MenuHandler.VB_VarHelpID = -1
Private m_MenuCommandBar As CommandBarControl
Private m_Doc As MainWindow
Private m_Window As Window
Private m_VBInst As VBIDE.VBE

Private Function AddToAddInCommandBar(sCaption As String, oBitmap As Picture) As Office.CommandBarControl
Dim Count As Integer
Dim cbMenuCommandBar As Office.CommandBarControl  'command bar object
Dim cbMenu As CommandBar
    
    On Error GoTo Error
    'see if we can find the Add-Ins menu
    Set cbMenu = m_VBInst.CommandBars("Add-Ins")
        If cbMenu Is Nothing Then
        'not available so we fail
        Exit Function
    End If
    
    'add it to the command bar
    With cbMenu.Controls
        Set cbMenuCommandBar = .Add(1)
        Count = .Count - 1
        If .Item(Count).BeginGroup And _
            Not .Item(Count - 1).BeginGroup Then
            'this is the first addin being added so it needs a separator
            cbMenuCommandBar.BeginGroup = True
        End If
    End With
    
    'set the caption
    cbMenuCommandBar.Caption = sCaption
    If Not oBitmap Is Nothing Then
        'copy the icon to the clipboard
        Clipboard.SetData oBitmap
        'set the icon for the button
        cbMenuCommandBar.PasteFace
    End If
    Set AddToAddInCommandBar = cbMenuCommandBar
    Exit Function
Error:
End Function

Private Sub AddinInstance_OnConnection(ByVal Application As Object, ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, ByVal AddInInst As Object, Custom() As Variant)
    Set m_VBInst = Application
    If ConnectMode = vbext_cm_AfterStartup Then
        AddinInstance_OnStartupComplete Custom()
    End If
End Sub

Private Sub AddinInstance_OnDisconnection(ByVal RemoveMode As AddInDesignerObjects.ext_DisconnectMode, Custom() As Variant)
    If Not m_MenuCommandBar Is Nothing Then
        If Not m_Window Is Nothing Then
            SaveSetting REG_CATEGORY, REG_APPSECTION, REG_SHOWONCONNECT, m_Window.Visible
        End If
        If Not m_Doc Is Nothing Then m_Doc.OnDisconnect
        m_MenuCommandBar.Delete
        Set m_MenuCommandBar = Nothing
        Set m_Window = Nothing
        Set m_Doc = Nothing
        Set MenuHandler = Nothing
    End If
    Set m_VBInst = Nothing
End Sub

Private Sub AddinInstance_OnStartupComplete(Custom() As Variant)
    Set m_MenuCommandBar = AddToAddInCommandBar(LoadResString(cidAddInMenu), LoadResPicture(1, vbResBitmap))
    If Not m_MenuCommandBar Is Nothing Then
        'sink the event
        Set MenuHandler = m_VBInst.Events.CommandBarEvents(m_MenuCommandBar)
        If CBool(GetSetting(REG_CATEGORY, REG_APPSECTION, REG_SHOWONCONNECT, False)) Then
            LoadShowWindow
        End If
    End If
End Sub

Private Sub MenuHandler_Click(ByVal CommandBarControl As Object, handled As Boolean, CancelDefault As Boolean)
    LoadShowWindow
End Sub
Private Sub LoadShowWindow()
Dim AppTitle As String
    If m_Window Is Nothing Then
        AppTitle = LoadResString(cidAppTitle)
        App.Title = AppTitle
        Set m_Window = m_VBInst.Windows.CreateToolWindow(m_VBInst.Addins(ADDIN_PROGID), ADDIN_DOC_PROGID, AppTitle, UNIQUE_APP_ID, m_Doc)
        m_Doc.OnConnect m_VBInst, m_Window
    Else
        m_Window.Visible = True
    End If
End Sub