mp3 tag

Hola Hector...
intente muchos cambios y no logre un resultado bueno... entonces decidi
buscar un poco mas en la web y encontre algo que me sirvio. te lo copio..:
).. muchas gracias por tu colaboracion
_____________________________________
''- MACRO TO CHANGE EXTENDED FILE PROPERTIES OF .MP3 AND .WMA FILES IN
WINDOWS EXPLORER
'- Reads from amended worksheet prepared with separate "READ_FROM_EXPLORER"
macro module.
'''- .WMA files do not have track number column 4
'- this version uses CDDBControlRoxio.dll
'- (was unable to get CDDBControl.dll version 1.2.0.51 to change more than 1
file without crashing)
'- Suggest you copy some files to a special folder for testing first.
'- Brian Baulsom May 2008 - using Excel 2000/Windows X
'==''- Method (works on all files in a single folder)
'- 1. Run macro "READ_FROM_EXPLORER" (other module) TO GET FILE NAMES INTO
CURRENTLY ACTIVE WORKSHEET
'- 2. Amend file details in the worksheet. Delete rows for files not changed
to save time (can be left).
'- 3. Run macro "WRITE_TO_EXPLORER" below
''- also uses Public variables in READ macro module
Dim ws As Worksheet
Dim FromRow As Long
Dim LastRow As Long
Dim FilesToChange As Integer ' number of files to change
Dim FilesChanged As Integer ' number of files changed
Dim MyFilePathName As String ' full path & file name
Dim MyFileType As String ' mp3 wma etc.
'-
Dim id3 As Object
Dim MyArtist As String
Dim MyAlbum As String
Dim MyGenre As String
Dim MyTrack As String
Dim MyTitle As Strin
''- MAIN ROUTINE
'- Run down visible rows and change data
'- worksheet has full path & file name in column
'Sub WRITE_TO_EXPLORER()
Application.Calculation = xlCalculationManual
Set ws = ActiveSheet
Set id3 = CreateObject("CDDBControlRoxio.CddbID3Tag")

'--
'- CHECK NUMBER OF FILES TO CHANGE (VISIBLE ROWS)
LastRow = ws.Range("A65536").End(xlUp).Row ' count worksheet rows
FilesToChange = ws.Range("A2:A" &
LastRow).SpecialCells(xlCellTypeVisible).Count
If FilesToChange = 0 Then MsgBox ("No files to change."): Exit Sub
FilesChanged = 0

'--
'- LOOP WORKSHEET FILES - VISIBLE ROWS ONLY
For FromRow = 2 To LastRow
If ws.Cells(FromRow, "A").EntireRow.Hidden = False Then

'
'- Get file properties from sheet
With ws
MyFilePathName = .Cells(FromRow, "O").Value
MyFileType = UCase(Right(MyFilePathName, 3))
Application.StatusBar = FileCount & "\" & FilesToChange
& " " & MyFilePathName 'STATUSBAR
MyArtist = .Cells(FromRow, "B").Value
MyAlbum = .Cells(FromRow, "C").Value
MyTrack = .Cells(FromRow, "E").Value
MyGenre = .Cells(FromRow, "F").Value
MyTitle = .Cells(FromRow, "H").Value
End With

'
'- Write to file
With id3
.LoadFromFile MyFilePathName, False ' True = Read Only
.LeadArtist = MyArtist
.Album = MyAlbum
.Genre = MyGenre
.Title = MyTitle
If MyFileType = "MP3" Then .TrackPosition = MyTrack
.SaveToFile MyFilePathName
End With

'
FilesChanged = FilesChanged + 1
End If
Next

'--
'- end of program
Application.Calculation = xlCalculationAutomatic
rsp = MsgBox("Done" & vbCr & "Changed " & FilesChanged & " of " &
FilesToChange)
Application.StatusBar = False
End Sub
'= END OF MAIN
=
EN OTRO MODULO

'=='- READ .MP3 & .WMA FILE PROPERTIES TO A WORKSHEET
'=='- MACRO TO :-
'- *1. SELECT A FOLDER - *2. CLEAR THE ACTIVE WORKSHEET* - *3. READ .MP3
& .WMA EXTENDED FILE PROPERTIES*
'- *3. MAKES PROPERTY CELLS BLUE
'- ONLY EXTRACTS FILE DATA SO CAN BE USED ON ITS OWN. SHEETS CAN BE SAVED AS
NORMAL
'- CAN THEN RUN MACRO "WRITE_TO_EXPLORER" (in another module below) TO
*CHANGE* PROPERTIES
'- Uses Windows Shell32.dll (Requires Tools/References .. 'Microsoft Shell
Controls And Automation')
'- Brian Baulsom July 2007 - using Excel 2000/Windows XP
'
'- Method (works on all files in a single folder)
'- 1. Run macro "READ_FROM_EXPLORER" below TO GET FILE NAMES INTO CURRENTLY
ACTIVE WORKSHEET
'- 2. Manually amend file details in the worksheet.Delete or hide rows for
files not changed saves time(can be left)
'- 3. Run macro "WRITE_TO_EXPLORER" (other module)
'=Option Base 1 ' MyProperties(15) starts 1 instead of 0
Dim MyFilePathName As String ' Local variable full path & file name
Public MyPathName As String ' **Public variable |enables 'Sub
GetPathFileNameFromFullPath()'|
Public MyFileName As String ' **Public variable |usage in
'WRITE_TO_EXPLORER' macro |
'- Properties Array (list of integers)
Dim Arr1 As Variant ' "Name"= shell property zero + First 5
properties in Windows Explorer
Dim Arr2 As Variant ' some more shell GetDetailsOf()
property numbers (0-34 available. 3 unused)
Dim MyProperties(16) As Integer ' Shell property index numbers used
here. Puts them in required order
Dim MyPropertyNum As Integer ' Array item position 1-15
Dim MyPropertyVal As Variant ' Lookup Array data shell property
numbers 0,16, 17 ... etc.
'-
Dim ws As Worksheet
Dim ToRow As Long ' write to worksheet row number
'- Shell variables
Dim ShellObj As Shell
Dim MyFolder As Folder
Dim MyFolderItem As FolderItem
'-
'='- MAIN ROUTINE
'=Sub READ_FROM_EXPLORER()
Application.EnableEvents = False ' WORKSHEET Worksheet_Change() makes
changed cells yellow

'-
'- GET FOLDER NAME FROM FIRST FOLDER\FILE IN THE WORKSHEET
MyFilePathName = ActiveSheet.Range("O2").Value
If InStr(1, MyFilePathName, "\", vbTextCompare) <> 0 Then 'there is "\"
in the path
GetPathFileNameFromFullPath (MyFilePathName) ' PUBLIC SUBROUTINE
IN 'READ_FROM_EXPLORER' module
ChDrive MyPathName
ChDir MyPathName & "\"
Else
ChDrive ThisWorkbook.FullName
ChDir ThisWorkbook.FullName
End If
'- GET FOLDER - Method 1 - using Windows Dialog (comment out if not
required)
'MsgBox ("Selecting a single file in the following dialog gets the
required *FOLDER*." & vbCr & vbCr _
& "NB. CLEARS THE CURRENTLY ACTIVE SHEET.")
MyFilePathName = _
Application.GetOpenFilename("Audio Files (*.mp3;*.wma),*.mp3;*.wma",
, " GET FOLDER REQUIRED")
If MyFilePathName = "False" Then Exit Sub
GetPathFileNameFromFullPath MyFilePathName ' subroutine to separate
folder & file name

'-
' '- GET FOLDER - Method 2 - hard coded for testing (comment out if not
required)
' MyPathName = "C:\TEMP\MP3_TEST" ' SET AS REQUIRED

' Set ShellObj = New Shell
Set MyFolder = ShellObj.Namespace(MyPathName)

'
ChDrive MyPathName
ChDir MyPathName & "\"
Set ws = ActiveSheet
ToRow = 2
With ws.Columns("A:O").Cells
.ClearContents ' clear worksheet
.Interior.ColorIndex = xlNone
End With
ws.Rows.Hidden = False

'-
'- INITIALISE PROPERTY ARRAY. CLEAR & SET UP WORKSHEET
'- Set up array to sort properties into the required order
'- do not change Arr1 (list of changeable fields in Windows Explorer -
used in WRITE macro.)
' "Name", "Artist", "Album", "Year", "Track", "Genre", "Lyrics",
"Title","Comments")
Arr1 = Array(0, 16, 17, 18, 19, 20, 27, 10, 14)
For n = 1 To 9: MyProperties(n) = Arr1(n): Next
'- "Duration", "Size", "Date Modified", "Category", "Author", "Bit
Rate"
Arr2 = Array(21, 9, 12, 3, 1, 22, 33)
For n = 10 To 16: MyProperties(n) = Arr2(n - 9): Next

'-
'- write worksheet header
For n = 1 To 14
ws.Cells(1, n).Value = MyFolder.GetDetailsOf(MyFolder.Items,
MyProperties(n))
Next
With ws
'- "Lyrics" is not included in the Shell properties. I have used a
blank one item 27
.Cells(1, "G").Value = "Lyrics"
'- This is useful for other purposes. eg. to play the track via
macro.
.Cells(1, "O").Value = "Full Name"
.Range("A1:O1").Interior.ColorIndex = 37 ' Dark blue header
End With

' '- GET FILE NAMES & PROPERTIES FROM FOLDER

' MyFileName = Dir(mypath & "*.*") 'first file name
Do While MyFileName <> ""
'- filter .MP3 & .WMA
If UCase(Right(MyFileName, 3)) = "MP3" Or UCase(Right(MyFileName,
3)) = "WMA" Then
Set MyFolderItem = MyFolder.ParseName(MyFileName)

'--
'- properties to worksheet
For MyPropertyNum = 1 To 14
MyPropertyVal = MyFolder.GetDetailsOf(MyFolderItem,
MyProperties(MyPropertyNum))
ws.Cells(ToRow, MyPropertyNum).Value = MyPropertyVal
Next

'
'- add full path\file name (used as lookup by "WRITE_TO_EXPLORER")
ws.Cells(ToRow, 15).Value = MyPathName & "\" & MyFileName
ToRow = ToRow + 1
End If
MyFileName = Dir ' Get next file name
Loop

'-
'- finish
With ws
.Activate
'.UsedRange.Columns.AutoFit
.Range("D1,G1,I1,K1").EntireColumn.Hidden = True
.Range("A1").Select
End With

'-
'- colour editable range -> blue

'-
If ToRow > 2 Then ws.Range("B2:I" &
ws.Range("A2").End(xlDown).Row).Interior.ColorIndex = 34
MsgBox ("Done.")
Application.EnableEvents = True
End Sub
'== END OF MAIN ROUTINE
=='='- SUB TO SEPARATE PATH & FILE NAME FROM FULL NAME
'- puts to Public module level variables 'MyFileName' & 'MyPathName'
'=Public Sub GetPathFileNameFromFullPath(Nm As String)
For c = Len(Nm) To 1 Step -1
If Mid(Nm, c, 1) = "\" Then
MyFileName = Right(Nm, Len(Nm) - c)
MyPathName = Left(Nm, Len(Nm) - Len(MyFileName) - 1)
Exit Sub
End If
Next
End Sub
'-

______________________________________
"Héctor Miguel" wrote:

hola (de nuevo), fredy ! (informacion de complemento -por si las dudas-)

creo que existe otra (posible) incongruencia en los codigos...

cuando se abre el archivo (I/O binario) se le nombra...
> Dim FileNum As Long

y se establece su referencia como...
> Open FileName For Binary As FileNum

PERO... cuando se (re)escribe el nuevo final, se utiliza...
> Put FileNum, LOF(1) - 127, Tag

cabria la posibilidad de que el archivo abierto (I/O) con el indice 1 -> LOF(1)
se cruzara con otros archivos abiertos por cualquier otra aplicacion (temporalmente ?) en el sistema (???)

prueba tambien cambiando a la referencia especifica del archivo instanciado...
> Put FileNum, LOF(FileName) - 127, Tag

saludos,
hector.


.

hola, fredy !

intente muchos cambios y no logre un resultado bueno... entonces decidi buscar un poco mas en la web
y encontre algo que me sirvio. te lo copio..:).. muchas gracias por tu colaboracion

gracias a ti, por compartirlo (pero, en mi caso...) lo tendre que dejar para otra oportunidad :-(
(no encontre en mi sistema instaladas las librerias CDDB*.dll)

saludos,
hector.

__ OP __
'> '- MACRO TO CHANGE EXTENDED FILE PROPERTIES OF .MP3 AND .WMA FILES IN

WINDOWS EXPLORER
'- Reads from amended worksheet prepared with separate "READ_FROM_EXPLORER"
macro module.
'=> '> '- .WMA files do not have track number column 4
'- this version uses CDDBControlRoxio.dll
'- (was unable to get CDDBControl.dll version 1.2.0.51 to change more than 1
file without crashing)
'- Suggest you copy some files to a special folder for testing first.
'- Brian Baulsom May 2008 - using Excel 2000/Windows XP
'> '> '- Method (works on all files in a single folder)
'- 1. Run macro "READ_FROM_EXPLORER" (other module) TO GET FILE NAMES INTO
CURRENTLY ACTIVE WORKSHEET
'- 2. Amend file details in the worksheet. Delete rows for files not changed
to save time (can be left).
'- 3. Run macro "WRITE_TO_EXPLORER" below.
'> '- also uses Public variables in READ macro module
Dim ws As Worksheet
Dim FromRow As Long
Dim LastRow As Long
Dim FilesToChange As Integer ' number of files to change
Dim FilesChanged As Integer ' number of files changed
Dim MyFilePathName As String ' full path & file name
Dim MyFileType As String ' mp3 wma etc.
'-
Dim id3 As Object
Dim MyArtist As String
Dim MyAlbum As String
Dim MyGenre As String
Dim MyTrack As String
Dim MyTitle As String
'> '- MAIN ROUTINE
'- Run down visible rows and change data
'- worksheet has full path & file name in column O
'> Sub WRITE_TO_EXPLORER()
Application.Calculation = xlCalculationManual
Set ws = ActiveSheet
Set id3 = CreateObject("CDDBControlRoxio.CddbID3Tag")

'--
'- CHECK NUMBER OF FILES TO CHANGE (VISIBLE ROWS)
LastRow = ws.Range("A65536").End(xlUp).Row ' count worksheet rows
FilesToChange = ws.Range("A2:A" &
LastRow).SpecialCells(xlCellTypeVisible).Count
If FilesToChange = 0 Then MsgBox ("No files to change."): Exit Sub
FilesChanged = 0

'--
'- LOOP WORKSHEET FILES - VISIBLE ROWS ONLY
For FromRow = 2 To LastRow
If ws.Cells(FromRow, "A").EntireRow.Hidden = False Then

'
'- Get file properties from sheet
With ws
MyFilePathName = .Cells(FromRow, "O").Value
MyFileType = UCase(Right(MyFilePathName, 3))
Application.StatusBar = FileCount & "\" & FilesToChange
& " " & MyFilePathName 'STATUSBAR
MyArtist = .Cells(FromRow, "B").Value
MyAlbum = .Cells(FromRow, "C").Value
MyTrack = .Cells(FromRow, "E").Value
MyGenre = .Cells(FromRow, "F").Value
MyTitle = .Cells(FromRow, "H").Value
End With

'
'- Write to file
With id3
.LoadFromFile MyFilePathName, False ' True = Read Only
.LeadArtist = MyArtist
.Album = MyAlbum
.Genre = MyGenre
.Title = MyTitle
If MyFileType = "MP3" Then .TrackPosition = MyTrack
.SaveToFile MyFilePathName
End With

'
FilesChanged = FilesChanged + 1
End If
Next

'--
'- end of program
Application.Calculation = xlCalculationAutomatic
rsp = MsgBox("Done" & vbCr & "Changed " & FilesChanged & " of " &
FilesToChange)
Application.StatusBar = False
End Sub
'= END OF MAIN
=>
EN OTRO MODULO

'==> '- READ .MP3 & .WMA FILE PROPERTIES TO A WORKSHEET
'==> '- MACRO TO :-
'- *1. SELECT A FOLDER - *2. CLEAR THE ACTIVE WORKSHEET* - *3. READ .MP3
& .WMA EXTENDED FILE PROPERTIES*
'- *3. MAKES PROPERTY CELLS BLUE
'- ONLY EXTRACTS FILE DATA SO CAN BE USED ON ITS OWN. SHEETS CAN BE SAVED AS
NORMAL
'- CAN THEN RUN MACRO "WRITE_TO_EXPLORER" (in another module below) TO
*CHANGE* PROPERTIES
'- Uses Windows Shell32.dll (Requires Tools/References .. 'Microsoft Shell
Controls And Automation')
'- Brian Baulsom July 2007 - using Excel 2000/Windows XP
'
> '- Method (works on all files in a single folder)
'- 1. Run macro "READ_FROM_EXPLORER" below TO GET FILE NAMES INTO CURRENTLY
ACTIVE WORKSHEET
'- 2. Manually amend file details in the worksheet.Delete or hide rows for
files not changed saves time(can be left)
'- 3. Run macro "WRITE_TO_EXPLORER" (other module)
'=> Option Base 1 ' MyProperties(15) starts 1 instead of 0
Dim MyFilePathName As String ' Local variable full path & file name
Public MyPathName As String ' **Public variable |enables 'Sub
GetPathFileNameFromFullPath()'|
Public MyFileName As String ' **Public variable |usage in
'WRITE_TO_EXPLORER' macro |
'- Properties Array (list of integers)
Dim Arr1 As Variant ' "Name"= shell property zero + First 5
properties in Windows Explorer
Dim Arr2 As Variant ' some more shell GetDetailsOf()
property numbers (0-34 available. 3 unused)
Dim MyProperties(16) As Integer ' Shell property index numbers used
here. Puts them in required order
Dim MyPropertyNum As Integer ' Array item position 1-15
Dim MyPropertyVal As Variant ' Lookup Array data shell property
numbers 0,16, 17 ... etc.
'-
Dim ws As Worksheet
Dim ToRow As Long ' write to worksheet row number
'- Shell variables
Dim ShellObj As Shell
Dim MyFolder As Folder
Dim MyFolderItem As FolderItem
'-
'=> '- MAIN ROUTINE
'=> Sub READ_FROM_EXPLORER()
Application.EnableEvents = False ' WORKSHEET Worksheet_Change() makes
changed cells yellow

'-
'- GET FOLDER NAME FROM FIRST FOLDER\FILE IN THE WORKSHEET
MyFilePathName = ActiveSheet.Range("O2").Value
If InStr(1, MyFilePathName, "\", vbTextCompare) <> 0 Then 'there is "\"
in the path
GetPathFileNameFromFullPath (MyFilePathName) ' PUBLIC SUBROUTINE
IN 'READ_FROM_EXPLORER' module
ChDrive MyPathName
ChDir MyPathName & "\"
Else
ChDrive ThisWorkbook.FullName
ChDir ThisWorkbook.FullName
End If
'- GET FOLDER - Method 1 - using Windows Dialog (comment out if not
required)
'MsgBox ("Selecting a single file in the following dialog gets the
required *FOLDER*." & vbCr & vbCr _
& "NB. CLEARS THE CURRENTLY ACTIVE SHEET.")
MyFilePathName = _
Application.GetOpenFilename("Audio Files (*.mp3;*.wma),*.mp3;*.wma",
, " GET FOLDER REQUIRED")
If MyFilePathName = "False" Then Exit Sub
GetPathFileNameFromFullPath MyFilePathName ' subroutine to separate
folder & file name

'-
' '- GET FOLDER - Method 2 - hard coded for testing (comment out if not
required)
' MyPathName = "C:\TEMP\MP3_TEST" ' SET AS REQUIRED

'> Set ShellObj = New Shell
Set MyFolder = ShellObj.Namespace(MyPathName)

'
ChDrive MyPathName
ChDir MyPathName & "\"
Set ws = ActiveSheet
ToRow = 2
With ws.Columns("A:O").Cells
.ClearContents ' clear worksheet
.Interior.ColorIndex = xlNone
End With
ws.Rows.Hidden = False

'-
'- INITIALISE PROPERTY ARRAY. CLEAR & SET UP WORKSHEET
'- Set up array to sort properties into the required order
'- do not change Arr1 (list of changeable fields in Windows Explorer -
used in WRITE macro.)
' "Name", "Artist", "Album", "Year", "Track", "Genre", "Lyrics",
"Title","Comments")
Arr1 = Array(0, 16, 17, 18, 19, 20, 27, 10, 14)
For n = 1 To 9: MyProperties(n) = Arr1(n): Next
'- "Duration", "Size", "Date Modified", "Category", "Author", "Bit
Rate"
Arr2 = Array(21, 9, 12, 3, 1, 22, 33)
For n = 10 To 16: MyProperties(n) = Arr2(n - 9): Next

'-
'- write worksheet header
For n = 1 To 14
ws.Cells(1, n).Value = MyFolder.GetDetailsOf(MyFolder.Items,
MyProperties(n))
Next
With ws
'- "Lyrics" is not included in the Shell properties. I have used a
blank one item 27
.Cells(1, "G").Value = "Lyrics"
'- This is useful for other purposes. eg. to play the track via
macro.
.Cells(1, "O").Value = "Full Name"
.Range("A1:O1").Interior.ColorIndex = 37 ' Dark blue header
End With

'> '- GET FILE NAMES & PROPERTIES FROM FOLDER

'> MyFileName = Dir(mypath & "*.*") 'first file name
Do While MyFileName <> ""
'- filter .MP3 & .WMA
If UCase(Right(MyFileName, 3)) = "MP3" Or UCase(Right(MyFileName,
3)) = "WMA" Then
Set MyFolderItem = MyFolder.ParseName(MyFileName)

'--
'- properties to worksheet
For MyPropertyNum = 1 To 14
MyPropertyVal = MyFolder.GetDetailsOf(MyFolderItem,
MyProperties(MyPropertyNum))
ws.Cells(ToRow, MyPropertyNum).Value = MyPropertyVal
Next

'
'- add full path\file name (used as lookup by "WRITE_TO_EXPLORER")
ws.Cells(ToRow, 15).Value = MyPathName & "\" & MyFileName
ToRow = ToRow + 1
End If
MyFileName = Dir ' Get next file name
Loop

'-
'- finish
With ws
.Activate
'.UsedRange.Columns.AutoFit
.Range("D1,G1,I1,K1").EntireColumn.Hidden = True
.Range("A1").Select
End With

'-
'- colour editable range -> blue

'-
If ToRow > 2 Then ws.Range("B2:I" &
ws.Range("A2").End(xlDown).Row).Interior.ColorIndex = 34
MsgBox ("Done.")
Application.EnableEvents = True
End Sub
'== END OF MAIN ROUTINE
==> '=> '- SUB TO SEPARATE PATH & FILE NAME FROM FULL NAME
'- puts to Public module level variables 'MyFileName' & 'MyPathName'
'=> Public Sub GetPathFileNameFromFullPath(Nm As String)
For c = Len(Nm) To 1 Step -1
If Mid(Nm, c, 1) = "\" Then
MyFileName = Right(Nm, Len(Nm) - c)
MyPathName = Left(Nm, Len(Nm) - Len(MyFileName) - 1)
Exit Sub
End If
Next
End Sub
'-