ocarecordfix.bas

VB圣经

Attribute VB_Name = "modOCARecordFix"
Option Explicit

'Stuff to get the version info. We can only do this on NT or Windows2000
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128      '  Maintenance string for PSS usage
End Type
Private Const VER_PLATFORM_WIN32_NT = 2
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

'We need a temp file. We might as well use the UNICODE APIs since this
'only runs on NT.
Private Declare Function GetTempFileNameW Lib "kernel32" (ByVal lpszPath As Long, ByVal lpPrefixString As Long, ByVal wUnique As Long, ByVal lpTempFileName As Long) As Long
Private Declare Function GetTempPathW Lib "kernel32" (ByVal nBufferLength As Long, ByVal lpBuffer As Long) As Long
Private Const MAX_PATH As Integer = 260

'Resource replacement APIs
Private Declare Function BeginUpdateResourceW Lib "kernel32" (ByVal pFileName As Long, ByVal bDeleteExistingResources As Long) As Long
Private Declare Function UpdateResourceW Lib "kernel32" (ByVal hUpdate As Long, ByVal sType As Long, ByVal sName As Long, ByVal LCID As Integer, ByVal lpData As Long, ByVal cbData As Long) As Long
Private Declare Function EndUpdateResourceW Lib "kernel32" (ByVal hUpdate As Long, ByVal fDiscard As Long) As Long

'APIs to locate the OCX in the OCA
Private Declare Function FindResource Lib "kernel32" Alias "FindResourceA" (ByVal hInstance As Long, ByVal lpName As Any, ByVal lpType As Any) As Long
Private Declare Function LockResource Lib "kernel32" (ByVal hResData As Long) As Long
Private Declare Function LoadResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Const RT_RCDATA As Long = 10

'Declares and APIs to prompt for a file name. Note that ComDlg32.ocx is reference
'solely to provide constant values.
Public 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
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

'Resource constants
Private Const cidAppTitle As Integer = 101
Private Const cidNTRequired As Integer = 102
Private Const cidOpenOCAFilter As Integer = 103
Private Const cidOpenOCATitle As Integer = 104
Private Const cidNoRecordsToUpdate As Integer = 105
Private Const cidRecordsReplaced As Integer = 106

Private GUID_NULL As VBGUID

Sub Main()
Dim strTmpTLB As String
Dim fNum As Integer
Dim Data() As Byte
Dim strOCAFile As String
Dim fQuiet As Boolean
Dim Pos As Long
    
    App.Title = LoadResString(cidAppTitle)
    
    'Make sure this is possible (NT required). Note that this
    'is probably doable on Win9x as well by extracting the 2 resources
    'in the OCA and rebuilding them into a new resource-only Dll, but
    'this is more than I want to do for this problem.
    If Not OSOK Then
        MsgBox LoadResString(cidNTRequired), vbCritical
        Exit Sub
    End If
    
    InitVBoost
    
    'Give the app a chance to run quietly with a /q or -q switch as the
    'first parameter. This isn't overly robust; it is just designed to
    'let this run as part of an automated build process.
    strOCAFile = Trim$(Command$)
    If Len(strOCAFile) Then
        Select Case AscW(strOCAFile)
            Case 45, 47 '- and /
                If Len(strOCAFile) > 1 Then
                    If AscW(LCase$(Mid$(strOCAFile, 2, 1))) = 113 Then 'q
                        fQuiet = True
                    End If
                End If
                Pos = InStr(strOCAFile, " ")
                If Pos Then
                    strOCAFile = Trim$(Mid$(strOCAFile, Pos + 1))
                Else
                    'Let the dialog prompt
                    strOCAFile = vbNullString
                End If
        End Select
    End If
    
    If Len(strOCAFile) = 0 Then
        strOCAFile = PromptForOCAFile
        If Len(strOCAFile) = 0 Then Exit Sub
    End If
    
    On Error GoTo Error
    'Do the bulk of the work in a header file so that the actual OCA
    'is not loaded into memory when we try to write back to it. It is
    'hard to get everything out of the local variables, so we let VB
    'clean up for us.
    strTmpTLB = RegenOCATypeLib(strOCAFile)
    
    If Len(strTmpTLB) = 0 Then
        If Not fQuiet Then MsgBox LoadResString(cidNoRecordsToUpdate), vbInformation
        Exit Sub
    End If
    
    'Modify typelib resource in compatible server
    fNum = FreeFile
    Open strTmpTLB For Binary As #fNum
    ReDim Data(FileLen(strTmpTLB) - 1)
    Get fNum, , Data
    Close #fNum
    Kill strTmpTLB
    
    If ReplaceResource(strOCAFile, "TYPELIB", 1, Data, False) Then
        If Not fQuiet Then MsgBox LoadResString(cidRecordsReplaced), vbInformation
    End If
Error:
    If Err Then MsgBox Err.Description, vbCritical
End Sub

Private Function RegenOCATypeLib(strOCAFile As String) As String
Dim TLInfOCA As TypeLibInfo
Dim TLInfOCX As TypeLibInfo
Dim ptlibOCX As ITypeLib
Dim RI As RecordInfo
Dim TLBMod As TLBModifier
Dim CustTLIB As CustomTypeLib
Dim GuidCur As VBGUID
Dim TITarget As TypeInfo
Dim CVTI As CustomVarTypeInfo
    Set TLInfOCA = TLI.TypeLibInfoFromFile(strOCAFile)
    Set TLInfOCX = TLIForOCXFromOCA(strOCAFile)
    Set ptlibOCX = TLInfOCX.ITypeLib
    'Narrow down the items to records only
    For Each RI In TLInfOCA.Records
        'Make sure this isn't already an alias
        If RI.TypeKind = TKIND_RECORD Then
            'Make sure it actually has a guid
            GuidCur = GUIDFromString(RI.Guid)
            If IsEqualGUID(GUID_NULL, GuidCur) = BOOL_FALSE Then
                'Make sure the item can be found in the OCX
                On Error Resume Next
                Set TITarget = Nothing
                Set TITarget = TLI.TypeInfoFromITypeInfo(ptlibOCX.GetTypeInfoOfGuid(GuidCur))
                On Error GoTo 0
                If Not TITarget Is Nothing Then
                    If TLBMod Is Nothing Then
                        Set TLBMod = New TLBModifier
                        Set TLBMod.StartingLib = TLInfOCA
                        Set CustTLIB = New CustomTypeLib
                        Set CVTI = New CustomVarTypeInfo
                    End If
                    With CustTLIB.AddCustomTypeInfo(RI.Name, TKIND_ALIAS)
                        CVTI.Clear
                        CVTI.SetType , TITarget
                        .SetAlias CVTI
                        Debug.Print RI.Name
                        TLBMod.RedirectType RI, .TypeInfo, True
                    End With
                End If
            End If
        End If
    Next
    If Not TLBMod Is Nothing Then
        RegenOCATypeLib = TempFile("~RF")
        TLBMod.Generate RegenOCATypeLib
    End If
End Function

Private Function OCXRefInfoFromOCA(strOCAFile As String) As String
Dim hInst As Long
Dim hRsrc As Long
Dim hGlobal As Long
Dim pData As Long
Dim dwOffset As Long
    hInst = LoadLibraryEx(strOCAFile, 0, DONT_RESOLVE_DLL_REFERENCES Or LOAD_LIBRARY_AS_DATAFILE)
    If hInst Then
        hRsrc = FindResource(hInst, CLng(1), RT_RCDATA)
        If hRsrc Then
            hGlobal = LoadResource(hInst, hRsrc)
            If hGlobal Then
                pData = LockResource(hGlobal)
                    With VBoost
                        dwOffset = .Deref(.UAdd(pData, 40))
                        pData = .UAdd(pData, dwOffset)
                    End With
                    OCXRefInfoFromOCA = StrConv(SysAllocStringByteLen(pData, lstrlen(pData)), vbUnicode)
            End If
        End If
        FreeLibrary hInst
    End If
End Function

Private Function TLIForOCXFromOCA(strOCAFile As String) As TLI.TypeLibInfo
Dim strOCXData As String
    strOCXData = OCXRefInfoFromOCA(strOCAFile)
    If Len(strOCXData) Then Set TLIForOCXFromOCA = TLIFromRefInfo(strOCXData)
End Function

Private Function TLIFromRefInfo(RefInfo As String) As TLI.TypeLibInfo
Dim MinorVerPos As Integer
Dim MajorVerPos As Integer
Dim LCIDPos As Integer
Dim EndPos As Long
Dim fMoreInfo As Boolean
Dim lPos As Long
    Set TLIFromRefInfo = New TypeLibInfo
    MinorVerPos = InStr(1, RefInfo, "#") + 1
    MajorVerPos = InStr(MinorVerPos, RefInfo, ".") + 1
    LCIDPos = InStr(MinorVerPos, RefInfo, "#") + 1
    EndPos = InStr(LCIDPos, RefInfo, "#")
    fMoreInfo = EndPos
    If EndPos = 0 Then EndPos = Len(RefInfo) + 1
    TLIFromRefInfo.LoadRegTypeLib _
        Mid$(RefInfo, 1, MinorVerPos - 2), _
        CInt(Mid$(RefInfo, MinorVerPos, MajorVerPos - MinorVerPos - 1)), _
        CInt(Mid$(RefInfo, MajorVerPos, LCIDPos - MajorVerPos - 1)), _
        CLng(Mid$(RefInfo, LCIDPos, EndPos - LCIDPos))
End Function

Private Sub ExtractVariantData(VarData As Variant, pData As Long)
Dim vtStart As Integer
Dim vt As Integer
    vtStart = VarType(VarData)
    vt = vbLong
    CopyMemory ByVal VarPtr(VarData), vt, 2
    pData = VarData
    CopyMemory ByVal VarPtr(VarData), vtStart, 2
End Sub

Private Function ReplaceResource(strFile As String, ByVal VType, ByVal vName, bData() As Byte, ByVal fNoDelete As Boolean) As Boolean
Dim pName As Long
Dim pType As Long
Dim hRes As Long
Dim cData As Long
Dim pData As Long
    ExtractVariantData VType, pType
    ExtractVariantData vName, pName
    cData = UBound(bData) + 1
    pData = VarPtr(bData(0))
    hRes = BeginUpdateResourceW(StrPtr(strFile), False)
    If hRes Then
        If Not fNoDelete Then fNoDelete = UpdateResourceW(hRes, pType, pName, 0, 0, 0) 'Delete
        If fNoDelete Then
            If UpdateResourceW(hRes, pType, pName, 0, pData, cData) Then
                ReplaceResource = True
            End If
        End If
        ReplaceResource = 0 <> EndUpdateResourceW(hRes, Not ReplaceResource)
    ElseIf Err.LastDllError Then
        Err.Raise &H80070000 Or Err.LastDllError
    End If
End Function

Private Function OSOK() As Boolean
Dim OSVer As OSVERSIONINFO
    OSVer.dwOSVersionInfoSize = Len(OSVer)
    If GetVersionEx(OSVer) Then
        OSOK = OSVer.dwPlatformId = VER_PLATFORM_WIN32_NT
    End If
End Function

Private Function TempFile(strBaseName As String) As String
    TempFile = String$(MAX_PATH, 0)
    GetTempPathW MAX_PATH, StrPtr(TempFile)
    GetTempFileNameW StrPtr(TempFile), StrPtr(strBaseName), 0, StrPtr(TempFile)
    TempFile = Left$(TempFile, InStr(TempFile, vbNullChar) - 1)
End Function

Private Function PromptForOCAFile() As String
Dim ofn As OPENFILENAME
'Dim Pos As Long
    With ofn
        .lStructSize = Len(ofn)
        .lpstrFilter = Replace(LoadResString(cidOpenOCAFilter), "|", vbNullChar)
'        .lpstrFilter = LoadResString(cidOpenOCAFilter)
'        Do
'            Pos = InStr(Pos + 1, .lpstrFilter, "|")
'            If Pos = 0 Then Exit Do
'            Mid$(.lpstrFilter, Pos, 1) = vbNullChar
'        Loop
        .Flags = cdlOFNFileMustExist Or cdlOFNPathMustExist Or cdlOFNExplorer Or cdlOFNHideReadOnly
        .lpstrFile = String$(512, 0)
        .nMaxFile = 512
        .lpstrTitle = LoadResString(cidOpenOCATitle)
        If 0 = GetOpenFileName(ofn) Then Exit Function
        PromptForOCAFile = Left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1)
    End With
End Function