Ses dosyalarının çalma süresi hakkında

[cellswhite]

İyi çalışmalar arkadaslar,

Bir konuda ricam olacak destek verebilirseniz çok sevineceğim.

"C:\out" klasoru içerisindeki ses dosyalarının ornek "c:\out\ses1.waw" , dosyaları açmadan sürelerini gösterebilecek bir kod varmıdır.

Varsa paylaşabilirmisiniz.

İyi çalışmalar.

 

[cellswhite]

Dosya özelliklerini içeren kodlar gördüm.Modifiye edemedim.
sadece a kolonundaki ses dosya yollarına bakarak "duration" değerni vermesi yeterli.

Teşekkurler.

 

[halit3]

Dosya özelliklerini içeren kodlar gördüm.Modifiye edemedim.
sadece a kolonundaki ses dosya yollarına bakarak "duration" değerni vermesi yeterli.

Teşekkurler.

A kolundaki ses dosyalarına ait süreleri B kolununa çıkarıyor.

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()
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 = 2 To [A65536].End(3).Row
Dosya_adi = Cells(i, 1).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
On Error Resume Next
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, "b").Value = Format$(iSat, "00") & ":" & Format$(iMin, "00") & ":" & Format$(iSec, "00")
Next
MsgBox "işlem tamamlandı"
End Sub

 

[halit3]

Buda farklı bir uygulama

Sub süreler()
For i = 2 To Cells(Rows.Count, "a").End(3).Row
yer = Mid(Cells(i, "a"), 1, Len(Cells(i, "a")) - Len(Dir(Cells(i, "a"))) - 1)
Set Dosya = CreateObject("Shell.Application").Namespace(yer).ParseName(Dir(Cells(i, "a")))
'ListBox3.AddItem CreateObject("Shell.Application").Namespace(yer).GetDetailsOf(, i)
If CreateObject("Shell.Application").Namespace(yer).GetDetailsOf(Dosya, 27) <> "" Then
Cells(i, "b") = CreateObject("Shell.Application").Namespace(yer).GetDetailsOf(Dosya, 27)
Else
Cells(i, "b") = CreateObject("Shell.Application").Namespace(yer).GetDetailsOf(Dosya, 21)
End If
Next
MsgBox "işlem tamam"
End Sub

 

[hımmmmmmmm]

slm

frekans vererek nota çalma komutu arıyorum...
elinde nasıl bir çalışma var ...
440 la yı- 220 yapmam gerek... 220 frekansdan ses almam lazım...
aradığım batı sisteminin frekansları değil... koma sesler bulmak...
========================================================

 

[hımmmmmmmm]

slm

bu konuda biline bir komut varmı

 

[hımmmmmmmm]

slm

eski sürüm vb lerde sound komutu vardı... şimdilerde farklı kullanılıyor...

 

[halit3]

frekans vererek nota çalma komutu arıyorum...
elinde nasıl bir çalışma var ...
440 la yı- 220 yapmam gerek... 220 frekansdan ses almam lazım...
aradığım batı sisteminin frekansları değil... koma sesler bulmak...
========================================================

Ben anlıyamadım yukarıdaki kodlar bir müzik dosyasına ait süreleri veriyor sizin yazdığınızdan bir şey anlıyamadım. birazcık detaylı anlatırmısınız.

 

[cellswhite]

Halit Bey selamlar,

İlk kodu çalıştırdım teşekkurler.2 kodu çalıştıramadım. Dosyanın tam adını almıyor sadece ses dosyasının oldugu klasor ismini almaktadır.
Yada ben yapamadım.
Yinede işimi gördü deşekkurler.

 

[halit3]

Halit Bey selamlar,

İlk kodu çalıştırdım teşekkurler.2 kodu çalıştıramadım. Dosyanın tam adını almıyor sadece ses dosyasının oldugu klasor ismini almaktadır.
Yada ben yapamadım.
Yinede işimi gördü deşekkurler.

A sutünunda müzik dosyasının tam adresi olacak ve aşağıdaki kodun kırmızı yerdeki değerle oyna birazcık yani 21-27 değer arasında değiştirerek dene

Sub süreler()
For i = 1 To Cells(Rows.Count, "a").End(3).Row
yer = Mid(Cells(i, "a"), 1, Len(Cells(i, "a")) - Len(Dir(Cells(i, "a"))) - 1)
Set Dosya = CreateObject("Shell.Application").Namespace(yer).ParseName(Dir(Cells(i, "a")))
Cells(i, "b") = CreateObject("Shell.Application").Namespace(yer).GetDetailsOf(Dosya, [COLOR=red]21[/COLOR])
Next
MsgBox "işlem tamam"
End Sub

 

[hımmmmmmmm]

slm

türk sanat müziği batı seslerini kullanmaz... ancak LA sesinin 440 frekansı neva(RE) sesine göçürülür... LA(dügah) sesi ise 220 yapılır...

koma ise 2 ses arasındaki 9 ayrı sesdir... makamlar Koma seslerin 2.4.5.ve 8. seslerini ve ana sesleri kullanılır... böylece TSM de 25 nota olmaktadır.. batıda ise 8 nota...
bu 25 sesi VBa de çıkarmak mümkün değil... ancak bu seslerin frekansları vardır...
eski QBasic de sound (220) ile bu sesleri almaktaydım... veya diğer frekansları... play ilede batı notaları çıkıyordu...

şimdi visualde bu 25 frekans sesi çıkarabilmek için komut arıyorum...

mesela; excel vba de(MIDI) nota numaraları var... nota numaraları bildiğimiz bir piyanonun sesleridir. numaralar oktav için numaralandırılmış ve nota sayılmış... sonuçda bir frekans sayısının sesidir... fakat bu sesler TSM nin asıl sesleri değildir...
vba yı değiştiremeyeceğimize göre falanca frekanstan ses çıkaran bir kot veya komut gerekiyoki TSM sesleirni çıkarabileyim...

 

[fremen17]

cevap

Private Type tbeep
F As Long
D As Long
End Type

Private Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal _
dwDuration As Long) As Long

Sub q()
B As tbeep

B.F = 220 ' Frequency interval from 37 to 10000
B.D = 100 ' Duration

Beep B.F, B.D

end sub

işinizi görümü bilmiyorum ama şöyle bir fonksiyon var