connect.dsr

VB圣经

VERSION 5.00
Begin {AC0714F6-3D04-11D1-AE7D-00A0C90F26F4} Connect 
   ClientHeight    =   7545
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   8895
   _ExtentX        =   15690
   _ExtentY        =   13309
   _Version        =   393216
   Description     =   "#101"
   DisplayName     =   "#100"
   AppName         =   "Visual Basic"
   AppVer          =   "Visual Basic 98 (ver 6.0)"
   LoadName        =   "None"
   LoadBehavior    =   2
   RegLocation     =   "HKEY_CURRENT_USER\Software\Microsoft\Visual Basic\6.0"
   SatName         =   "OCXDirect"
   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 Declare Function FindResource Lib "kernel32" Alias "FindResourceA" (ByVal hInstance As Long, ByVal lpName As Any, ByVal lpType As Any) As Long
Private Declare Function LockResource Lib "kernel32" (ByVal hResData As Long) As Long
Private Declare Function LoadResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long

Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As Long, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH As Integer = 260

Private Const RT_RCDATA As Long = 10
Private Const DONT_RESOLVE_DLL_REFERENCES As Long = 1
Private Const LOAD_LIBRARY_AS_DATAFILE As Long = 2

Private m_VBInst As VBIDE.VBE
Private m_ProjPath As String

Private Const cstrNameExtension As String = "Direct"
Private Const cstrOurLibName As String = "DirectOCXTypes"

Private Function OCXRefInfoFromOCA(strOCAFile As String) As String
Dim hInst As Long
Dim hRsrc As Long
Dim hGlobal As Long
Dim pData As Long
Dim dwOffset As Long
    hInst = LoadLibraryEx(strOCAFile, 0, DONT_RESOLVE_DLL_REFERENCES Or LOAD_LIBRARY_AS_DATAFILE)
    If hInst Then
        hRsrc = FindResource(hInst, CLng(1), RT_RCDATA)
        If hRsrc Then
            hGlobal = LoadResource(hInst, hRsrc)
            If hGlobal Then
                pData = LockResource(hGlobal)
                With VBoost
                    dwOffset = .Deref(.UAdd(pData, 40))
                    pData = .UAdd(pData, dwOffset)
                End With
                OCXRefInfoFromOCA = StrConv(SysAllocStringByteLen(pData, lstrlen(pData)), vbUnicode)
            End If
        End If
        FreeLibrary hInst
    End If
End Function

Private Function TLIForOCXFromOCA(strOCAFile As String) As TLI.TypeLibInfo
Dim strOCXData As String
    strOCXData = OCXRefInfoFromOCA(strOCAFile)
    If Len(strOCXData) Then Set TLIForOCXFromOCA = TLIFromRefInfo(strOCXData)
End Function

Private Function TLIFromRefInfo(RefInfo As String) As TLI.TypeLibInfo
Dim MinorVerPos As Integer
Dim MajorVerPos As Integer
Dim LCIDPos As Integer
Dim EndPos As Long
Dim fMoreInfo As Boolean
Dim lPos As Long
    On Error Resume Next
    Set TLIFromRefInfo = New TypeLibInfo
    MinorVerPos = InStr(1, RefInfo, "#") + 1
    MajorVerPos = InStr(MinorVerPos, RefInfo, ".") + 1
    LCIDPos = InStr(MinorVerPos, RefInfo, "#") + 1
    EndPos = InStr(LCIDPos, RefInfo, "#")
    fMoreInfo = EndPos
    If EndPos = 0 Then EndPos = Len(RefInfo) + 1
    TLIFromRefInfo.LoadRegTypeLib _
        Mid$(RefInfo, 1, MinorVerPos - 2), _
        CInt(Mid$(RefInfo, MinorVerPos, MajorVerPos - MinorVerPos - 1)), _
        CInt(Mid$(RefInfo, MajorVerPos, LCIDPos - MajorVerPos - 1)), _
        CLng(Mid$(RefInfo, LCIDPos, EndPos - LCIDPos))
    If Err Then
        'Try to load off the file name.
        If fMoreInfo Then
            If Len(m_ProjPath) = 0 Then
                m_ProjPath = m_VBInst.ActiveVBProject.FileName
                lPos = Len(m_ProjPath)
                Do Until Mid$(m_ProjPath, lPos, 1) = "\"
                    lPos = lPos - 1
                Loop
                m_ProjPath = Left$(m_ProjPath, lPos)
            End If
            Err.Clear
            TLIFromRefInfo.ContainingFile = m_ProjPath & Mid$(RefInfo, EndPos + 1, InStr(EndPos + 1, RefInfo, "#") - EndPos - 1)
            If Err = 0 Then Exit Function
        End If
        'Just return Nothing.  Don't care why the error happened.
        Set TLIFromRefInfo = Nothing
        Err.Clear
    End If
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
        m_MenuCommandBar.Delete
        Set m_MenuCommandBar = Nothing
        Set MenuHandler = Nothing
    End If
    Set m_VBInst = Nothing
End Sub

Private Sub AddinInstance_OnStartupComplete(custom() As Variant)
    Set m_MenuCommandBar = AddToAddInCommandBar(LoadResString(102), LoadResPicture(1, vbResBitmap))
    If Not m_MenuCommandBar Is Nothing Then
        'sink the event
        Set MenuHandler = m_VBInst.Events.CommandBarEvents(m_MenuCommandBar)
    End If
End Sub

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 s 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 Function TLIForRefsFromVBP(VBPFile As String) As VBA.Collection
Dim fNum As Integer
Dim strLine As String
Dim TLInf As TypeLibInfo
    'Make sure we have a collection, even if it ends up empty.
    Set TLIForRefsFromVBP = New VBA.Collection
    fNum = FreeFile
    Open VBPFile For Input As #fNum
    Do Until EOF(fNum)
        Line Input #fNum, strLine
        'Assume default format
        If Left$(strLine, 7) = "Object=" Then
            Set TLInf = TLIFromRefInfo(Mid$(strLine, 8, InStr(8, strLine, ";") - 8))
        ElseIf Left$(strLine, 13) = "Reference=*\G" Then
            Set TLInf = TLIFromRefInfo(Mid$(strLine, 14))
        End If
        If Not TLInf Is Nothing Then
            TLIForRefsFromVBP.Add TLInf, TLInf.Name
            Set TLInf = Nothing
        End If
    Loop
    Close fNum
End Function

Private Function TempFile(strBaseName As String) As String
    TempFile = String$(MAX_PATH, 0)
    GetTempPath MAX_PATH, TempFile
    TempFile = StrConv(TempFile, vbFromUnicode)