connect.dsr

VB圣经

    GetTempFileName StrPtr(TempFile), strBaseName, 0, StrPtr(TempFile)
    TempFile = StrConv(TempFile, vbUnicode)
    TempFile = Left$(TempFile, InStr(TempFile, vbNullChar) - 1)
End Function

Private Sub MenuHandler_Click(ByVal CommandBarControl As Object, Handled As Boolean, CancelDefault As Boolean)
Dim TLInfOCX As TLI.TypeLibInfo
Dim TLInfTmp As New TLI.TypeLibInfo
Dim CCInfo As TLI.CoClassInfo

Dim ref As VBIDE.Reference
Dim refPath As String
Dim refName As String

Dim strNoFile As String
Dim vbProj As VBIDE.VBProject
Dim strProjPath As String
Dim refOurs As VBIDE.Reference
Dim strTLBName As String
Dim strTLBTmp As String

Dim strTmp As String
Dim fCompareGuids As Boolean
Dim VBPControls As VBA.Collection

Dim ICTL As ICreateTypeLib2
Dim ITLCreate As ITypeLib
Dim CTI As ICreateTypeInfo
Dim NewGuid As VBGUID
Dim hr As Long
Dim fHaveImports As Boolean
Dim tdesc As TYPEDESC
    
    If VBoost Is Nothing Then InitVBoost
    
    Handled = True
    Set vbProj = m_VBInst.ActiveVBProject
    strProjPath = vbProj.FileName
    If Len(strProjPath) = 0 Then
        MsgBox "Please save project file and try again.", vbExclamation
        Exit Sub
    End If
    'Make an ICreateTypeLib pointer to dump data to
    strTLBTmp = TempFile("~FC")
    Set ICTL = CreateTypeLib2(SYS_WIN32, strTLBTmp)
    Set ITLCreate = ICTL
    'Might have change, initialized as needed
    m_ProjPath = vbNullString
    For Each ref In vbProj.References
        'Cache FastCtlTypes reference
        On Error Resume Next
        refPath = ref.FullPath
        If Err Then
            Err.Clear
            'This will happen if the referenced OCA is
            'loaded as a project of this group.  In this
            'case, fall back on the VBP file, which may be
            'out of date, but is better than nothing.
            If VBPControls Is Nothing Then
                Set VBPControls = TLIForRefsFromVBP(strProjPath)
            End If
            Set TLInfOCX = VBPControls.Item(ref.Name)
            If Err Then
                strNoFile = strNoFile & ", " & ref.Name
                refPath = vbNullString
            Else
                refPath = vbNullString
                Set TLInfTmp = Nothing
                GoTo HaveTLInfOCX
            End If
        End If
        On Error GoTo RefError
        If StrComp(".oca", Right$(refPath, 4), vbTextCompare) = 0 Then
            Set TLInfOCX = TLIForOCXFromOCA(refPath)
HaveTLInfOCX:
            If Not TLInfOCX Is Nothing Then
                fCompareGuids = Len(refPath)
                If fCompareGuids Then
                    TLInfTmp.ContainingFile = refPath
                End If
                refName = TLInfOCX.Name
                For Each CCInfo In TLInfOCX.CoClasses
                    'We should be able to check CCInfo.AttributeMask
                    'for TYPEFLAG_FCONTROL, but not all controls
                    'cooperate by setting the correct flags in the
                    'typelib. If we can find a typeinfo with the same
                    'name and GUID in the OCA as in the OCX, then
                    'this isn't an extended control
                    On Error Resume Next
                    If fCompareGuids Then
                        If CCInfo.Guid = TLInfTmp.TypeInfos.NamedItem(CCInfo.Name).Guid Then
                            Set CCInfo = Nothing
                        End If
                    ElseIf 0 = (CCInfo.AttributeMask And TYPEFLAG_FCONTROL) Then
                            Set CCInfo = Nothing
                    End If
                    If Not CCInfo Is Nothing Then
                        Set CTI = ICTL.CreateTypeInfo(CCInfo.Name & cstrNameExtension, TKIND_ALIAS)
                        tdesc.vt = VT_USERDEFINED
                        tdesc.lptdesc_lpadesc_hreftype = CTI.AddRefTypeInfo(CCInfo.ITypeInfo)
                        CTI.SetTypeDescAlias VarPtr(tdesc)
                        CTI.LayOut
                        If Err = 0 Then fHaveImports = True
                        Set CCInfo = Nothing
                    End If
                    On Error GoTo RefError
                Next
            End If
        ElseIf ref.Name = cstrOurLibName Then
            Set refOurs = ref
        End If
NextRef:
    Next
    'The collection may hold a reference which locks
    'the typelib we're overwriting.  Make sure it's released.
    Set VBPControls = Nothing
    On Error GoTo OtherError
    strTLBName = Left$(strProjPath, Len(strProjPath) - 4) & cstrOurLibName & ".tlb"
    If fHaveImports Then
        'Make sure we actually have something to generate
        NewGuid = CoCreateGuid
        ICTL.SetName cstrOurLibName
        ICTL.SetGuid NewGuid
        ICTL.SetDocString LoadResString(103)
        ICTL.SetVersion 1, 0
        ICTL.SetLibFlags LIBFLAG_FHIDDEN
        ICTL.SaveAllChanges
        If Len(strNoFile) Then
            MsgBox "Can't load files for the following referenced libraries:" & _
                vbCrLf & Mid$(strNoFile, 3), vbExclamation
        End If
    Else
        Set ICTL = Nothing
        Set ITLCreate = Nothing
        On Error Resume Next
        Kill strTLBTmp
        On Error GoTo OtherError
    End If
    'Even if we don't have anything to generate, we still
    'want to remove a lib we created earlier
    If Not refOurs Is Nothing Then
        'FullPath only works before removal from the collection
        On Error Resume Next
        strTmp = refOurs.FullPath
        If Err Then
            vbProj.References.Remove refOurs
        Else
            'Make sure TLInfTmp is Nothing.  Otherwise,
            'we could unregister a random library if
            'setting .ContainingFile fails.
            Set TLInfTmp = Nothing
            TLInfTmp.ContainingFile = strTmp
            'We're generating a new GUID for pass, so the
            'previous version of this library needs to be
            'removed from the references collection, unregistered,
            'and deleted (in the case where the project name changed)
            vbProj.References.Remove refOurs
            TLInfTmp.UnRegister
            Set TLInfTmp = Nothing
            Kill strTLBName
            If StrComp(strTmp, strTLBName, vbTextCompare) Then
                'The library has moved or been renamed
                'since the last pass.  Clean up.
                'Note: This errs on the side of too much cleanup,
                'but the library is easy enough to regenerate if
                'a project has been 'saved as' and the old project
                'still needs to be valid.
                'Kill the TLB file we generated
                Kill strTmp
            End If
        End If
        On Error GoTo OtherError
    End If
    If fHaveImports Then
        'Make a final check to see if we need to clean up a previous file
        On Error Resume Next
        TLInfTmp.ContainingFile = strTLBName
        If Err = 0 Then
            TLInfTmp.UnRegister
            Set TLInfTmp = Nothing
            Kill strTLBName
        End If
        On Error GoTo OtherError
        Set ITLCreate = Nothing
        Set ICTL = Nothing 'Remove references to generated typelib
        Name strTLBTmp As strTLBName
        strTLBTmp = vbNullString
        TLInfTmp.ContainingFile = strTLBName
        'If we don't register this here, then the
        'FullPath property fails to work
        TLInfTmp.Register
        vbProj.References.AddFromFile strTLBName
    End If
    Exit Sub
OtherError:
    MsgBox Err.Description, vbExclamation
    If Len(strTLBTmp) Then
        On Error Resume Next
        Kill strTLBTmp
        On Error GoTo 0
    End If
    Exit Sub
RefError:
    Resume NextRef
End Sub