VBA解析复合文档08——应用-解析Thumbs.db

Private Sub Test_ParseThumbs()
    Dim f As CFile
    
    Set f = NewCFile()
    f.OpenFile "C:UsersAdministratorPicturesdyhThumbs.db"
    
    Dim cf As CCompoundFile
    
    Set cf = New CCompoundFile
    
    Dim ret As String
    ret = cf.Parse(f)
    If VBA.Len(ret) Then
        Debug.Print ret
        Exit Sub
    End If
    
    Dim fs() As String
    fs = cf.DirsName()
    
    Dim b() As Byte, bpic() As Byte
    Dim i As Long, j As Long
    For i = 0 To UBound(fs)
        If fs(i) <> "Root Entry" Then
            ret = cf.GetStream(fs(i), b)
            If VBA.Len(ret) Then
                Debug.Print ret
                Exit Sub
            End If
            
            '保存
    '        每一个缩略图IStream的前3个整形不是缩略图的内容，64位电脑就是24个Byte
            ReDim bpic(UBound(b) - 24) As Byte
            For j = 24 To UBound(b)
                bpic(j - 24) = b(j)
            Next
            
            ByteToFile "C:UsersAdministratorPicturesdyhVBAParse" & fs(i) & ".jpg", bpic
        End If
    Next
    
    
    Set cf = Nothing
    Set f = Nothing
End Sub

Function ByteToFile(file_name As String, b() As Byte)
    Dim iFreefile As Integer
    
    iFreefile = VBA.FreeFile()
    Open file_name For Binary As iFreefile
    Put #iFreefile, 1, b
    Close iFreefile
End Function