mainwindow.dob

VB圣经

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{6AA5A030-32F0-11D4-91F9-3E9B52000000}#1.0#0"; "TLBEditor.ocx"
Begin VB.UserDocument MainWindow 
   ClientHeight    =   2535
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3960
   ClipControls    =   0   'False
   ContinuousScroll=   0   'False
   HasDC           =   0   'False
   HScrollSmallChange=   15
   LockControls    =   -1  'True
   ScaleHeight     =   169
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   264
   VScrollSmallChange=   15
   Begin MSComctlLib.ImageList Images 
      Left            =   510
      Top             =   1680
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   16711935
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   5
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "MainWindow.dox":0000
            Key             =   ""
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "MainWindow.dox":0112
            Key             =   ""
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "MainWindow.dox":0224
            Key             =   ""
         EndProperty
         BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "MainWindow.dox":0336
            Key             =   ""
         EndProperty
         BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "MainWindow.dox":0448
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.Toolbar Commands 
      Align           =   1  'Align Top
      Height          =   330
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   3960
      _ExtentX        =   6985
      _ExtentY        =   582
      ButtonWidth     =   609
      ButtonHeight    =   582
      AllowCustomize  =   0   'False
      Wrappable       =   0   'False
      Style           =   1
      ImageList       =   "Images"
      _Version        =   393216
      BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628} 
         NumButtons      =   6
         BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            ImageIndex      =   1
            Style           =   5
         EndProperty
         BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            ImageIndex      =   2
            Style           =   5
         EndProperty
         BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            ImageIndex      =   3
         EndProperty
         BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Style           =   3
         EndProperty
         BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            ImageIndex      =   4
         EndProperty
         BeginProperty Button6 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            ImageIndex      =   5
         EndProperty
      EndProperty
   End
   Begin TLBEditor.LibraryViewer LibViewer 
      Height          =   2205
      Left            =   0
      TabIndex        =   1
      Top             =   330
      Width           =   3960
      _ExtentX        =   6985
      _ExtentY        =   3889
   End
End
Attribute VB_Name = "MainWindow"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

'Button Index constants
Private Const cbiChooseProject As Integer = 1
Private Const cbiEditLibrary As Integer = 2
Private Const cbiNewLibrary As Integer = 3
Private Const cbiSaveChanges As Integer = 5
Private Const cbiDiscardChanges As Integer = 6

Implements IChangeListener
Private WithEvents ProjectsEvents As VBIDE.VBProjectsEvents
Attribute ProjectsEvents.VB_VarHelpID = -1
Private WithEvents ReferencesEvents As VBIDE.ReferencesEvents
Attribute ReferencesEvents.VB_VarHelpID = -1
Private WithEvents FileControlEvents As VBIDE.FileControlEvents
Attribute FileControlEvents.VB_VarHelpID = -1
Private m_ActiveRef As Reference
Private m_VBInst As VBE
Private m_ActiveProject As VBProject
Private m_fDirty As Boolean
Private m_fProjectsDirty As Boolean
Private m_ListenerHook As ChangeListenerHook
Private m_Libraries As Collection

'Variables to coordinate overwriting a saved file
Private m_pfnAfterCloseFile As Long       'A function pointer called by FileControlEvents_AfterCloseFile
Private m_cRemainingProjects As Long      'A counter decremented by FileControlEvents_AfterCloseFile, make callback when 0

Friend Sub OnConnect(VBInst As VBIDE.VBE, Window As VBIDE.Window)
Dim Listen As ChangeListener
    'Get a listener in place so that we know when we're dirty
    Set m_ListenerHook = New ChangeListenerHook
    Set Listen = New ChangeListener
    m_ListenerHook.Attach Listen, Me
    Set LibViewer.ChangeListener = Listen
    
    Set m_VBInst = VBInst
    Set ProjectsEvents = VBInst.Events.VBProjectsEvents
    
    'Make the projects dropdown repopulate
    m_fProjectsDirty = True
    
    'If we only have one project, then let it be the active project
    With VBInst.VBProjects
        If .Count = 1 Then
            Set ActiveProject = .Item(1)
        Else
            'Force Dirty routine to run
            m_fDirty = True
            Dirty = False
        End If
    End With
    
    Window.Visible = True
    UpdateCaption
End Sub
Friend Sub OnDisconnect()
    Set LibViewer.ChangeListener = Nothing
    Set m_ActiveProject = Nothing
    Set m_ActiveRef = Nothing
    Set m_Libraries = Nothing
    Set m_ListenerHook = Nothing
    Set ProjectsEvents = Nothing
    Set ReferencesEvents = Nothing
End Sub

Private Property Set ActiveProject(ByVal Proj As VBProject)
    If Proj Is m_ActiveProject Then Exit Property
    Set LibViewer.CurrentLibrary = Nothing
    Set m_ActiveProject = Proj
    Set m_Libraries = Nothing
    Set m_ActiveRef = Nothing
    Set ReferencesEvents = Nothing
    If Not Proj Is Nothing Then
        Set ReferencesEvents = m_VBInst.Events.ReferencesEvents(Proj)
    End If
    m_fDirty = True
    Dirty = False
End Property
Private Sub AddNewReference()
Dim strPath As String
    On Error GoTo Error
    strPath = PromptForFileName(UserDocument.hWnd)
    If Len(strPath) Then
        LibViewer.SaveCurrentLibrary strPath
        'Have to register it or VB won't be able to pick it up
        RegisterTypeLib LoadTypeLibEx(strPath), strPath, vbNullString
        Set m_ActiveRef = m_ActiveProject.References.AddFromFile(strPath)
        Dirty = False
    End If
    Exit Sub
Error:
    MsgBox Err.Description, vbInformation
End Sub

Private Sub Commands_ButtonClick(ByVal Button As MSComctlLib.Button)
Dim GuidString As String * 38
Dim strPath As String
Dim ptlib As ITypeLib
    On Error GoTo Error
    Select Case Button.Index
        Case cbiNewLibrary
            With New CustomTypeLib
                .LibName = LoadResString(cidNewLibName)
                StringFromGUID2 CoCreateGuid, GuidString
                .Guid = GuidString
                .LCID = 0
                LoadLibViewer .Generate(False).ITypeLib, vbNullString
            End With
            Dirty = True 'A new library is dirty immediately
            UpdateCaption
        Case cbiSaveChanges
            If m_ActiveRef Is Nothing Then
                AddNewReference
            Else
                SaveActiveRef
            End If
            UpdateCaption
        Case cbiDiscardChanges
            If m_ActiveRef Is Nothing Then
                Set LibViewer.CurrentLibrary = Nothing
            Else
                strPath = m_ActiveRef.Name
                Set ptlib = LoadTypeLibEx(LibPathFromRef(m_ActiveRef), REGKIND_NONE)
                Set m_ActiveRef = Nothing 'Make sure this resets
                LoadLibViewer ptlib, strPath
            End If
            Dirty = False
            UpdateCaption
    End Select
    Exit Sub
Error:
    MsgBox Err.Description, vbExclamation
End Sub
Private Function LibPathFromRef(Ref As Reference) As String
Dim fNum As Integer
Dim strProjFile As String
Dim Proj As VBProject
Dim fFileOpen As Boolean
Dim fSawReference As Boolean 'Make sure we don't go past the References section, they are all listed up front.
Dim strLine As String
Dim iPos As Long
Dim iPos1 As Long
Dim Maj As Long
Dim Min As Long
    On Error Resume Next
    LibPathFromRef = Ref.FullPath
    On Error GoTo 0
    If Len(LibPathFromRef) Then Exit Function 'Properly registered library
    
    'If the library is loaded but not registered, then the relative path
    'from the project directly must be present in the project file.
    On Error GoTo Error
    Set Proj = Ref.Collection.Parent
    strProjFile = Proj.FileName
    fNum = FreeFile
    Open strProjFile For Input As #fNum
    fFileOpen = True
    Do Until EOF(fNum)
        strLine = vbNullString
        Line Input #fNum, strLine
        If 1 = InStr(strLine, "Reference=*\G") Then
            fSawReference = True
            If IsEqualGUID(GUIDFromString(Mid$(strLine, 14, 38)), GUIDFromString(Ref.Guid)) = BOOL_TRUE Then
                iPos = InStr(53, strLine, ".", vbBinaryCompare)
                If CLng("&H" & Mid$(strLine, 53, iPos - 53)) = Ref.Major Then
                    iPos1 = iPos + 1
                    iPos = InStr(iPos1, strLine, "#", vbBinaryCompare)
                    If CLng("&H" & Mid$(strLine, iPos1, iPos - iPos1)) = Ref.Minor Then
                        'This is the reference we're looking for. Skip the LCID and get the path.
                        iPos1 = InStr(iPos + 1, strLine, "#", vbBinaryCompare) + 1
                        iPos = InStr(iPos1, strLine, "#", vbBinaryCompare)
                        LibPathFromRef = Mid$(strLine, iPos1, iPos - iPos1)
                        
                        'See if this is an absolute path
                        If 0 = StrComp(Mid$(strLine, 2, 1), ":", vbBinaryCompare) Then
                        ElseIf 0 = StrComp(Left$(strLine, 2), "\\", vbBinaryCompare) Then
                        Else
                            strLine = Proj.FileName
                            LibPathFromRef = Left$(strLine, InStrRev(strLine, "\", , vbBinaryCompare)) & LibPathFromRef
                        End If
                        Exit Do
                    End If
                End If
            End If
        ElseIf fSawReference Then
            Exit Do
        End If
    Loop
    fFileOpen = False
    Close #fNum
    Exit Function
Error:
    If fFileOpen Then Close #fNum
    LibPathFromRef = vbNullString
End Function
Private Sub SaveActiveRef()
    'This is incredibly difficult for something that sounds so simple
    'because of two issues. The first issue is that VB doesn't allow
    'you to add a reference with a priority higher than last, so all
    'references after the target must be removed and readded as part
    'of the update. This is not always possible if the references are
    'broken, and an unregistered but unbroken reference requires a spin
    'through the project file to readd the reference. The other problem
    'is that if the file is still locked after the reference is removed,
    'then about the only thing left to do is to attempt to unload the
    'project (group), attempt to update the file while the project is unloaded,
    'then reload the project. If even this fails to let go of the file, then
    'all we can do is offer a Save As and bail.
    
    'This function uses a lot of helper functions to make sure that all
    'objects (including VB-generated temporary locals) that might be holding
    'a reference to the typelib we're replacing have been cleared when we
    'try to replace it. Note that the LibViewer's CurrentLibrary is an
    'in-memory copy of the library being edited and never locks down a
    'file on disk, so we don't have to worry about clearing it.