bir klasörün içinde "abc" ile başlayan jpg uzantılı dosyaların sayıs

[hsayar]

Esenlikler
excel vba ile bir klasörün içinde "abc" ile başlayan jpg uzantılı dosyaların sayısını nasıl tespit edebiliriz?

klsr =c:\resim
bas = "abc"
son = ".jpg"
Ara = ???
adt = Ara.????

 

[Haluk]

Sub Test()
    MyPath = "C:\Resim"
    MyFile = Dir(MyPath & "\*.jpg", vbDirectory)
    Do While MyFile <> ""
        If MyFile Like "abc*" Then
            adt = adt + 1
        End If
        MyFile = Dir
    Loop
    MsgBox "Bulunan dosya sayısı : " & adt & " adet"
End Sub

 

[hsayar]

teşekkür ederim hocam emeğinize sağlık

 

[hsayar]

hocam ancak bir sorun var
ben çalıştırdığımda If MyFile Like "[vtmahbirimler.xls-ilveilce]_[E8_H21]*" Then
satırında invalid pattern string hatası veriyor... ne yapabilirz?

Sub TestKlsSay()
Dim MyPath, MyFile As String
Dim araIsm
Dim adt As Integer
    MyPath = "C:\Resim"
    araIsm = "[vtmahbirimler.xls-ilveilce]_[E8_H21]*"
    MyFile = Dir(MyPath & "\*.jpg", vbDirectory)
    Do While MyFile <> ""
        If MyFile Like "[vtmahbirimler.xls-ilveilce]_[E8_H21]*" Then
'        If MyFile Like araIsm Then
            adt = adt + 1
        End If
        MyFile = Dir
    Loop
    MsgBox "Bulunan dosya sayısı : " & adt & " adet"
End Sub

 

[tamer42]

If MyFile Like "[vtmahbirimler.xls-ilveilce]_[E8_H21]*" Then

bu satırı silin

 

[Kemal Demir]

Haluk Bey'în kodunda şöyle bir değişiklik yapmamızda bir mahsur yoktur umarım.

Sub Test()
    MyPath = "C:\Resim"
    myfile = Dir(MyPath & "\*.jpg", vbDirectory)
    Do While myfile <> ""
[b][u]' ifadenizde ilk 3 harften bahsediyorsan&#305;z e&#287;er ,a&#351;ag&#305;daki kod'uda kullanabilirsiniz[/b][/u] 
       If Left(myfile, 3) = "abc" Then
            adt = adt + 1
isim = MyFile & vbCrLf & isim
        End If
        myfile = Dir
    Loop
    MsgBox "Bulunan dosya say&#305;s&#305; : " & adt & " adet"
MsgBox "Bulunan dosya isimler: " & vbCrLf & isim & vbCrLf
End Sub

Haluk Hocamızın izni ile;

 

[hsayar]

Sn Rakkas kodları henüz denemedim ancak ilk üç harf diye bir kısıtlama yok. Önce buna açıklma getirmek isterim;

AraMet = AranacakMetin
AraUzn = len(AraMet)

değerlerimiz tespit edilmiş olsun, c:\resim klasöründeki ilk arauzn harfi AraMet ile başlayan jpg uzantılı dosya kaç adettir?
Sorumuz budur.

 

[hsayar]

Sizin kodlarınız içinde yaptığım revizyonda aşağıdaki gibi çalışıyor,
Sayın haluk'un yöntemindeki reviyon ne şekilde olmalı acaba?
Yada şöyle sorayaım dosya sayısı artıkça bu yöntem mi, If MyFile Like araIsm yöntemi mi, kasmaksızın(stabil) çalışır?
mü yoksa

Sub TestKlsSay_rakkas()
Dim MyPath, MyFile, AraMet, isim As String, AraUzn%
Dim adt As Integer
    MyPath = "C:\Resim"
    MyFile = Dir(MyPath & "\*.jpg", vbDirectory)
    AraMet = "[vtmahbirimler.xls-ilveilce]_[E8_H21]"
    AraUzn = Len(AraMet)
    Do While MyFile <> ""
' ifadenizde ilk 3 harften bahsediyorsanız eğer ,aşagıdaki kod'uda kullanabilirsiniz
       If Left(MyFile, AraUzn) = AraMet Then
            adt = adt + 1
isim = MyFile & vbCrLf & isim
        End If
        MyFile = Dir
    Loop
    MsgBox "Bulunan dosya sayısı : " & adt & " adet"
MsgBox "Bulunan dosya isimler: " & vbCrLf & isim & vbCrLf
End Sub

 

[Kemal Demir]

Esenlikler
excel vba ile bir klasörün içinde "abc" ile başlayan jpg uzantılı dosyaların sayısını nasıl tespit edebiliriz?

klsr =c:\resim
bas = "abc"
son = ".jpg"
Ara = ???
adt = Ara.????

İlk mesajınız da "abc" ile başlayan dediğiniz için ben öyle düşündüm.Aksi bir durumda Haluk Bey'in kodu yeterlidir.

 

[hsayar]

İlk mesajınız da "abc" ile başlayan dediğiniz için ben öyle düşündüm.Aksi bir durumda Haluk Bey'in kodu yeterlidir.

da... o kodda "[" ve "]" karekterlerini beğenmiyor

 

[Korhan Ayhan]

Selamlar,

Kodu aşağıdaki şekilde değiştirip denermisiniz.

Sub TestKlsSay()
Dim MyPath, MyFile As String
Dim araIsm As String
Dim adt As Integer
    MyPath = "C:\Resim"
    araIsm = "[vtmahbirimler.xls-ilveilce]_[E8_H21]"
    araIsm = Replace(Replace(araIsm, "[", "("), "]", ")")
    MyFile = Dir(MyPath & "\*.jpg", vbDirectory)
    Do While MyFile <> ""
        If Replace(Replace(MyFile, "[", "("), "]", ")") Like "*" & araIsm & "*" Then
            adt = adt + 1
        End If
        MyFile = Dir
    Loop
    MsgBox "Bulunan dosya say&#305;s&#305; : " & adt & " adet"
End Sub

 

[Haluk]

da... o kodda "[" ve "]" karekterlerini beğenmiyor

Şimdi beğenir artık.... :mrgreen:

Sub Test2()
    MyPath = "C:\Resim"
    MyFile = Dir(MyPath & "\*.jpg", vbDirectory)
    Do While MyFile <> ""
        If MyFile Like "[[]vtmahbirimler.xls-ilveilce[]]_[[]E8_H21[]]*" Then
            adt = adt + 1
        End If
        MyFile = Dir
    Loop
    MsgBox "Bulunan dosya say&#305;s&#305; : " & adt & " adet"
End Sub

 

[hsayar]

Korhan hocam anlaşılan köşeli paranteleri kabul ettirmenin yolu yok, neyse
(vtmahbirimler.xls-ilveilce)_(E8_H21)_004.jpg
[vtmahbirimler.xls-ilveilce]_[E8_H21]_004.jpg

arasında fark etmiyor çünkü, neyse buna da razı olacağız artık. Çok teşekkür ederim.

İlave olarak Şöyle bir şey sorsam;
Bulunan dosyaların listesini aktif çalışma sayfasının a1 hücresinden itibaren yaz nasıl derim?

 

[Haluk]

Korhan hocam anlaşılan köşeli paranteleri kabul ettirmenin yolu yok, neyse

??????

Yukarıda benim 12nci mesajıma baktınız mı ?


.

 

[hsayar]

Haluk hocam alakanıza teşekkür ederim;

Sub TestKlsSay_Haluk()
Dim MyPath, MyFile As String
Dim araIsm As String
Dim adt As Integer
    araIsm = "[[]vtmahbirimler.xls-ilveilce[]]_[[]E8_H21[]]"
    araIsm = araIsm & "*" 'araIsm  ile başlayanlar
  '  araIsm = "[vtmahbirimler.xls-ilveilce]_[E8_H21]*"
  '  araIsm = Replace(Replace(araIsm, "[", "["), "]", "]")
    MyPath = "C:\Resim"
    MyFile = Dir(MyPath & "\*.jpg", vbDirectory)
    Do While MyFile <> ""
        If MyFile Like araIsm Then
            adt = adt + 1
        End If
        MyFile = Dir
    Loop
    MsgBox "Bulunan dosya say&#305;s&#305; : " & adt & " adet"
End Sub

kod dizesinde prosodür işlerken [vtmahbirimler.xls-ilveilce]_[E8_H21] haline gelen metin ile başlayanların listesini öğrenip sonuna sayaçnosu eklemek amacım. dolayısı ile "[[]vtmahbirimler.xls-ilveilce[]]_[[]E8_H21[]]" haline kendiliğinden dönüştürmem gerekiyor ancak replacelala denedim tutturamadım.
Tekrar yardım ederseniz sevinirim.

 

[hsayar]

özür dilerim hata ile dömnüştürmemem yazmışım, doğrusu dönüştürmem olacaktır.

 

[Haluk]

Neden bahsettiğinizi anlamıyorum, dönüştürülen falan birşey yok. Zaten herhangibir şeyi de dönüştermeye gerek yok.......

Önerdiğim kodu çalıştırınca, [vtmahbirimler.xls-ilveilce]_[E8_H21]_004.jpg gibi dosyalardan kaç tane olduğunu öğreniyorsunuz.

Bu değil mi sizin sorduğunuz ?????????


.

 

[hsayar]

şöyle izah edeyim hocam;

Sub subhsr_Selection_ScreenShot()
'#########################################################################################################'
'#########         Aktif Çalışma Sayfasında seçili olan hücreleri ve üzerindeki                  #########'
'#########         grafik, resim vs. şekillerin resmini çekip c:\resim altına                    #########'
'#########         kaydeder.                                                                     #########'
'#########         [URL="http://www.Excel.web.tr"]www.Excel.web.tr[/URL] den Anemos ve Seyit Diken 'in katkılarıyla                   #########'
'#########         hsayar tarafından hazırlanmıştır.                                             #########'
'#########################################################################################################'
1 Dim DsSisKnt, Pic, graf, Dosyalar, dosya, ws, wb As Object
2 Dim KytKls$, uznKls$, KytDAd$, uznDAd$, ara$, sycDno%, Arlk
3 Set DsSisKnt = CreateObject("Scripting.FileSystemObject")
4 Set ws = Selection.Parent:         Set wb = ws.Parent
5 On Error GoTo hata
'\  Seçili Alanın resmini çeker;
6 Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture: GoTo islem
7 hata:
8    MsgBox "Birleşik aralıkta bir seçim yapmalısınız": GoTo Son
9 islem:
'**\     Çekilen resmi pic değişkenine atayarak yapıştır, sayfadan siler.
10        Set Pic = ActiveSheet.Pictures.Paste
11        With Pic
12      '      .Copy
13            .Delete
14        End With
15        Set Pic = Nothing
'**\     Resmin kaydedileceği klasör ve dosya adı ve uzunluk bilgileri hazırlanır.
16        KytKls = "C:\Resim\":           Call SubHsr_Klsr_Yks_Olstr(KytKls)
17        uznKls = Len(KytKls)
171       Arlk = "[" & Replace(Replace(Selection.address, ":", "_", 1), "$", "", 1) & "]_"
18        [COLOR=red][B]KytDAd = "[" & wb.Name & "-" & ws.Name & "]_" & Arlk[/B][/COLOR]
           uznDAd = Len(KytDAd)
'**\    Dizindeki Dosya Adlarını Kaydedilecek Dosya Adı ile karşılaştır...
19        Set Dosyalar = DsSisKnt.GetFolder(KytKls).Files
20        For Each dosya In Dosyalar
21            ara = Mid$(KytKls & KytDAd, uznKls + 1, uznDAd)
22            If ara = KytDAd Then sycDno = sycDno + 1
23        Next
24        Set Dosyalar = Nothing:                 Set dosya = Nothing
'**\    Çekilen Resmi, jpg olarak kaydet
25        Set graf = ActiveSheet.ChartObjects.Add(1, 1, Selection.Width + 2, Selection.Height + 2).Chart
251       KytDAd = KytKls & KytDAd & Format(sycDno + 1, "000") & ".jpg"
26        With graf
27            .Paste
28            .Export KytDAd
29            .Parent.Delete
30        End With
31        Set graf = Nothing
32 Son:
33    Set DsSisKnt = Nothing
34    Set ws = Nothing
End Sub

18. satıra geldiğinda kaydedilecek dosyanın adı oluşmuş oluyor yani [vtmahbirimler.xls-ilveilce]_[E8_H21]_ haline geliyor. buradan sonra başı bu halde olan hiç dosya yoksa [vtmahbirimler.xls-ilveilce]_[E8_H21]_001 olarak kaydetmesini istiyorum. vtmahbirimler.xls-ilveilce]_[E8_H21]_ ile başlayan 5 dosya varsa [vtmahbirimler.xls-ilveilce]_[E8_H21]_006 olarak kaydetmesini istiyorum.

19 ila 23. satırlar arasında yaptığım denemede KytDAd ile başlayanları değil,resimdende görüleceği üzere dizindeki dosya sayısına göre sayacı artırıyor.

bu nedenle ben çekilen resmin abc001,abc002 ile giderken alan değişince bcd001, bcd002 gibi gitmesini istiyorum.

Saygılarımla.

[LEFT]Sub TestKlsSay_Haluk()
Dim MyPath, MyFile As String
Dim araIsm As String
Dim adt As Integer
   araIsm = "[[]vtmahbirimler.xls-ilveilce[]]_[[]E8_H21[]]"
   araIsm = araIsm & "*" 'araIsm  ile başlayanlar
 '  araIsm = "[vtmahbirimler.xls-ilveilce]_[E8_H21]*"
 '  araIsm = Replace(Replace(araIsm, "[", "["), "]", "]")
   MyPath = "C:\Resim"
   MyFile = Dir(MyPath & "\*.jpg", vbDirectory)
   Do While MyFile <> ""
       If MyFile Like araIsm Then
           adt = adt + 1
       End If
       MyFile = Dir
   Loop
   MsgBox "Bulunan dosya say&#305;s&#305; : " & adt & " adet"
End Sub[/LEFT]

Yani sizin kodlarınızdaki AraIsm değişkeni benim KytDAd değişkenine eşit olacak ve arama yapılacaktır.

 

[Haluk]

Önerdiğim kodu fonksiyon haline getirip, sizin kodun içinden çağırdım....

.

Sub subhsr_Selection_ScreenShot_R()
'#########################################################################################################'
'#########         Aktif Çalışma Sayfasında seçili olan hücreleri ve üzerindeki                  #########'
'#########         grafik, resim vs. şekillerin resmini çekip c:\resim altına                    #########'
'#########         kaydeder.                                                                     #########'
'#########         www.Excel.web.tr den Anemos ve Seyit Diken 'in katkılarıyla                   #########'
'#########         hsayar tarafından hazırlanmıştır.                                             #########'
'#########################################################################################################'
1 Dim DsSisKnt, Pic, graf, Dosyalar, dosya, ws, wb As Object
2 Dim KytKls$, uznKls$, KytDAd$, uznDAd$, ara$, sycDno%, Arlk
3 Set DsSisKnt = CreateObject("Scripting.FileSystemObject")
4 Set ws = Selection.Parent:         Set wb = ws.Parent
5 On Error GoTo hata
'\  Seçili Alanın resmini çeker;
6 Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture: GoTo islem
7 hata:
8    MsgBox "Birleşik aralıkta bir seçim yapmalısınız": GoTo Son
9 islem:
'**\     Çekilen resmi pic değişkenine atayarak yapıştır, sayfadan siler.
10        Set Pic = ActiveSheet.Pictures.Paste
11        With Pic
12      '      .Copy
13            .Delete
14        End With
15        Set Pic = Nothing
'**\     Resmin kaydedileceği klasör ve dosya adı ve uzunluk bilgileri hazırlanır.
16        KytKls = "C:\Resim\":           'Call SubHsr_Klsr_Yks_Olstr(KytKls)
17        uznKls = Len(KytKls)
171       Arlk = "[" & Replace(Replace(Selection.Address, ":", "_", 1), "$", "", 1) & "]_"
18        KytDAd = "[" & wb.Name & "-" & ws.Name & "]_" & Arlk
           uznDAd = Len(KytDAd)
'**\    Dizindeki Dosya Adlarını Kaydedilecek Dosya Adı ile karşılaştır...
'19        Set Dosyalar = DsSisKnt.GetFolder(KytKls).Files
'20        For Each dosya In Dosyalar
'21            ara = Mid$(KytKls & KytDAd, uznKls + 1, uznDAd)
'22            If ara = KytDAd Then sycDno = sycDno + 1
'23        Next
          sycDno = GetLast(KytKls & KytDAd)
24        Set Dosyalar = Nothing:                 Set dosya = Nothing
'**\    Çekilen Resmi, jpg olarak kaydet
25        Set graf = ActiveSheet.ChartObjects.Add(1, 1, Selection.Width + 2, Selection.Height + 2).Chart
251       KytDAd = KytKls & KytDAd & Format(sycDno + 1, "000") & ".jpg"
26        With graf
27            .Paste
28            .Export KytDAd
29            .Parent.Delete
30        End With
31        Set graf = Nothing
32 Son:
33    Set DsSisKnt = Nothing
34    Set ws = Nothing
End Sub
'
Function GetLast(MyPath As String) As Long
    Dim adt As Long
    MyFile = Dir(MyPath & "*.jpg", vbDirectory)
    Do While MyFile <> ""
        If MyFile Like "[[]" & ThisWorkbook.Name & "-" & ActiveSheet.Name & "[]]_[[]" & Replace(Selection.Address(False, False), ":", "_") & "[]]*" Then
            adt = adt + 1
        End If
        MyFile = Dir
    Loop
    GetLast = adt
End Function

 

[hsayar]

ellerinize sağlık hocam istediğim buydu sadece ThisWorkbook tan değil ActiveWorkbook Kullanamk zorundayım onu değiştirdim.