Changing a part of vba code

Milade8080

New member
Joined
Mar 13, 2014
Messages
19
Reaction score
0
Points
0
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:
[/FONT][/COLOR]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


[COLOR=#000000][FONT=verdana]
 
As far as I can see, it gets all file types, not just mp3, already, and then outsorts the mp3 files

Code:
            If UCase(Right(filename, 3)) = "MP3" Then

so you could just change the mp3 here to mkv.
 
Last edited:
assuming the files reside in folder "G:\OF\" and it's subfolders

Code:
Sub M_snb()
   sn=split(createobject("wscript.shell").exec("cmd /d Dir """ & c00 & "*.mkv"" /b/s/a").stdout.readall,vbcrlf)

   with createobject("scripting.dictionary")
   for j=0 to ubound(sn)-1
      c01=dir(sn(j))
      With CreateObject("shell.application").namespace("E:\OF\")
               sp=array(left(sn(j),len(sn(j))-len(c01)),c01),.getdetailsof(.Items.Item(c01), 20), .getdetailsof(.Items.Item(c01), 14),.getdetailsof(.Items.Item(c01), 21),.getdetailsof(.Items.Item(c01), 26),.getdetailsof(.Items.Item(c01), 16),.getdetailsof(.Items.Item(c01), 27),filelen(sn(j)))
     End With
     .item("n_" & .count)=sp
   next

   cells(1).resize(.count,9)=application.index(.items,0,0)
end with
End Sub
 
Last edited:
Code:
Sub GetAllFiles()
 '
'
'
   Cells.Clear
FileType = InputBox ("Enter the file type to retrieve", etc,etc
    Call RecursiveDir(Directory, FileType)
End Sub

Code:
Public Sub RecursiveDir(ByVal currdir As String, FileType As String)
'
'
'

If UCase(Right(filename, 3)) = FileType" Then
'
'
'End Sub
 
Back
Top