edittlbexe.bas

此源码为vb圣经编码

Attribute VB_Name = "modEditTLBExe"
Option Explicit
Public Const cidMenuFile As Integer = 101
Public Const cidMenuFileNew As Integer = 102
Public Const cidMenuFileOpen As Integer = 103
Public Const cidMenuFileSave As Integer = 104
Public Const cidMenuFileSaveAs As Integer = 105
Public Const cidMenuFileExit As Integer = 106
Public Const cidAppTitle As Integer = 107
Public Const cidAppCaption As Integer = 108
Public Const cidSaveAsNotATypeLib As Integer = 109
Public Const cidSaveAsTitle As Integer = 110
Public Const cidSaveAsFilter As Integer = 111
Public Const cidOpenTitle As Integer = 112
Public Const cidOpenFilter As Integer = 113
Public Const cidOpenNotATypeLib As Integer = 114
Public Const cidNewLibName As Integer = 115
Public Const cidSavePrompt As Integer = 116
Public Const cidNewLibrary As Integer = 117
Public Const cidDirtyFlag As Integer = 118

'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 Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (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

Public Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long

Public Function PromptForSaveAsFileName(ByVal hWnd As Long, StartFile As String) 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)
        If Len(StartFile) Then CopyMemory ByVal StrPtr(.lpstrFile), ByVal StrPtr(StartFile), LenB(StartFile) + 2
        .nMaxFile = 512
        .lpfnHook = FuncAddr(AddressOf SaveAsHookProc)
        .lpstrTitle = LoadResString(cidSaveAsTitle)
        If 0 = GetSaveFileName(ofn) Then Exit Function
        PromptForSaveAsFileName = Left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1)
    End With
End Function
Private Function OpenHookProc(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
Dim ptlib As ITypeLib
    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)
            On Error Resume Next
            Set ptlib = LoadTypeLibEx(strFile, REGKIND_NONE)
            On Error GoTo 0
            If ptlib Is Nothing Then
                MsgBox BuildString(LoadResString(cidOpenNotATypeLib), strFile), vbInformation
                'Return to the dialog
                OpenHookProc = 1
                SetWindowLong hWnd, DWL_MSGRESULT, 1
            End If
        End If
    End If
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

Public Function PromptForOpenFileName(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)
        .hwndOwner = hWnd
        .lpstrFilter = Replace(LoadResString(cidOpenFilter), "|", vbNullChar)
'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
        .lpfnHook = FuncAddr(AddressOf OpenHookProc)
        .Flags = OFN_ENABLEHOOK Or cdlOFNFileMustExist Or cdlOFNPathMustExist Or cdlOFNExplorer Or cdlOFNHideReadOnly
        .lpstrFile = String$(512, 0)
        .nMaxFile = 512
        .lpstrTitle = LoadResString(cidOpenTitle)
        If 0 = GetOpenFileName(ofn) Then Exit Function
        
        'Guaranteed by hook proc to be a valid typelib file
        PromptForOpenFileName = Left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1)
    End With
End Function

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

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