Leer Propiedades Extendidas de Archivos

[MrLake]

¿Alguien sabe como puedo leer Propiedades Extendidas de un Archivo, los que aparecen en la sección "Summary" al darle clic derecho "Properties"?

Lo que necesito es poder leer los atributos de "Title", "Subject", "Author", "Keywords" etc.

Gracias

[vbx3m]

Global c As Integer
Public Function NullPad(strData As String) As String
If strData = "" Then Exit Function
Dim lenData As Long
For i = 1 To Len(strData)
tempStr = tempStr & Chr(0) & Mid(strData, i, 1)
Next
NullPad = Chr(1) & tempStr
End Function
Public Function ReplaceIt(Original As Variant, Item As String, Replace As String) As String
If InStr(Original, Item) = False Then
ReplaceIt = Original
Exit Function
End If
nStage$ = Original
Do Until InStr(nStage$, Item) = 0
lSide$ = Left$(nStage$, InStr(nStage$, Item) - 1)
rSide$ = Right$(nStage$, (Len(nStage$) - Len(lSide$) - Len(Item)))
nStage$ = lSide$ & Replace & rSide$
Loop
ReplaceIt = nStage$
End Function
Public Function GetCompanyName(strFile As String)
Dim tempFile As String
Dim pos As Long
Dim StartPos As Long, EndPos As Long
fileText$ = "CompanyName"
nextText$ = "FileDescription"
Open strFile For Binary As #1
tempFile = Space(LOF(1))
Get #1, , tempFile
Close #1
pos = InStr(tempFile, NullPad("StringFileInfo"))
If pos = 0 Then
pos = InStr(tempFile, "StringFileInfo")
If pos = 0 Then pos = 1
pnStart = InStr(pos, tempFile, fileText$)
fileLength% = 12
Else
pnStart = InStr(pos, tempFile, NullPad(fileText$))
nextText$ = NullPad(nextText$)
fileLength% = 26
End If
If pnStart > 0 Then
StartPos = pnStart + fileLength%
EndPos = InStr(StartPos, tempFile, String(3, Chr(0)))
If InStr(Mid(tempFile, StartPos, EndPos - StartPos), nextText$) <> 0 Then
For i = 1 To 255
If CInt(Asc(Mid(tempFile, StartPos + i, 1))) <= 31 Then
EndPos = StartPos + (i - 1)
Exit For
End If
Next i
c = c + 1
End If
FileInfo = Mid(tempFile, StartPos, EndPos - StartPos)
GetCompanyName = ReplaceIt(FileInfo, Chr(0), "")
End If
End Function
Public Function GetFileDescription(strFile As String)
Dim tempFile As String
Dim pos As Long
Dim StartPos As Long, EndPos As Long
fileText$ = "FileDescription"
nextText$ = "FileVersion"
Open strFile For Binary As #1
tempFile = Space(LOF(1))
Get #1, , tempFile
Close #1
pos = InStr(tempFile, NullPad("StringFileInfo"))
If pos = 0 Then
pos = InStr(tempFile, "StringFileInfo")
If pos = 0 Then pos = 1
pnStart = InStr(pos, tempFile, fileText$)
fileLength% = 16
Else
pnStart = InStr(pos, tempFile, NullPad(fileText$))
nextText$ = NullPad(nextText$)
fileLength% = 34
End If
If pnStart > 0 Then
StartPos = pnStart + fileLength%
EndPos = InStr(StartPos, tempFile, String(3, Chr(0)))
If InStr(Mid(tempFile, StartPos, EndPos - StartPos), nextText$) <> 0 Then
For i = 1 To 255
If CInt(Asc(Mid(tempFile, StartPos + i, 1))) <= 31 Then
EndPos = StartPos + i
Exit For
End If
Next i
c = c + 1
End If
FileInfo = Mid(tempFile, StartPos, EndPos - StartPos)
GetFileDescription = ReplaceIt(FileInfo, Chr(0), "")
End If
End Function
Public Function GetLegalCopyright(strFile As String)
Dim tempFile As String
Dim pos As Long
Dim StartPos As Long, EndPos As Long
fileText$ = "LegalCopyright"
nextText$ = "OriginalFilename"
Open strFile For Binary As #1
tempFile = Space(LOF(1))
Get #1, , tempFile
Close #1
pos = InStr(tempFile, NullPad("StringFileInfo"))
If pos = 0 Then
pos = InStr(tempFile, "StringFileInfo")
If pos = 0 Then pos = 1
pnStart = InStr(pos, tempFile, fileText$)
fileLength% = 16
Else
pnStart = InStr(pos, tempFile, NullPad(fileText$))
fileLength% = 30
End If
If pnStart > 0 Then
StartPos = pnStart + fileLength%
EndPos = InStr(StartPos, tempFile, String(3, Chr(0)))
If InStr(Mid(tempFile, StartPos, EndPos - StartPos), nextText$) <> 0 Then
For i = 1 To 255
If CInt(Asc(Mid(tempFile, StartPos + i, 1))) <= 31 Then
EndPos = StartPos + (i - 1)
Exit For
End If
Next i
c = c + 1
End If
FileInfo = Mid(tempFile, StartPos, EndPos - StartPos)
GetLegalCopyright = ReplaceIt(FileInfo, Chr(0), "")
End If
End Function
Public Function GetProductName(strFile As String)
Dim tempFile As String
Dim pos As Long
Dim StartPos As Long, EndPos As Long
fileText$ = "ProductName"
nextText$ = "ProductVersion"
Open strFile For Binary As #1
tempFile = Space(LOF(1))
Get #1, , tempFile
Close #1
pos = InStr(tempFile, NullPad("StringFileInfo"))
If pos = 0 Then
pos = InStr(tempFile, "StringFileInfo")
If pos = 0 Then pos = 1
pnStart = InStr(pos, tempFile, fileText$)
fileLength% = 12
Else
pnStart = InStr(pos, tempFile, NullPad(fileText$))
fileLength% = 26
End If
If pnStart > 0 Then
StartPos = pnStart + fileLength%
EndPos = InStr(StartPos, tempFile, String(3, Chr(0)))
If InStr(Mid(tempFile, StartPos, EndPos - StartPos), nextText$) <> 0 Then
For i = 1 To 255
If CInt(Asc(Mid(tempFile, StartPos + i, 1))) <= 31 Then
EndPos = StartPos + (i - 1)
Exit For
End If
Next i
c = c + 1
End If
FileInfo = Mid(tempFile, StartPos, EndPos - StartPos)
GetProductName = ReplaceIt(FileInfo, Chr(0), "")
End If
End Function
Public Function GetFileVersion(strFile As String)
Dim tempFile As String
Dim pos As Long
Dim StartPos As Long, EndPos As Long
fileText$ = "FileVersion"
nextText$ = "InternalName"
Open strFile For Binary As #1
tempFile = Space(LOF(1))
Get #1, , tempFile
Close #1
pos = InStr(tempFile, NullPad("StringFileInfo"))
If pos = 0 Then
pos = InStr(tempFile, "StringFileInfo")
If pos = 0 Then pos = 1
pnStart = InStr(pos, tempFile, fileText$)
fileLength% = 12
Else
pnStart = InStr(pos, tempFile, NullPad(fileText$))
fileLength% = 26
End If
If pnStart > 0 Then
StartPos = pnStart + fileLength%
EndPos = InStr(StartPos, tempFile, String(3, Chr(0)))
If InStr(Mid(tempFile, StartPos, EndPos - StartPos), nextText$) <> 0 Then
For i = 1 To 255
If CInt(Asc(Mid(tempFile, StartPos + i, 1))) <= 31 Then
EndPos = StartPos + (i - 1)
Exit For
End If
Next i
c = c + 1
End If
FileInfo = Mid(tempFile, StartPos, EndPos - StartPos)
GetFileVersion = ReplaceIt(FileInfo, Chr(0), "")
End If
End Function
Public Function GetProductVersion(strFile As String)
Dim tempFile As String
Dim pos As Long
Dim StartPos As Long, EndPos As Long
fileText$ = "ProductVersion"
nextText$ = "VarFileInfo"
Open strFile For Binary As #1
tempFile = Space(LOF(1))
Get #1, , tempFile
Close #1
pos = InStr(tempFile, NullPad("StringFileInfo"))
If pos = 0 Then
pos = InStr(tempFile, "StringFileInfo")
If pos = 0 Then pos = 1
pnStart = InStr(pos, tempFile, fileText$)
fileLength% = 16
Else
pnStart = InStr(pos, tempFile, NullPad(fileText$))
fileLength% = 30
End If
If pnStart > 0 Then
StartPos = pnStart + fileLength%
EndPos = InStr(StartPos, tempFile, String(3, Chr(0)))
If InStr(Mid(tempFile, StartPos, EndPos - StartPos), nextText$) <> 0 Then
For i = 1 To 255
If CInt(Asc(Mid(tempFile, StartPos + i, 1))) <= 31 Then
EndPos = StartPos + (i - 1)
Exit For
End If
Next i
c = c + 1
End If
FileInfo = Mid(tempFile, StartPos, EndPos - StartPos)
GetProductVersion = ReplaceIt(FileInfo, Chr(0), "")
End If
End Function
Public Function GetInternalName(strFile As String)
Dim tempFile As String
Dim pos As Long
Dim StartPos As Long, EndPos As Long
fileText$ = "InternalName"
nextText$ = "LegalCopyright"
Open strFile For Binary As #1
tempFile = Space(LOF(1))
Get #1, , tempFile
Close #1
pos = InStr(tempFile, NullPad("StringFileInfo"))
If pos = 0 Then
pos = InStr(tempFile, "StringFileInfo")
If pos = 0 Then pos = 1
pnStart = InStr(pos, tempFile, fileText$)
fileLength% = 17
Else
pnStart = InStr(pos, tempFile, NullPad(fileText$))
fileLength% = 26
End If
If pnStart > 0 Then
StartPos = pnStart + fileLength%
EndPos = InStr(StartPos, tempFile, String(3, Chr(0)))
If InStr(Mid(tempFile, StartPos, EndPos - StartPos), nextText$) <> 0 Then
For i = 1 To 255
If CInt(Asc(Mid(tempFile, StartPos + i, 1))) <= 31 Then
EndPos = StartPos + (i - 1)
Exit For
EndIf
Next i
c = c + 1
EndIf
FileInfo = Mid(tempFile, StartPos, EndPos - StartPos)
GetInternalName = ReplaceIt(FileInfo, Chr(0), "")
EndIf
End Function
Public Function GetOriginalFilename(strFile As String)
Dim tempFile As String
Dim pos As Long
Dim StartPos As Long, EndPos As Long
fileText$ = "OriginalFilename"
nextText$ = "ProductName"
Open strFile For Binary As #1
tempFile = Space(LOF(1))
Get #1, , tempFile
Close #1
pos = InStr(tempFile, NullPad("StringFileInfo"))
If pos = 0 Then
pos = InStr(tempFile, "StringFileInfo")
If pos = 0 Then pos = 1
pnStart = InStr(pos, tempFile, fileText$)
fileLength% = 20
Else
pnStart = InStr(pos, tempFile, NullPad(fileText$))
fileLength% = 34
EndIf
If pnStart > 0 Then
StartPos = pnStart + fileLength%
EndPos = InStr(StartPos, tempFile, String(3, Chr(0)))
If InStr(Mid(tempFile, StartPos, EndPos - StartPos), nextText$) <> 0 Then
For i = 1 To 255
If CInt(Asc(Mid(tempFile, StartPos + i, 1))) <= 31 Then
EndPos = StartPos + (i - 1)
Exit For
End If
Next i
c = c + 1
EndIf
FileInfo = Mid(tempFile, StartPos, EndPos - StartPos)
GetOriginalFilename = ReplaceIt(FileInfo, Chr(0), "")
EndIf
End Function

[vbx3m]

MsgBox ("Compañia: " & GetCompanyName("ruta") & Chr(13) + Chr(10) & _ "Descripcion de archivo: " & GetFileDescription("ruta") & _
GetLegalCopyright("ruta") & Chr(13) + Chr(10) & _
"Nombre del producto" & GetProductName("ruta") & Chr(13) + Chr(10) & _ "Version de archivo: " & GetFileVersion("ruta") & Chr(13) + Chr(10) & _
"Version del producto: " & GetProductVersion("ruta") & _
Chr(13) + Chr(10) & "Nombre interno: " & GetInternalName("ruta") & _
Chr(13) + Chr(10) & "Nombre original: " & GetOriginalFilename("ruta"))

Espero te sirva...

[MrLake]

Muchas gracias lo voy a revisar