Results 1 to 4 of 4

Thread: Changing a part of vba code

  1. #1

    Changing a part of vba code



    Register for a FREE account, and/
    or Log in to avoid these ads!

    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. #2
    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 by Bob Phillips; 2014-09-11 at 02:33 PM.

  3. #3
    Conjurer snb's Avatar
    Join Date
    May 2013
    Posts
    375
    Articles
    0
    Excel Version
    2020
    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 by snb; 2014-09-11 at 04:57 PM.

  4. #4
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •