Mp3 massive renamer - sepcial baladeur mp3

Télécharger le projet
Commenter

Description

Si vous avez un baladeur MP3 vous vous êtes surement rendu compte combien il est peniable de naviguer dans le repertoire des différents artistes, surtout si vous avez l'habitude de bien nomer vos MP3 et que vous aves un baladeurs MP3 a disque dur.
Ainsi donc ce programme transforme a la volée des noms de MP3 de la forme

01 - Nom de l'artiste - nom de la piste.mp3

en

01 - nom de la piste.mp3

L'opération dans le sens inversse n'est pas encore possible mais je compte bien l'ajouter en me baseant sur les TAG ID3 et le nom du dossier.
Dans une prochaine source je publirai un programme plus complet sepcial pour les baladerus MP3 pour renomer, Tagger en fonction du nom, ou encore renomer en fonction du TAG vos fichiers MP3.
Bien sur de nombreux progrmmes proposent deja ces fonction de manières tres abouties. Mais il vous est impossible de modifier a votre guise les fonctions du proramme ou meme de savoir comment sa marche, contrairement au principe de l'open source.

Bien entendu pour l'instant mon programme ne détecte que ce format de nom pour les mp3.

Si vous êtes courageux, recopier chaques parties du code dans leurs emplacement de destination, sinon télerchargez le ZIP

Voici dans le 1er cas ce dont vous avez besoin :

'tous les composants utilisent les noms par défault sauf les menus, ou quand c'est spécifié
'
'Sur Le form1
'
'1 checkbox nomé check2
'3 CommandButtons
'1 label
'1 liste box
'9 menu comme suit
'Fichier (nomé M_File)
'...Go (nomé M_F_go)
'...- (nomé M_sep1)
'...Quitter (nomé M_F_quit)
'Options (nomé M_Option)
'...Long => Court (nomé M_O_2what index 0)
'...Court => Long (nomé M_O_2what index 1 Disabled)
'? (nomé M_About)
'...About (nomé M_A_About)
'
'1 text box
'3 modules

Source / Exemple : 


'A METRE DANS LE FORM 1
'
'1 checkbox nomé check2
'3 CommandButtons
'1 label
'1 liste box
'9 menu comme suit
'Fichier          (nomé M_File)
'...Go            (nomé M_F_go)
'...-             (nomé M_sep1)
'...Quitter       (nomé M_F_quit)
'Options          (nomé M_Option)
'...Long => Court (nomé M_O_2what index 0)
'...Court => Long (nomé M_O_2what index 1 Disabled)
'?                (nomé M_About)
'...About         (nomé M_A_About)
'
'1 text box

Option Explicit

Dim Path As String, SimpleF As Boolean, StartS As String
Dim EndS As String, Dest As String, Canceled As Boolean, Comment As String
Dim TotalTime As Long, b As Integer

    Private Sub Command1_Click()
        If FileExist(Text1.Text) <> True Then
            MsgBox "Le dossier spécifié n'existe pas ou ne contient pas de MP3s", vbCritical + vbOKOnly, "Attention"
            Call Command3_Click
            Exit Sub
        End If
        Command1.Enabled = False
        StartS = Timer
        Label1.Caption = "Renomage en cours..."
        Command2.Caption = "Annuler"
        DoEvents
    If Right(Text1.Text, 1) = "\" Then Path = Text1.Text Else Path = Text1.Text & "\"
    Call RecurseTree(AddSlash(Path))
    Call EndOp
    End Sub
    Private Sub Command2_Click()
    If List1.ListCount <> 0 Then
            Label1.Caption = "Annulation en cours..."
            Comment = "(Action Annulée) "
        Canceled = True
    Else
        End
    End If
    End Sub
    Private Sub Command3_Click()
    Dim w
    w = ShowFolder(Me, "Veuillez choisir un dossier")
    If w <> "" Then
        Text1.Text = w
    Else
        MsgBox "Vous devez choisir le dossier contenant les MP3s a renomer !", vbExclamation + vbOKOnly, "Attention"
    End If
    End Sub
    Private Sub Form_Unload(Cancel As Integer)
    Call Command2_Click
    End Sub
    Private Sub M_A_about_Click()
        MsgBox "© OverDarck 2003/2004" & vbCrLf & "Sources disponibles sur www.vbfrance.com" & vbCrLf & "DarckOver@yahoo.fr", vbInformation + vbOKOnly, "About"
    End Sub
    Private Sub M_F_go_Click()
        Call Command1_Click
    End Sub
    Private Sub M_F_quit_Click()
        Call Command2_Click
    End Sub
    Private Sub Text1_Change()
    If Text1.Text <> vbNullString Then Command1.Enabled = True Else Command1.Enabled = False
    End Sub
    
Private Sub RecurseTree(CurrentPath$) 'list tt les fichier dans le dossier et ses sous dossiers
Dim Ext As String, i, N, a, X, FileName$, DirectoryList$(), FileN As String

'Fichiers racines
If Not SimpleF Then 'Securité pour que ne soit executer qu'une fois cette partie
    ChangeFichEmp CurrentPath$
    'If FichCount > 0 Then List1.AddItem title("Mp3 Divers") 'on ajoute...
    For X = 0 To FichCount - 1
        Ext = LCase(Right(Fich(X), Len(Fich(X)) - InStrRev(Fich(X), "."))) 'on recupère l'extansion
        If Ext = "mp3" Or Ext = "mid" Or Ext = "wav" Or Ext = "wma" Or Ext = "mod" Then ' on verifie que c'est un fichier du type qu elon veut
            If InStr(Fich(a), " - ") And Mid(Fich(a), 4, 1) = "-" Then
                FileN = Left(Fich(a), 5) & Right(Fich(a), Len(Fich(a)) - InStr(Mid(Fich(a), 6, Len(Fich(a)) - 6), "-") - 6)
                Name AddSlash(DirectoryList$(i)) & Fich(a) As AddSlash(DirectoryList$(i)) & FileN
            End If
            b = b + 1
        End If
    Next X
    SimpleF = True
End If
    
'Fichiers des sous dossiers
FileName$ = Dir(CurrentPath$)
Do While FileName$ <> ""
    FileName$ = Dir
Loop
FileName$ = Dir(CurrentPath$, vbDirectory)
Do While FileName$ <> ""
    If FileName$ <> "." And FileName$ <> ".." Then
        If (GetAttr(CurrentPath$ & FileName$) And vbDirectory) = vbDirectory Then
            N = N + 1
            ReDim Preserve DirectoryList$(N)
            DirectoryList$(N) = CurrentPath$ & FileName$
        End If
    End If
    FileName$ = Dir
Loop
For i = 1 To N
    'On tombe sur un dossier...
    ChangeFichEmp DirectoryList$(i) & "\" 'On se prépare pour regarder ses fichiers...
    'listage des fichiers contenus dans le dossier
    For a = 0 To FichCount - 1
        Ext = LCase(Right(Fich(a), Len(Fich(a)) - InStrRev(Fich(a), "."))) 'on recupère l'extansion
        If Ext = "mp3" Or Ext = "mid" Or Ext = "wav" Or Ext = "wma" Or Ext = "mod" Then ' on verifie que c'est un fichier du type qu elon veut
            FileN = Fich(a) 'Right(DirectoryList$(i), Len(DirectoryList$(i)) - Len(Path))
            DoEvents
            If InStr(Fich(a), " - ") And InStrRev(Fich(a), " - ") And InStr(Fich(a), " - ") <> InStrRev(Fich(a), " - ") And Mid(Fich(a), 4, 1) = "-" Then
                FileN = Left(Fich(a), 5) & Right(Fich(a), Len(Fich(a)) - InStr(Mid(Fich(a), 6, Len(Fich(a)) - 6), "-") - 6)
                Name AddSlash(DirectoryList$(i)) & Fich(a) As AddSlash(DirectoryList$(i)) & FileN
                If Canceled <> True Then Label1.Caption = Fich(a)
                b = b + 1
            End If
        End If
    Next a
    'Suivi

    DoEvents
    'pr l'annulation
    If Canceled = True Then Exit Sub
    RecurseTree DirectoryList$(i) & "\" 'et on passe au sous dossier suivant
Next i
End Sub
Private Sub EndOp()
'On affiche la durée de l'operation
    EndS = Timer - StartS
    If Canceled = False Then Label1.Caption = "Fini en " & Format(Int(EndS / 60), "0#") & "'" & Format(EndS - Int(EndS / 60) * 60, "0#") & "'' (" & b & " fichiers renomés)" Else Label1.Caption = "Opération Annulée"
'On quitte si Check2 est coché
    If Canceled = False And Check2.Value = 1 Then End
'On vide les variables :
    Command2.Caption = "Quitter"
    Comment = vbNullString
    Dest = vbNullString
    Canceled = False
    b = 0
    Command2.Enabled = True
    Command1.Enabled = True
End Sub

'A METRE DANS UN MODULE

'///////////////////////////////////////////////////////////////////////////////////////////
'COMMON DIALOG API - MODULE CODE
'///////////////////////////////////////////////////////////////////////////////////////////
Option Explicit
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pidl As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hmem As Long) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As TCOLORDLG) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As TFILENAMEDLG) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As TFILENAMEDLG) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As TBROWSEINFO) As Long
Private Type TCOLORDLG
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As Long
Flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Type TFILENAMEDLG
lStructSize As Long
hwndOwner As Long
hInstance As Long
strFilter As String
strCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
strFile As String
nMaxFile As Long
strFileTitle As String
nMaxFileTitle As Long
strInitialDir As String
strTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
strDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
pvReserved As Long
dwReserved As Long
FlagsEx As Long
End Type
Private Type TBROWSEINFO
hwndOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfnHook As Long
lParam As Long
iImage As Long
End Type
Private Const MAX_PATH = 260
Private Const WM_USER = &H400
Private Const WM_INITDIALOG As Long = &H110
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Private Const LMEM_FIXED = &H0
Private Const LMEM_ZEROINIT = &H40
Private Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
Private Const CC_FULLOPEN = &H2
Private Const CC_PREVENTFULLOPEN = &H4
Private Const CC_ANYCOLOR = &H100
Private Const BIF_USENEWUI = &H40
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_BROWSEINCLUDEFILES = &H4000
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_EXPLORER = &H80000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_LONGNAMES = &H200000
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_READONLY = &H1
Private Const OFN_OPEN = True
Private Const OFN_SAVE = False
Private Const OFN_FILE_OPEN_FLAGS = OFN_EXPLORER Or OFN_LONGNAMES Or OFN_CREATEPROMPT Or OFN_NODEREFERENCELINKS Or OFN_HIDEREADONLY 'Or OFN_ALLOWMULTISELECT
Private Const OFN_FILE_SAVE_FLAGS = OFN_EXPLORER Or OFN_LONGNAMES Or OFN_OVERWRITEPROMPT Or OFN_HIDEREADONLY
'SHOW FOLDER TREE DIALOG BOX
Public Function ShowFolder(ByRef nOwner As Form, Optional ByVal sDlgTitle As String, Optional ByVal sInitDir As String, Optional ByRef bIncludeFiles As Boolean) As String
Dim cFolder As TBROWSEINFO
Dim sPath As String * MAX_PATH
Dim sFolder As String
Dim lResult As Long
Dim lSelPath As Long
Dim sTempPath As String
sTempPath = sInitDir
sPath = Left$(sTempPath & String(MAX_PATH, 0), MAX_PATH)
lSelPath = LocalAlloc(LPTR, Len(sPath) + 1)
CopyMemory ByVal lSelPath, ByVal sPath, Len(sPath) + 1
With cFolder
.hwndOwner = nOwner.hWnd
.pidlRoot = 0&
.lpszTitle = sDlgTitle
.ulFlags = IIf(bIncludeFiles, BIF_BROWSEINCLUDEFILES, BIF_RETURNONLYFSDIRS) + BIF_USENEWUI
.lpfnHook = FARPROC(AddressOf PATHPROC)
.lParam = lSelPath
End With
lResult = SHBrowseForFolder(cFolder)
If lResult <> 0 Then
If SHGetPathFromIDList(ByVal lResult, ByVal sPath) Then
sFolder = Left$(sPath, InStr(1, sPath, vbNullChar) - 1)
End If
End If
Call CoTaskMemFree(lResult)
Call LocalFree(lSelPath)
ShowFolder = sFolder
End Function
Private Function FARPROC(ByVal pPathProc As Long) As Long
FARPROC = pPathProc
End Function
Private Function PATHPROC(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If uMsg = BFFM_INITIALIZED Then Call SendMessage(hWnd, BFFM_SETSELECTIONA, True, ByVal lParam)
End Function
'SHOW THE COLOR DIALOG BOX
Public Function ShowColor(ByRef nOwner As Form, ByVal lInitColor As Long, ByRef lCustColors() As Long, Optional ByVal bFullOpen As Boolean) As Long
Dim cColor As TCOLORDLG
Dim lResult As Long
With cColor
.lStructSize = Len(cColor)
.hwndOwner = nOwner.hWnd
.hInstance = App.hInstance
.Flags = CC_ANYCOLOR
.rgbResult = lInitColor
.lpCustColors = VarPtr(lCustColors(0))
.Flags = IIf(bFullOpen, CC_ANYCOLOR, CC_FULLOPEN)
lResult = ChooseColor(cColor)
If lResult = 1 Then
ShowColor = .rgbResult
Else
ShowColor = -1
End If
End With
End Function
'ADD A FILTER TO OPEN/SAVE DIALOG BOX
Public Function AddFilterItem(ByVal sFilter As String, ByVal sDescription As String, Optional ByVal sExt As String = "*.*") As String
AddFilterItem = sFilter & sDescription & vbNullChar & sExt & vbNullChar
End Function
'SHOW THE OPEN/SAVE DIALOG BOX
Public Function ShowFileOpenSave(ByRef nOwner As Form, Optional ByVal bOpenFlag As Boolean = True, Optional ByVal sDlgTitle As String, Optional ByVal sInitDir As String, Optional ByVal nFilter As String, Optional ByVal nFilterIndex As Integer = 1) As String
Dim cFileOpenSave As TFILENAMEDLG
Dim lResult As Long
With cFileOpenSave
.lStructSize = Len(cFileOpenSave)
.hwndOwner = nOwner.hWnd
.hInstance = App.hInstance
.strFilter = nFilter
.nFilterIndex = nFilterIndex
.strFile = String(256, 0)
.nMaxFile = 256
.strFileTitle = String(256, 0)
.nMaxFileTitle = 256
.strTitle = sDlgTitle
.strInitialDir = sInitDir
.strDefExt = "*.*"
.strCustomFilter = String(255, 0)
.nMaxCustFilter = 255
.lpfnHook = 0
.Flags = IIf(bOpenFlag, OFN_FILE_OPEN_FLAGS, OFN_FILE_SAVE_FLAGS)
End With
If bOpenFlag Then
lResult = GetOpenFileName(cFileOpenSave)
Else
lResult = GetSaveFileName(cFileOpenSave)
End If
If lResult <> 0 Then
ShowFileOpenSave = Trim(cFileOpenSave.strFile)
End If
End Function

'DANS UN AUTRE MODULE

'ATTENTION : Si vous rencontrez un probleme de compilation/execution sur se module,
'veuillez acticver la Réference
'FileSystemObject Projet > References > Microsoft Scripting Runtime
Public FSO As New FileSystemObject
Public Fich(32767) As String
Public FichCount As Integer
Public CurrentFichEmp As String
Public Rep(32767) As String
Public RepCount As Integer
Public CurrentRepEmp As String
Public Sub ChangeFichEmp(Optional Emp As String = ".\")
On Error Resume Next
Dim fld As Folder
If Emp = ".\" Then Emp = CurrentFichEmp
CurrentFichEmp = Emp
Set fld = FSO.GetFolder(Emp)
Dim f As File
FichCount = 0
For Each f In fld.Files
    Fich(FichCount) = f.Name
    FichCount = FichCount + 1
Next
End Sub
Public Function FileExist(FileName As String)
On Error Resume Next
If FSO.FileExists(FileName) Or FSO.FolderExists(FileName) Then FileExist = True

End Function

'ET DANS LE DERNIER MODULE

Public MP3FileName As String

Public Const G = """"

Public Function Convtime(Secondes As Long) As String
Dim min, sec, h, day
'Convtime = Secondes
min = Int(Secondes / 60)
sec = Secondes - (60 * min) 'reste de secondes
h = Int(min / 60) 'heures
min = min - 60 * h 'reste de minutes
day = Int(h / 24) 'jours
h = h - 24 * day 'reste des heures
Convtime = "<b>" & day & "</b>j <b>" & h & "</b>h <b>" & min & "</b>min <b>" & sec & "</b>sec"
End Function
Public Function OctetsToKoMoGo(DATA) As String
Dim Décimales
Décimales = 2
If DATA < 1024 Then ' - d'1 Ko
    OctetsToKoMoGo = DATA & " Octets"
ElseIf DATA >= 1024 And DATA < (1024 ^ 2) Then ' Entre 1 Ko et 1023Ko
    OctetsToKoMoGo = (Round((DATA / 1024), Décimales)) & " Ko"
ElseIf DATA >= (1024 ^ 2) And DATA < (1024 ^ 3) Then 'Entre 1 Mo et 1023 Mo
    OctetsToKoMoGo = (Round((DATA / (1024 ^ 2)), Décimales)) & " Mo"
ElseIf DATA >= (1024 ^ 3) And DATA < (1024 ^ 4) Then 'Entre 1 Go et 1023 Go')
    OctetsToKoMoGo = (Round((DATA / (1024 ^ 3)), Décimales)) & " Go"
ElseIf DATA >= (1024 ^ 4) And DATA < (1024 ^ 5) Then 'Entre 1 To et 1023 To')
    OctetsToKoMoGo = (Round((DATA / (1024 ^ 4)), Décimales)) & " To"
End If
End Function
Public Function AddSlash(StrData As String) As String
If Right(StrData, 1) = "\" Or Right(StrData, 1) = "/" Then AddSlash = StrData Else AddSlash = StrData & "\" 'Left(StrData, Len(StrData) - 1)
End Function
Public Function UpFirst(Txt As String) As String
UpFirst = UCase(Left(Txt, 1)) & Right(Txt, Len(Txt) - 1)
End Function

'Public Function SpeInfo(ByVal lpMP3File As String, ByRef lpMP3Info As MP3Info)
'Dim buf As String * 124
'Dim title As String, art As String, alb As String, ann As String, com As String
'Dim pnb As String
'
'alen = FileLen(lpMP3File) - 124
'Open lpMP3File For Binary As #1
'    Get #1, alen, buf
'Close #1
'lpMP3Info.Titre = Mid(buf, 1, InStr(1, buf, vbNullChar) - 1)          'OK '30
'lpMP3Info.Artiste = Mid(buf, 31, InStr(31, buf, vbNullChar) - 1 - 31) 'OK '30
'lpMP3Info.Album = Mid(buf, 61, InStr(61, buf, vbNullChar) - 1 - 61)   'OK '30
'lpMP3Info.Annee = Trim(Mid(buf, 91, 4))                               'OK '4
'lpMP3Info.Comment = Mid(buf, 95, InStr(95, buf, vbNullChar) - 1 - 94) 'OK '29
'lpMP3Info.Number = Asc(Mid(buf, 123, 1))                              'OK
'End Function

Conclusion :


Voila je pensse que je n'ai rien oublié.
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (OverDarck)