Dosya Özelliği(Uzunluk) bulma

[turist]

Ekli excel dosyası bilgisayarınızda istediğiniz harddiskten, istediğiniz klasörün içindeki mp3, mp4, avi vb. gibi dosyaları listelemektedir.
Bu işlemi macro ile yapmaktadır.
Macro kodları ; Dosya Yolu, Dosya İsmi,Boyutu(Mb) ve Son değiştirme tarihlerini bulabilirken, Dosyanın Uzunluğu(Length) yani süresini bulamıyor.
Kodlarda yer alan:

 Cells(iRow, iCol).Value = myFile.Length

satırı herhangibir bilgi getirmiyor.
Bu satır ne şekilde düzenlenebilir veya alternatif bir kod uygulanabilir mi?

Üstad ve konu hakkında bilgi sahibi arkadaşlarımızın yardımcı olacağını umuyor, katkılarınız için şimdiden teşekkür ediyorum.

 

[SadiSerdari]

Sayın Halit3 beyin verdiği kodlar işinize yarayacaktır.

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Sub zaman_bul()

 	On Error Resume Next
	'Columns("b:b").ClearContents
	Dim yer As String
	Dim lRet As Long
	Dim sReturn As String
	Dim iMin As Integer
	Dim iSec As Integer
	Dim iSat As Integer
	
	For i = 11 To [B65536].End(3).Row
		Dosya_adi = Cells(i, 2).Value
		yer = Space$(255)
		lRet = GetShortPathName(Dosya_adi, yer, Len(yer))

		If lRet <> 0 Then
			Dosya_adi = Left$(yer, InStr(yer, vbNullChar) - 1)
		End If
		
		mciSendString "open " & Dosya_adi & " type MPEGVideo alias mp3audio", 0, 0, 0
		sReturn = Space$(256)
		lRet = mciSendString("status mp3audio length", sReturn, Len(sReturn), 0&)
		mciSendString "close mp3audio", 0, 0, 0

		iSec = Int(Val(sReturn) / 1000)
		iMin = Int(iSec / 60)
		iSec = iSec - (iMin * 60)
		
		If iMin > 59 Then
			iSat = Int(iMin / 60)
			iMin = iMin - (Int(iMin / 60) * 60)
		End If
		
		Cells(i, "G").Value = Format$(iSat, "00") & ":" & Format$(iMin, "00") & ":" & Format$(iSec, "00")
	Next
	
	MsgBox "işlem tamamlandı"
	
End Sub

 

[Levent Menteşoğlu]

Ekte verdiğim dosyadaki kodları kendi dosyanıza uyarlayabilirsiniz.

 

[halit3]

Sayın SadiSerdari kodu vermiş bende sizin kodunuzla özleştirdim.

kod:

Dim iRow
[COLOR=red]Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long[/COLOR]
[COLOR=red]Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long[/COLOR]
 
Sub ListFiles()
    iRow = 11
    Range("B11:f65500") = ""
    Call ListMyFiles(Range("C7"), Range("C8"))
End Sub
Sub ListMyFiles(mySourcePath, IncludeSubfolders)
    Set MyObject = New Scripting.FileSystemObject
    Set mySource = MyObject.GetFolder(mySourcePath)
    On Error Resume Next
 
   [COLOR=red] Dim yer As String[/COLOR]
[COLOR=red]    Dim lRet As Long[/COLOR]
[COLOR=red]    Dim sReturn As String[/COLOR]
[COLOR=red]    Dim iMin As Integer[/COLOR]
[COLOR=red]    Dim iSec As Integer[/COLOR]
[COLOR=red]    Dim iSat As Integer[/COLOR]
 
 
    For Each myFile In mySource.Files
        iCol = 2
        Cells(iRow, iCol).Value = myFile.Path
        iCol = iCol + 1
        Cells(iRow, iCol).Value = myFile.Name
        iCol = iCol + 1
        Cells(iRow, iCol).Value = myFile.Size / 1024000
        iCol = iCol + 1
         Cells(iRow, iCol).Value = myFile.Length
        iCol = iCol + 1
        Cells(iRow, iCol).Value = myFile.DateLastModified
 
 
 
       [COLOR=red] Dosya_adi = myFile.Path[/COLOR]
[COLOR=red]        yer = Space$(255)[/COLOR]
[COLOR=red]        lRet = GetShortPathName(Dosya_adi, yer, Len(yer))[/COLOR]
[COLOR=red]        If lRet <> 0 Then[/COLOR]
[COLOR=red]            Dosya_adi = Left$(yer, InStr(yer, vbNullChar) - 1)[/COLOR]
[COLOR=red]        End If[/COLOR]
[COLOR=red] [/COLOR]
[COLOR=red]        mciSendString "open " & Dosya_adi & " type MPEGVideo alias mp3audio", 0, 0, 0[/COLOR]
[COLOR=red]        sReturn = Space$(256)[/COLOR]
[COLOR=red]        lRet = mciSendString("status mp3audio length", sReturn, Len(sReturn), 0&)[/COLOR]
[COLOR=red]        mciSendString "close mp3audio", 0, 0, 0[/COLOR]
[COLOR=red]        iSec = Int(Val(sReturn) / 1000)[/COLOR]
[COLOR=red]        iMin = Int(iSec / 60)[/COLOR]
[COLOR=red]        iSec = iSec - (iMin * 60)[/COLOR]
[COLOR=red] [/COLOR]
[COLOR=red]        If iMin > 59 Then[/COLOR]
[COLOR=red]            iSat = Int(iMin / 60)[/COLOR]
[COLOR=red]            iMin = iMin - (Int(iMin / 60) * 60)[/COLOR]
[COLOR=red]        End If[/COLOR]
[COLOR=red] [/COLOR]
[COLOR=red]        Cells(iRow, "E").Value = Format$(iSat, "00") & ":" & Format$(iMin, "00") & ":" & Format$(iSec, "00")[/COLOR]
[COLOR=red] [/COLOR]
 
        iRow = iRow + 1
 
 
 
 
    Next
    If IncludeSubfolders Then
        For Each mySubFolder In mySource.SubFolders
            Call ListMyFiles(mySubFolder.Path, True)
        Next
    End If
End Sub

 

[turist]

Sn.SadiSerdari , Sn.LeventMenteşoğlu ve Sn.halit3

İlgi ve yardımlarınız için çok teşekkür ederim.Sağolunuz.

 

[halit3]

Sn.SadiSerdari , Sn.LeventMenteşoğlu ve Sn.halit3

İlgi ve yardımlarınız için çok teşekkür ederim.Sağolunuz.

Teşekkürler iyi çalışmalar