#1
|
|||
|
|||
Changing a part of vba code
Hi
The VBA code below is for generates a list of MP3 files I want to change the code from mp3 to Mkv Who can help me Thanks Code:
Option Explicit '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 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 Sub GetAllFiles() Dim Msg As String Dim Directory As String Msg = "Select the directory that contains the MP3 files. All subdirectories will be included." Directory = GetDirectory(Msg) If Directory = "" Then Exit Sub If Right(Directory, 1) <> "\" Then Directory = Directory & "\" Worksheets("Sheet1").Activate Cells.Clear Call RecursiveDir(Directory) End Sub 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 Public Sub RecursiveDir(ByVal currdir As String) Dim Dirs() As String Dim NumDirs As Long Dim filename As String Dim PathAndName As String Dim i As Long Dim Row As Long ' Make sure path ends in backslash If Right(currdir, 1) <> "\" Then currdir = currdir & "\" Application.ScreenUpdating = False ' Put column headings on active sheet Cells(1, 1) = "Path" Cells(1, 2) = "Filename" Cells(1, 3) = "Artist" Cells(1, 4) = "Album" Cells(1, 5) = "Title" Cells(1, 6) = "Track#" Cells(1, 7) = "Genre" Cells(1, 8) = "Duration" Cells(1, 9) = "Size" Range("A1:I1").Font.Bold = True ' Get files filename = Dir(currdir & "*.*", vbDirectory) Do While Len(filename) <> 0 If Left$(filename, 1) <> "." Then 'Current dir PathAndName = currdir & filename If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then 'store found directories ReDim Preserve Dirs(0 To NumDirs) As String Dirs(NumDirs) = PathAndName NumDirs = NumDirs + 1 Else If UCase(Right(filename, 3)) = "MP3" Then Row = WorksheetFunction.CountA(Range("A:A")) + 1 Cells(Row, 1) = currdir 'path Cells(Row, 2) = filename 'filename Cells(Row, 3) = FileInfo(currdir, filename, 20) 'artist Cells(Row, 4) = FileInfo(currdir, filename, 14) 'album Cells(Row, 5) = FileInfo(currdir, filename, 21) 'title Cells(Row, 6) = FileInfo(currdir, filename, 26) 'track Cells(Row, 7) = FileInfo(currdir, filename, 16) 'genre Cells(Row, 8) = FileInfo(currdir, filename, 27) 'duration Cells(Row, 9) = Application.Round(FileLen(currdir & filename) / 1024, 0) 'size Application.StatusBar = Row End If End If End If filename = Dir() Loop ' Process the found directories, recursively For i = 0 To NumDirs - 1 RecursiveDir Dirs(i) Next i Application.StatusBar = False End Sub Function FileInfo(path, filename, item) As Variant Dim objShell As IShellDispatch4 Dim objFolder As Folder3 Dim objFolderItem As FolderItem2 Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.Namespace(path) Set objFolderItem = objFolder.ParseName(filename) FileInfo = objFolder.GetDetailsOf(objFolderItem, item) Set objShell = Nothing Set objFolder = Nothing Set objFolderItem = Nothing End Function |
#2
|
||||
|
||||
So change 'MP3' in the code to 'MKV'. Since I don't know what an MKV file is, though, I can't say whether the rest of the code that's trying to extract the FileInfo will work.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
You need to change this instance
Code:
If UCase(Right(filename, 3)) = "MP3" Then Code:
If UCase(Right(filename, 3)) = "MKV" Then |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Code for shading part of a word | SQLUSA | Word | 4 | 10-29-2013 05:57 AM |
How to transpose the datas of part code and supplier into row and column | PRADEEPB270 | Excel | 3 | 10-26-2012 07:22 PM |
VBA code for changing capital letters become lower | Jasa P | Word VBA | 6 | 05-02-2012 12:10 AM |
changing font size without changing leading | carolns | Word | 1 | 09-14-2009 12:30 PM |
Code for Changing Cell Backgrounds | leroytrolley | Excel | 2 | 12-05-2008 02:05 AM |