dumpclassdata.bas

VB圣经

Attribute VB_Name = "modMain"
Option Explicit

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 GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Const OFN_HIDEREADONLY              As Long = &H4
Private Const OFN_PATHMUSTEXIST             As Long = &H800
Private Const OFN_FILEMUSTEXIST             As Long = &H1000
Private Const OFN_EXPLORER                  As Long = &H80000        'new look commdlg

Sub Main()
Dim pCF2 As IClassFactory2
Dim hModDll As Long
Dim strFile As String
Dim TInfo As TypeInfo
Dim strOutput As String
Dim strLicKey As String
Dim strName As String
Dim strClassType As String
Dim Concat As SmartConcat
Dim TypeFlags As TypeFlags
Dim ResetError As ResetError
Dim ofn As OPENFILENAME
    'Get the file from the command line
    strFile = Trim$(Command$)
    
    'If one wasn't provided, then use a dialog
    If Len(strFile) = 0 Then
        With ofn
            .lStructSize = LenB(ofn)
            .lpstrFilter = "Type Libraries" & vbNullChar & "*.dll;*.ocx;*.tlb;*.olb;*.exe" & vbNullChar & "All Files" & vbNullChar & "*.*" & vbNullChar & vbNullChar
            .Flags = OFN_FILEMUSTEXIST Or OFN_PATHMUSTEXIST Or OFN_EXPLORER Or OFN_HIDEREADONLY
            .lpstrFile = String$(512, 0)
            .nMaxFile = 512
            .lpstrTitle = App.Title
            If 0 = GetOpenFileName(ofn) Then Exit Sub
            strFile = Left$(.lpstrFile, InStr(1, .lpstrFile, vbNullChar) - 1)
        End With
    End If
    
    On Error GoTo BadFile
    With New TypeLibInfo
        .ContainingFile = strFile
        On Error Resume Next
        InitVBoost
        InitResetError ResetError
        Set Concat = New SmartConcat
        Concat.Separator = vbCrLf
        For Each TInfo In .CoClasses
            With TInfo
                TypeFlags = .AttributeMask
                If TypeFlags And TYPEFLAG_FCONTROL Then
                    strClassType = " control"
                Else
                    strClassType = " class"
                End If
                strName = .Name
                If TypeFlags And TYPEFLAG_FLICENSED Then
                    Set pCF2 = GetDllClassObject(strFile, GUIDFromString(.Guid), hModDll)
                    If Not pCF2 Is Nothing Then
                        If Not pCF2 Is Nothing Then
                            Concat.AddString "'" & strName & strClassType
                            Concat.AddString "Private Const strCLSID_" & strName & " As String = """ & .Guid & """"
                            strLicKey = pCF2.RequestLicKey
                            If Len(strLicKey) Then
                                Concat.AddString "Private Const RTLic_" & strName & " As String = """ & strLicKey & """"
                            End If
                        Else
                        End If
                        Concat.AddString vbNullString
                        Set pCF2 = Nothing
                    End If
                Else
                    Concat.AddString "'" & strName & strClassType
                    Concat.AddString "Private Const strCLSID_" & strName & " As String = """ & .Guid & """"
                    Concat.AddString vbNullString
                End If
            End With
        Next
    End With
    TestUnloadDll hModDll
    strOutput = Concat.GenerateCurrentString
    Clipboard.Clear
    Clipboard.SetText strOutput
    MsgBox "The following data has been placed on the clipboard: " & vbCrLf & vbCrLf & strOutput
    Exit Sub
BadFile:
    MsgBox "'" & strFile & "'" & " is not a valid file."
End Sub