问扫描COM引用以帮助生成无Reg的COM清单

EN

Private Function GetDirCLSIDRefs(Directory As String, CLSIDs As KeyValuePair(Of Guid, String)()) As KeyValuePair(Of String, String())()
   Dim result As New List(Of KeyValuePair(Of String, String()))
   Dim entries = New System.IO.DirectoryInfo(Directory).GetFileSystemInfos()
   For Each entry In entries
      If TypeOf entry Is System.IO.FileInfo AndAlso _
         (entry.Name.EndsWith(".exe") OrElse _
          entry.Name.EndsWith(".dll") OrElse _
          entry.Name.EndsWith(".ocx")) Then
         Dim refs = ScanForCLSIDs(entry.FullName, CLSIDs)
         If refs IsNot Nothing AndAlso refs.Length > 0 Then result.Add(New KeyValuePair(Of String, String())(entry.FullName, refs))
      ElseIf TypeOf entry Is System.IO.DirectoryInfo Then
         result.AddRange(GetDirCLSIDRefs(entry.FullName, CLSIDs))
      End If
   Next
   Return result.ToArray()
End Function

Private Function GetDirCLSIDs(Directory As String) As KeyValuePair(Of Guid, String)()
   Dim result As New List(Of KeyValuePair(Of Guid, String))
   Dim entries = New System.IO.DirectoryInfo(Directory).GetFileSystemInfos()
   For Each entry In entries
      If TypeOf entry Is System.IO.FileInfo AndAlso _
         (entry.Name.EndsWith(".exe") OrElse _
          entry.Name.EndsWith(".dll") OrElse _
          entry.Name.EndsWith(".ocx")) Then
         For Each clsid In GetCLSIDs(entry.FullName)
            result.Add(New KeyValuePair(Of Guid, String)(clsid, entry.FullName))
         Next
      ElseIf TypeOf entry Is System.IO.DirectoryInfo Then
         result.AddRange(GetDirCLSIDs(entry.FullName))
      End If
   Next
   Return result.ToArray()
End Function

Private Function GetCLSIDs(FileName As String) As Guid()
   Dim tlb = TypeLibTypes.Interop.TypeLib.Load(FileName)
   If tlb.GetTypeLib() Is Nothing Then Return {}
   Dim result As New List(Of Guid)
   Try
      For typeIndex As Integer = 0 To tlb.GetTypeInfoCount() - 1
         Using attr = tlb.GetTypeInfo(typeIndex).GetTypeAttr()
            If (attr.wTypeFlags And TypeLibTypes.Interop.TYPEFLAGS.TYPEFLAG_FHIDDEN) = 0 _
               AndAlso attr.typekind = TypeLibTypes.Interop.TYPEKIND.TKIND_COCLASS Then
               result.Add(attr.Guid)
            End If
         End Using
      Next
   Catch ex As System.Runtime.InteropServices.COMException When ex.ErrorCode = &H80029C4A
      Return {}
   End Try
   Return result.ToArray()
End Function

Private Function ScanForCLSIDs(FileName As String, CLSIDFiles As KeyValuePair(Of Guid, String)()) As String()
   Dim content As Byte()
   Using file As New System.IO.FileStream(FileName, IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.ReadWrite)
      content = DirectCast(Array.CreateInstance(GetType(Byte), CInt(file.Length)), Byte())
      file.Read(content, 0, CInt(file.Length))
   End Using
   Dim result As New List(Of String)
   For Each CLSIDFile In CLSIDFiles
      If FindBytes(content, CLSIDFile.Key.ToByteArray()) >= 0 Then
         If Not result.Contains(CLSIDFile.Value) Then result.Add(CLSIDFile.Value)
      End If
   Next
   Return result.ToArray()
End Function

Private Function FindBytes(data As Byte(), pattern As Byte(), Optional start As Integer = 0) As Int32
   If pattern.Length = 0 Then Return -1
   If data.Length = 0 Then Return 0
   Dim search = ProcessSearchPattern(pattern)
   Dim i As Integer = start + pattern.Length - 1
   Do While i < data.Length
      Dim j As Integer = pattern.Length - 1
      Do While j >= 0 AndAlso data(i) = pattern(j)
         i -= 1
         j -= 1
      Loop
      If j < 0 Then Return i + 1
      i += Math.Max(search.Delta1(data(i)), search.Delta2(j))
   Loop
   Return -1
End Function

Private Class SearchPattern
   Public Delta1 As Integer()
   Public Delta2 As Integer()
End Class

Private Class PatternBytes
   Private bytes As Byte()
   Public Sub New(value As Byte())
      bytes = value
   End Sub
   Public Overrides Function GetHashCode() As Integer
      Dim i As Integer = 0
      GetHashCode = 0
      Do While i <= bytes.Length - 4
         GetHashCode = GetHashCode Xor BitConverter.ToInt32(bytes, i)
         i += 4
      Loop
      If i <= bytes.Length - 2 Then
         GetHashCode = GetHashCode Xor BitConverter.ToInt16(bytes, i)
         i += 2
      End If
      If i < bytes.Length Then
         GetHashCode = GetHashCode Xor bytes(i)
      End If
   End Function

   Public Overrides Function Equals(obj As Object) As Boolean
      Dim compare As Byte()
      If TypeOf obj Is PatternBytes Then
         compare = DirectCast(obj, PatternBytes).bytes
      ElseIf TypeOf obj Is Byte() Then
         compare = DirectCast(obj, Byte())
      Else
         Return False
      End If
      If compare.Length <> bytes.Length Then Return False
      For i As Integer = 0 To bytes.Length - 1
         If bytes(i) <> compare(i) Then Return False
      Next
      Return True
   End Function
End Class

Private Function ProcessSearchPattern(pattern As Byte()) As SearchPattern
   Static cache As New Dictionary(Of PatternBytes, SearchPattern)
   ProcessSearchPattern = Nothing
   Dim pb As New PatternBytes(pattern)
   If cache.TryGetValue(pb, ProcessSearchPattern) Then Exit Function
   ProcessSearchPattern = New SearchPattern()
   Dim patLen = pattern.Length
   ProcessSearchPattern.Delta1 = DirectCast(Array.CreateInstance(GetType(Integer), Byte.MaxValue + 1), Integer())
   ProcessSearchPattern.Delta2 = DirectCast(Array.CreateInstance(GetType(Integer), patLen), Integer())
   Dim c As Integer ' Cannot run a For loop to Byte.MaxValue in a Byte!
   Dim i As Integer
   For c = 0 To Byte.MaxValue
      ProcessSearchPattern.Delta1(c) = patLen
   Next
   For i = 0 To patLen - 2
      ProcessSearchPattern.Delta1(pattern(i)) = patLen - 1 - i
   Next

   Dim m As Integer
   Dim lastPrefixIndex = patLen - 1
   Dim isPrefix As Boolean = False
   For i = patLen - 1 To 0 Step -1
      isPrefix = True
      If patLen - i - 2 > 0 Then
         For m = 0 To patLen - i - 2
            If pattern(m) <> pattern(m + i + 1) Then
               isPrefix = False
               Exit For
            End If
         Next
      End If
      If isPrefix Then lastPrefixIndex = i + 1
      ProcessSearchPattern.Delta2(i) = lastPrefixIndex + (patLen - 1 - i)
   Next

   For i = 0 To patLen - 2
      For m = 0 To i - 1
         If pattern(i - m) = pattern(patLen - 1 - m) Then
            Exit For
         End If
         If pattern(i - m) <> pattern(patLen - 1 - m) Then
            ProcessSearchPattern.Delta2(patLen - 1 - m) = patLen - 1 - i + m
         End If
      Next
   Next

   cache.Add(pb, ProcessSearchPattern)
End Function