mainwindow.dob

VB圣经

Dim Locals As SaveActiveRefLocals
Dim fContinue As Boolean
Dim fHarmlessNameChange As Boolean
Dim strSaveAsPath As String

    On Error GoTo Error
    With Locals
        .TargetFile = LibPathFromRef(m_ActiveRef)
        
        If Len(.TargetFile) = 0 Then
            MsgBox LoadResString(cidReferenceInvalid), vbExclamation
            Exit Sub
        End If
    
        If GetAttr(.TargetFile) And vbReadOnly Then
            MsgBox BuildString(cidReadOnlyFile, .TargetFile), vbExclamation
            Exit Sub
        End If
    
        With LibViewer.CurrentLibrary
            Locals.NewLibGuid = GUIDFromString(.Guid)
            Locals.NewLibName = .Name
            Locals.NewLibMajor = .MajorVersion
            Locals.NewLibMinor = .MinorVersion
            Locals.NewLibLCID = .LCID
            Locals.NewLibDesc = .HelpString
        End With
        
        'The Reference object doesn't provide an LCID property, but this
        'forces us to rewrite the line in the .vbp file, so we need to track it.
        With TLI.TypeLibInfoFromFile(.TargetFile)
            Locals.StartLibLCID = .LCID
            Locals.fRefInfoChange = Locals.NewLibLCID <> Locals.StartLibLCID
            'Don't give name change warnings if the library is new and has
            'no types in it. Only libraries with types can actually be imported
            'into other libraries.
            fHarmlessNameChange = .TypeInfoCount = 0
        End With
        
        SaveActiveRefLoadFiles Locals, fContinue
        
        If .fRefInfoChange And Not fHarmlessNameChange Then
            If .fNameChange And .fGuidChange Then
                If vbYes = MsgBox(LoadResString(cidLibNameAndGuidChange), vbInformation Or vbYesNo) Then
                    AddNewReference
                    Exit Sub
                End If
            ElseIf .fNameChange Then
                'No guid change, can't save without an edit from the user
                If vbYes = MsgBox(LoadResString(cidLibNameNoGuidChange), vbInformation Or vbYesNo) Then
                    Exit Sub
                End If
            ElseIf .fGuidChange Then
                'No name change change, can't save to a different file without a new name
                If vbYes = MsgBox(LoadResString(cidLibGuidNoNameChange), vbInformation Or vbYesNo) Then
                    Exit Sub
                End If
            End If
        End If
        
        If .fRestorableRefs Then
            'Very unlikely, happens only if m_ActiveRef is not a Reference
            'object in the current project. No special message.
            If Not fContinue Then Beep: Exit Sub
            
            SaveActiveRefGenLibraryFile Locals, fContinue
            If Not fContinue Then Exit Sub
            
            'Clear module-level references that could be locking the
            'file down.
            Set m_Libraries = Nothing 'Holds a reference to the target file
            Set m_ActiveRef = Nothing 'Can restore from Locals.
            
            'Pull the active References object and all objects after it. This is
            'done after clearing m_ActiveRef to avoid bad interactions with the
            'ReferencesEvents. Note that this event callback could be cleared,
            'but it is a hassle to restore it.
            SaveActiveRefPullRefs Locals
            
            'See if we can kill the target file now
            On Error Resume Next
            'Always unregister the library before deleting it. We're not
            'tracking if there have been name or interface changes, so we
            'always unregister and reregister, even if the LIBID hasn't
            'changed.
            SaveActiveRefUnregisterTarget Locals
            Kill .TargetFile
            fContinue = Err
            On Error GoTo Error
            
            'If we failed the delete, then reregister the file.
            If fContinue Then SaveActiveRefRegisterTarget Locals
            
            'Copy the file across if we managed to kill the target. It is very unlikely
            'that this will fail, which is good because it corrupts the references collection.
            If Not fContinue Then
                Name Locals.NewFile As Locals.TargetFile
                .NewFile = vbNullString
                'Need to register the new file to make sure interface
                'and name changes are picked up correctly
                SaveActiveRefRegisterTarget Locals
            End If
            
            'We need to reset the references collection regardless of whether
            'or not this succeeded. Deal with the reload requirements later.
            SaveActiveRefRestoreRefs Locals
            
            'Restore the m_ActiveRef variable whether or not we're continuing
            Set m_ActiveRef = m_ActiveProject.References(Locals.iActiveRef)
            If Not fContinue Then
                Dirty = False
                Exit Sub
            End If
        ElseIf Not fContinue Then
            Exit Sub
        End If
        
        'If we made it this far, then the references collection is not easily editable, or the
        'referenced file is being held open by more than the active projects reference. This could
        'be an import from another referenced library, or a reference to the same library from
        'another project, or another external reference altogether. In any case, the first thing to
        'try is to reload the current project group and see what happens. Note that this bails out
        'very early if the project has not been saved.
        .ProjectName = m_ActiveProject.Name
        If vbYes = MsgBox(BuildString(LoadResString(cidTryReload), .TargetFile, .ProjectName), vbInformation Or vbYesNo) Then
            'Make sure that the project file is writable if a library change was made that
            'requires an existing References line to be updated. We don't care if the project
            'file doesn't exist because firing the Save Project command will save it for us
            'if a file has not been specified.
            .ProjectFile = m_ActiveProject.FileName
            If .fRefInfoChange Then
                On Error Resume Next
                If GetAttr(.ProjectFile) And vbReadOnly Then
                    If Err = 0 Then
                        MsgBox BuildString(LoadResString(cidReadOnlyProjectFile), .ProjectFile), vbInformation
                        'Might have generated the file already, kill it
                        If Len(.NewFile) Then SaveActiveRefKillNewFile Locals
                        Exit Sub
                    End If
                End If
                On Error GoTo 0
            End If
                
            'Make sure the current project is saved
            If Not SaveActiveRefSaveProject Then
                'Can't save project file because a SaveAs or some other dialog
                'came up. There's not much that can be done here except to
                'let the user specify file names then come back to this. Note
                'that VBProjects.AddFromFile automatically saves everything with
                'default file names, but that isn't a good thing either. It's
                'better to prompt and let the user Save a second time.
                If Len(.NewFile) Then SaveActiveRefKillNewFile Locals
                Exit Sub
            End If
            
            'Regenerate the file if we haven't done so yet. There is a small
            'chance this will fail, so we make sure it can be done before the
            'current IDE state changes.
            If Len(.NewFile) = 0 Then
                SaveActiveRefGenLibraryFile Locals, fContinue
                If Not fContinue Then Exit Sub
            End If
                
            'Go ahead and reload the project
            If Not SaveActiveRefReloadProject(Locals) Then
                'We're completely out of things to try. Offer to save this
                'as a new file. Note that it is only possible to add this
                'as a reference if the library name and LIBID have changed,
                'but they have to retry the entire file save command to make
                'this happen.
                If vbYes = MsgBox(BuildString(LoadResString(cidFileLocked), .TargetFile), vbYesNo Or vbInformation Or vbDefaultButton2) Then
                    strSaveAsPath = PromptForFileName(UserDocument.hWnd)
                    If Len(strSaveAsPath) Then
                        On Error Resume Next
                        Kill strSaveAsPath
                        On Error GoTo 0
                        Name Locals.NewFile As strSaveAsPath
                        Locals.NewFile = vbNullString
                        Set m_ActiveRef = Nothing
                        Set m_Libraries = Nothing
                        Set LibViewer.CurrentLibrary = Nothing
                        m_fDirty = True
                        Dirty = False
                    Else
                        SaveActiveRefKillNewFile Locals
                    End If
                Else
                    'Leave the status quo
                    SaveActiveRefKillNewFile Locals
                End If
            Else
                m_fDirty = True
                Dirty = False
            End If
        Else
            If Len(.NewFile) Then SaveActiveRefKillNewFile Locals
        End If
    End With
    Exit Sub
Error:
    MsgBox Err.Description, vbExclamation
    If Len(Locals.NewFile) Then SaveActiveRefKillNewFile Locals
End Sub
Private Function SaveActiveRefReloadProject(Locals As SaveActiveRefLocals) As Boolean
Dim fUseGroup As Boolean
Dim GroupFile As String
Dim Thunk As PushParamThunk
    On Error GoTo Error
    Set FileControlEvents = m_VBInst.Events.FileControlEvents(Nothing)
    With m_VBInst.VBProjects
        m_cRemainingProjects = .Count
        GroupFile = .FileName
        If m_cRemainingProjects = 1 Then
            'We have a project group only if a real file name is specified.
            On Error Resume Next
            If Len(Dir$(GroupFile)) Then
                fUseGroup = Err = 0
            End If
            On Error GoTo 0
        Else
            fUseGroup = True
        End If
        
        'Establish the old and the new RefInfo lines
        If Locals.fRefInfoChange Then
            With m_ActiveRef
                Locals.ReferenceLineStart = "Reference=*\G" & .Guid & "#" & Hex$(.Major) & "." & Hex$(.Minor) & "#"
            End With
        End If
        
        'Clear out all possible references on our side to the current and references
        Set ReferencesEvents = Nothing
        Set m_Libraries = Nothing
        Set m_ActiveProject = Nothing
        Set m_ActiveRef = Nothing
        
        'The LibViewer also needs to be cleared as it also holds references
        'to other typelibs in the project, which may in turn reference this one.
        Set LibViewer.CurrentLibrary = Nothing
        
        'Set up callback mechanism for the AfterCloseFile event
        InitPushParamThunk Thunk, VarPtr(Locals), AddressOf SaveActiveRefMakeReloadModifications
        m_pfnAfterCloseFile = Thunk.pfn
        If fUseGroup Then
            .AddFromFile GroupFile, True
        Else
            .AddFromFile Locals.ProjectFile, True
        End If
        
        'The update was successful if NewFile is empty
        SaveActiveRefReloadProject = Len(Locals.NewFile) = 0
        
        'All current settings should now restore correctly
        Set m_ActiveProject = .Item(Locals.ProjectName)
        Set ReferencesEvents = m_VBInst.Events.ReferencesEvents(m_ActiveProject)
        If SaveActiveRefReloadProject Then
            'Reload the library viewer to contain the new library
            LoadLibViewer LoadTypeLibEx(Locals.TargetFile, REGKIND_NONE), Locals.NewLibName
        Else
            'Reload the library viewer by copying the changes back out of the saved file
            LoadLibViewer LoadTypeLibEx(Locals.NewFile, REGKIND_NONE), Locals.RefName
        End If
    End With
    Set FileControlEvents = Nothing
    Exit Function
Error:
    Set FileControlEvents = Nothing
    MsgBox Err.Description, vbInformation
End Function
Private Function SaveActiveRefSaveProject() As Boolean
Dim Proj As VBProject
    m_VBInst.CommandBars.FindControl(, 3).Execute
    DoEvents 'Needed to get the command through
    For Each Proj In m_VBInst.VBProjects
        'Proj.Saved is a bad boolean (it is never -1), don't use Not Proj.Saved
        If 0 = Proj.Saved Then Exit Function 'This means a file dialog came up
    Next
    SaveActiveRefSaveProject = True
End Function
Private Sub SaveActiveRefLoadFiles(Locals As SaveActiveRefLocals, fContinue As Boolean)
Dim Refs As References
Dim Ref As Reference
Dim iFile As Long
    With Locals
        Set Refs = m_ActiveProject.References
        .iActiveRef = -1
        For Each Ref In Refs
            iFile = iFile + 1
            If Ref Is m_ActiveRef Then
                fContinue = True
                .iActiveRef = iFile
                .cRefs = Refs.Count
                .RefName = Ref.Name 'Save to enable restoring
                ReDim .Files(.iActiveRef To .cRefs)
                .Files(iFile) = .TargetFile
                .fNameChange = StrComp(.NewLibName, .RefName, vbTextCompare)
                .fRefInfoChange = .fRefInfoChange Or .fNameChange
                .StartLibGuid = GUIDFromString(Ref.Guid)
                .fGuidChange = IsEqualGUID(.NewLibGuid, .StartLibGuid) = BOOL_FALSE
                .fRefInfoChange = .fRefInfoChange Or .fGuidChange
                .StartLibMajor = Ref.Major
                .fRefInfoChange = .fRefInfoChange Or (.NewLibMajor = .StartLibMajor)
                .StartLibMinor = Ref.Minor
                .fRefInfoChange = .fRefInfoChange Or (.NewLibMinor = .StartLibMinor)
            Else
                If IsEqualGUID(.NewLibGuid, GUIDFromString(Ref.Guid)) Then
                    MsgBox BuildString(cidGuidConflict, Ref.Guid), vbExclamation
                    fContinue = False
                    Exit Sub
                ElseIf 0 = StrComp(.NewLibName, Ref.Name, vbTextCompare) Then
                    MsgBox BuildString(cidNameInUse, .NewLibName), vbExclamation
                    fContinue = False
                    Exit Sub
                End If
                If Not .iActiveRef Then
                    'We've already seen the active ref, save files off
                    If Ref.IsBroken Or (Ref.Type = vbext_rk_Project) Then Exit Sub 'Not fatal, but the refs path doesn't work
                    .Files(iFile) = LibPathFromRef(Ref)
                    If Len(.Files(iFile)) = 0 Then Exit Sub
                End If
            End If
        Next Ref