PROPRIEDADES DE ARQUIVOS ATRAVES DE VBA

CAETANO 28/03/2011 19:01:22
#369523

Boa noite
Encontrei na net um código que retorna uma lista de arquivos com suas propriedades contidos em uma pasta .Os arquivos são mp3.Gostaria que através do Excel , eu informasse novos valores para estas propriedades.
Abaixo esta o código.
Alguem poderia me dar uma ajuda ?
Obrigado

[ô]>>>>>>>>>

Public objShell As IShellDispatch4

Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

[ô]32-bit API declarations
Declare Function SHGetPathFromIDList Lib [Ô]shell32.dll[Ô] _
Alias [Ô]SHGetPathFromIDListA[Ô] (ByVal pidl As Long, ByVal pszPath As String) _
As Long

Declare Function SHBrowseForFolder Lib [Ô]shell32.dll[Ô] _
Alias [Ô]SHBrowseForFolderA[Ô] (lpBrowseInfo As BROWSEINFO) As Long


Sub DisplayMP3Info()
Dim i As Long
Dim Folder As String
Dim StrLen As Long, FolderLen As Long
Dim NameOnly As String
Dim Row As Long

[ô] Prompt for the directory
Folder = GetDirectory([Ô]Select a directory that has MP3 files[Ô])
Set objShell = CreateObject([Ô]Shell.Application[Ô])

FolderLen = Len(Folder)
With Application.FileSearch
.NewSearch
.LookIn = Folder
.SearchSubFolders = True
.FileType = msoFileTypeAllFiles
If .Execute > 1 Then
If .FoundFiles.Count = 0 Then
MsgBox [Ô]Error - No files.[Ô], vbCritical
GoTo ExitSub
Exit Sub
End If
Row = 1
Worksheets([Ô]Sheet1[Ô]).Activate
ActiveSheet.Cells.Clear
With ActiveSheet.Range([Ô]A1:K1[Ô])
.Value = Array([Ô]Path[Ô], [Ô]Filename[Ô], [Ô]Size[Ô], [Ô]Date/Time[Ô], [Ô]Artist[Ô], [Ô]Album Title[Ô], [Ô]Year[Ô], [Ô]Track No.[Ô], [Ô]Genre[Ô], [Ô]Duration[Ô], [Ô]Bit Rate[Ô])
.Font.Bold = True
End With
Application.ScreenUpdating = False
For i = 1 To .FoundFiles.Count
If i Mod (100) = 0 Then
DoEvents
Application.StatusBar = [Ô]Working on [Ô] & i & [Ô] of [Ô] & .FoundFiles.Count
End If
If Right(.FoundFiles(i), 3) = [Ô]mp3[Ô] Then
Row = Row + 1
[ô]Parse the directory path to get genre, artist, and album name, and song title
ActiveSheet.Cells(Row, 1) = .FoundFiles(i)
ActiveSheet.Cells(Row, 2) = FileNameOnly(.FoundFiles(i))
ActiveSheet.Cells(Row, 3) = FileLen(.FoundFiles(i)) [ô] file size
ActiveSheet.Cells(Row, 4) = FileDateTime(.FoundFiles(i)) [ô]date
ActiveSheet.Cells(Row, 5) = GetMP3TagInfo(.FoundFiles(i), 16) [ô]artist
ActiveSheet.Cells(Row, 6) = GetMP3TagInfo(.FoundFiles(i), 17) [ô]album title
ActiveSheet.Cells(Row, 7) = GetMP3TagInfo(.FoundFiles(i), 18) [ô]year
ActiveSheet.Cells(Row, 8) = GetMP3TagInfo(.FoundFiles(i), 19) [ô]track number
ActiveSheet.Cells(Row, 9) = GetMP3TagInfo(.FoundFiles(i), 20) [ô]duration
ActiveSheet.Cells(Row, 10) = GetMP3TagInfo(.FoundFiles(i), 21) [ô]genre
ActiveSheet.Cells(Row, 11) = GetMP3TagInfo(.FoundFiles(i), 22) [ô]bit rate
End If
Next i
End If
End With
ExitSub:
[ô]update the pivot table
ActiveSheet.UsedRange.Name = [Ô]Data[Ô]
Worksheets([Ô]pivot[Ô]).PivotTables([Ô]PivotTable1[Ô]).PivotCache.Refresh

Set objShell = Nothing
Application.StatusBar = False
End Sub

Function GetMP3TagInfo(FolderName, ItemNum)
Dim strFilename
Dim objFolder As Folder3
Dim objFolderItem As FolderItem2
Dim FileName As String

FileName = FileNameOnly(FolderName)
Set objFolder = objShell.Namespace(Left(FolderName, Len(FolderName) - Len(FileName)))
Set objFolderItem = objFolder.ParseName(FileName)
GetMP3TagInfo = objFolder.GetDetailsOf(objFolderItem, ItemNum)
End Function


Function FileNameOnly(FullPath) As String
Dim i As Long
Dim FN As String
If Right(FullPath, 1) = [Ô]\[Ô] Then FullPath = Left(FullPath, Len(FullPath) - 1)
For i = Len(FullPath) To 1 Step -1
If Mid(FullPath, i, 1) = [Ô]\[Ô] Then
FileNameOnly = FN
Exit Function
Else
FN = Mid(FullPath, i, 1) & FN
End If
Next i
End Function


Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

[ô] Root folder = Desktop
bInfo.pidlRoot = 0&

[ô] Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = [Ô]Select a folder.[Ô]
Else
bInfo.lpszTitle = Msg
End If

[ô] Type of directory to return
bInfo.ulFlags = &H1

[ô] Display the dialog
x = SHBrowseForFolder(bInfo)

[ô] Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = [Ô][Ô]
End If
End Function