edittlb.bas

VB圣经

Attribute VB_Name = "modEditTLB"
Option Explicit

'Localized resource identifiers
Public Const cidAddinShortDesc As Integer = 100
Public Const cidAddinLongDesc As Integer = 101
Public Const cidAddInMenu As Integer = 102
Public Const cidAppTitle As Integer = 103
Public Const cidReferenceInvalid As Integer = 104
Public Const cidReadOnlyFile As Integer = 105
Public Const cidGuidConflict As Integer = 106
Public Const cidNameInUse As Integer = 107
Public Const cidLibNameAndGuidChange As Integer = 108
Public Const cidLibNameNoGuidChange As Integer = 109
Public Const cidLibGuidNoNameChange As Integer = 110
Public Const cidSaveAsTitle As Integer = 111
Public Const cidSaveAsFilter As Integer = 112
Public Const cidSaveAsNotATypeLib As Integer = 113
Public Const cidTryReload As Integer = 114
Public Const cidReadOnlyProjectFile As Integer = 115
Public Const cidFileLocked As Integer = 116
Public Const cidTipProjects As Integer = 117
Public Const cidTipLibraries As Integer = 118
Public Const cidTipNewLibrary As Integer = 119
Public Const cidTipSaveChanges As Integer = 120
Public Const cidTipDiscardChanges As Integer = 121
Public Const cidWindowCaption As Integer = 122
Public Const cidWindowCaptionNewLibrary As Integer = 123
Public Const cidWindowCaptionNoLibrary As Integer = 124
Public Const cidWindowCaptionNoProject As Integer = 125
Public Const cidWindowCaptionDirtyFlag As Integer = 126
Public Const cidNewLibName As Integer = 127

'Nonlocalized strings
Public Const ADDIN_PROGID As String = "PowerVBTLBEditor.Connect"
Public Const ADDIN_DOC_PROGID As String = "PowerVBTLBEditor.MainWindow"
Public Const UNIQUE_APP_ID As String = "PowerVBTLBEditor_1_0"
Public Const REG_CATEGORY As String = "PowerVB AddIns"
Public Const REG_APPSECTION As String = "Edit TLB"
Public Const REG_SHOWONCONNECT As String = "ShowOnConnect"

'Temp file APIs. Need to use ANSI because this add-in can run on Win9x
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 Long) As Long
Private Const MAX_PATH As Integer = 260

'APIs for setting the caption of the document window's parent
Public Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Public Const WM_SETTEXT As Long = &HC
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

'Declares and APIs to prompt for a file name. Note that ComDlg32.ocx is reference
'solely to provide constant values.
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Type NMHDR
    hwndFrom As Long
    idFrom As Long
    Code As Long
End Type
Private Type OFNOTIFY
    hdr As NMHDR
    lpOFN As Long
    pszFile As Long
End Type
Private Const WM_NOTIFY As Long = &H4E
Private Const CDN_FIRST As Long = -601
Private Const CDN_FILEOK As Long = CDN_FIRST - 5
Private Const DWL_MSGRESULT As Long = 0&
Private Const OFN_ENABLEHOOK As Long = &H20
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Type OFNForDeref
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As Long
    lpstrCustomFilter As Long
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As Long 'This is as far as we need
End Type
Private Type DerefOFN
    Owner As ArrayOwner
    pSA() As OFNForDeref
End Type
Private m_DerefOFN As DerefOFN

'A structure to hold all the locals needed for SaveActiveRef. These
'are passed around to its helper functions. It is in this module
'because one of the helper functions is an AddressOf callback, which
'can't be in the DOB.
Public Type SaveActiveRefLocals
    RefName As String       'Info to restore m_ActiveRef
    ProjectName As String   'Info to restore m_ActiveProject
    Files() As String       'Array of file names, includes active ref and all after it
    iActiveRef As Long      '1-base index of active reference, LBound of Files
    cRefs As Long           'Count of references, UBound of Files
    TargetFile As String    'The file that we're updating
    NewFile As String       'The temporary file with the newly generated typelib
    NewLibName As String    'The name of the new library
    NewLibGuid As VBGUID    'The GUID of the new library
    NewLibMajor As Integer  'The MajorVersion of the new library
    NewLibMinor As Integer  'The MinorVersion of the new library
    NewLibLCID As Long      'The LCID of the new library
    NewLibDesc As String    'The description of the new library. Used while regenerating the project file
    StartLibGuid As VBGUID  'The GUID of the original target library
    StartLibMajor As Integer 'The MajorVersion of the original library
    StartLibMinor As Integer 'The MinorVersion of the original library
    StartLibLCID As Long     'The LCID of the original library
    ProjectFile As String    'The project file to edit.
    ReferenceLineStart As String 'The formatted reference line to search for in the ProjectFile
    fRestorableRefs As Boolean 'The references collection can be repopulated without a library reload
    fRefInfoChange As Boolean  'The libraries GUID/Major/Minor/Name values have change
    fGuidChange As Boolean     'The libraries GUID has changed-prompt for a SaveAs
    fNameChange As Boolean     'The libraries name has changed-prompt for a SaveAs
End Type

Public Function BuildString(StartString As String, ParamArray Inserts() As Variant) As String
Dim i As Integer
Dim iPos As Integer
    'BuildString = LoadResString(idStart)
    BuildString = StartString
    For i = 0 To UBound(Inserts)
        iPos = InStr(1, BuildString, "|" & CStr(i + 1))
        BuildString = Left$(BuildString, iPos - 1) & Inserts(i) & Mid$(BuildString, iPos + 2)
    Next i
End Function
 
Public Function TempFile(strBaseName As String) As String
    TempFile = String$(MAX_PATH, 0) 'More space than we need, but it can't hurt with DBCS issues
    GetTempPath MAX_PATH, StrPtr(TempFile)
    GetTempFileName StrPtr(TempFile), strBaseName, 0, StrPtr(TempFile)
    TempFile = StrConv(TempFile, vbUnicode)
    TempFile = Left$(TempFile, InStr(TempFile, vbNullChar) - 1)
End Function

Public Function PromptForFileName(ByVal hWnd As Long) As String
Dim ofn As OPENFILENAME
    'Make sure we're ready to dereference an OPENFILENAME in the callback
    With m_DerefOFN
        If .Owner.SA.cDims = 0 Then InitArrayOwner .Owner, LenB(.pSA(0)), 0
    End With
    
    With ofn
        .lStructSize = Len(ofn)
        .lpstrDefExt = "tlb"
        .lpstrFilter = Replace(LoadResString(cidSaveAsFilter), "|", vbNullChar)
        .hwndOwner = hWnd
'Dim Pos As Long
'        .lpstrFilter = LoadResString(cidSaveAsFilter)
'        Do
'            Pos = InStr(Pos + 1, .lpstrFilter, "|")
'            If Pos = 0 Then Exit Do
'            Mid$(.lpstrFilter, Pos, 1) = vbNullChar
'        Loop
        .Flags = OFN_ENABLEHOOK Or cdlOFNOverwritePrompt Or cdlOFNNoReadOnlyReturn Or cdlOFNPathMustExist Or cdlOFNExplorer Or cdlOFNHideReadOnly
        .lpstrFile = String$(512, 0)
        .nMaxFile = 512
        .lpfnHook = FuncAddr(AddressOf SaveAsHookProc)
        .lpstrTitle = LoadResString(cidSaveAsTitle)
        If 0 = GetSaveFileName(ofn) Then Exit Function
        PromptForFileName = Left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1)
    End With
End Function
Private Function SaveAsHookProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, lParam As OFNOTIFY) As Long
Dim strFile As String
Dim lpstrFile As Long
    If uMsg = WM_NOTIFY Then
        If lParam.hdr.Code = CDN_FILEOK Then
            With m_DerefOFN
                m_DerefOFN.Owner.SA.pvData = lParam.lpOFN
                lpstrFile = .pSA(0).lpstrFile
            End With
            strFile = StrConv(SysAllocStringByteLen(lpstrFile, lstrlen(lpstrFile)), vbUnicode)
            If Not IsTypeLibEditable(strFile) Then
                Select Case MsgBox(LoadResString(cidSaveAsNotATypeLib), vbInformation Or vbYesNo Or vbDefaultButton2)
                    Case vbYes
                        'Nothing to do, just return zero
                    Case vbNo
                        'Return to the dialog
                        SaveAsHookProc = 1
                        SetWindowLong hWnd, DWL_MSGRESULT, 1
                End Select
            End If
        End If
    End If
End Function

'Returns True if a library is editable or if the specified file does not exist.
Public Function IsTypeLibEditable(FilePath As String) As Boolean
Dim fNum As Integer
Dim fCloseFile As Boolean
Dim iMagic As Long
    On Error GoTo Error
    fNum = FreeFile
    Open FilePath For Binary Access Read As fNum
    fCloseFile = True
    If LOF(fNum) = 0 Then
        IsTypeLibEditable = True
    Else
        Get #fNum, 1, iMagic
        'Make sure this is a (new format) typelib, not a resource in a dll or exe.
        IsTypeLibEditable = iMagic = &H5446534D
    End If
    fCloseFile = False
    Close #fNum
    Exit Function
Error:
    If fCloseFile Then
        Close #fNum
    Else
        IsTypeLibEditable = True 'File doesn't exist
    End If
End Function

Private Function FuncAddr(ByVal pfn As Long) As Long
    FuncAddr = pfn
End Function

'Redirection function for PushParamThunk address
Public Sub SaveActiveRefMakeReloadModifications(Locals As SaveActiveRefLocals)
Dim fCantKill As Boolean
    On Error Resume Next
    SaveActiveRefUnregisterTarget Locals
    Kill Locals.TargetFile
    fCantKill = Err
    On Error GoTo 0
    If fCantKill Then
        SaveActiveRefRegisterTarget Locals
        Exit Sub
    End If
    
    'Move the file
    Name Locals.NewFile As Locals.TargetFile
    
    'Reregister the file
    SaveActiveRefRegisterTarget Locals
    
    'Update the project file. The NewFile name is now available to write to.
    RewriteProjectFile Locals
    
    'This signals that everything worked
    Locals.NewFile = vbNullString
End Sub
Private Sub RewriteProjectFile(Locals As SaveActiveRefLocals)
Dim GuidString As String * 38
Dim strLine As String
Dim fNumDst As Integer
Dim fNumSrc As Integer
Dim fCloseDstFile As Boolean
Dim fCloseSrcFile As Boolean
Dim iPos1 As Long
Dim iPos2 As Long
Dim fFoundLine As Boolean
    
    On Error GoTo Error
    fNumDst = FreeFile
    Open Locals.NewFile For Output As fNumDst
    fCloseDstFile = True
    fNumSrc = FreeFile
    Open Locals.ProjectFile For Input As fNumSrc
    fCloseSrcFile = True
    
    Do Until EOF(fNumSrc)
        Line Input #fNumSrc, strLine
        If InStr(1, strLine, Locals.ReferenceLineStart, vbBinaryCompare) = 1 Then
            fFoundLine = True
            'Need to rewrite the file line. We have all of the information in locals
            'except for the local path to the target file, which can be gleaned from
            'the current setting in the project file.
            'Skip the LCID number
            iPos1 = InStr(Len(Locals.ReferenceLineStart) + 1, strLine, "#", vbBinaryCompare) + 1
            iPos2 = InStr(iPos1, strLine, "#", vbBinaryCompare)
            With Locals
                StringFromGUID2 .NewLibGuid, GuidString
                Print #fNumDst, "Reference=*\G"; GuidString; "#"; _
                                Hex$(.NewLibMajor); "."; Hex$(.NewLibMinor); "#"; Hex$(.NewLibLCID); "#"; _
                                Mid$(strLine, iPos1, iPos2 - iPos1); "#";
                If Len(.NewLibDesc) = 0 Then
                    Print #fNumDst, .NewLibName
                Else
                    Print #fNumDst, .NewLibDesc
                End If
            End With
            
            'Finish up here to avoid the check
            Do Until EOF(fNumSrc)
                Line Input #fNumSrc, strLine
                Print #fNumDst, strLine
            Loop
        Else
            Print #fNumDst, strLine
        End If
    Loop
    fCloseDstFile = False
    Close #fNumDst
    fCloseSrcFile = False
    Close #fNumSrc
    
    If fFoundLine Then
        Kill Locals.ProjectFile
        Name Locals.NewFile As Locals.ProjectFile
    Else
        SaveActiveRefKillNewFile Locals
    End If
    Exit Sub
Error:
    'Not really anything to do here. This is a very unlikely failure
    If fCloseDstFile Then Close #fNumDst
    If fCloseSrcFile Then Close #fNumSrc
    SaveActiveRefKillNewFile Locals
End Sub
Public Sub SaveActiveRefKillNewFile(Locals As SaveActiveRefLocals)
    Debug.Assert Len(Locals.NewFile)
    On Error Resume Next
    Kill Locals.NewFile
    Locals.NewFile = vbNullString
    On Error GoTo 0
End Sub
Public Sub SaveActiveRefUnregisterTarget(Locals As SaveActiveRefLocals)
    On Error Resume Next 'Just in case it isn't registered
    With Locals
        UnRegisterTypeLib .StartLibGuid, .StartLibMajor, .StartLibMinor, .StartLibLCID, SYS_WIN32
    End With
    On Error GoTo 0
End Sub
Public Sub SaveActiveRefRegisterTarget(Locals As SaveActiveRefLocals)
    On Error Resume Next
    'We must use RegisterTypeLib here because LoadTypeLibEx doesn't register it
    'reliably if it already considers this a loaded typelib.
    RegisterTypeLib LoadTypeLibEx(Locals.TargetFile), Locals.TargetFile, vbNullString
    On Error GoTo 0
End Sub