Samsak Döveci

Kütahya, Tavşanlı yöresine ait olduğu öğrenilen "Samsak Döveci" için hazırlanmış videonun altyazı dosyasını paylaştım.

https://www.youtube.com/embed/-7ivGse6p9o yerleştirme kodlu video yayından kaldırılmış, söz konusu içeriğin alt yazısı berbat durumda olduğu için bu alt yazı hazırlanmıştı. Fakat her zamanki gibi, gerek kalmadığı için alt yazı burada kaldı.

1 00:00:02,120 --> 00:00:06,176 Langıdı lanlan langıdı lanlan Samsak döveci 2 00:00:06,201 --> 00:00:10,003 Gümbüdü gümbam gümbam gümbam Ebegümeci 3 00:00:10,035 --> 00:00:14,169 Ebelerin ilacıdır ebegümeci 4 00:00:14,448 --> 00:00:18,288 Uyuz eşek yoncasıdır ebegümeci 5 00:00:18,523 --> 00:00:22,616 Ebegümecini toplayalım 6 00:00:22,641 --> 00:00:26,462 Lazım olur saklayalım 7 00:00:26,749 --> 00:00:30,595 Lazım olur saklayalım 8 00:00:30,845 --> 00:00:34,799 Ardımıza bile bakmayalım 9 00:00:34,888 --> 00:00:39,028 Langıdı lanlan langıdı lanlan Samsak döveci 10 00:00:39,067 --> 00:00:42,647 Gümbüdü gümbam gümbam gümbam Ebegümeci 11 00:00:43,175 --> 00:00:47,248 Ebelerin ilacıdır ebegümeci 12 00:00:47,273 --> 00:00:51,049 Uyuz eşek yoncasıdır ebegümeci 13 00:00:51,119 --> 00:00:55,393 Langıdı lanlan langıdı lanlan Samsak döveci 14 00:00:55,483 --> 00:00:59,203 Gümbüdü gümbam gümbam gümbam Ebegümeci 15 00:00:59,584 --> 00:01:03,644 Ebelerin ilacıdır ebegümeci 16 00:01:03,683 --> 00:01:07,389 Uyuz eşek yoncasıdır ebegümeci 17 00:01:07,490 --> 00:01:11,856 ♫ 18 00:01:11,881 --> 00:01:15,958 ♫ 19 00:01:15,983 --> 00:01:20,070 ♫ 20 00:01:20,095 --> 00:01:24,180 ♫ 21 00:01:24,205 --> 00:01:28,284 ♫ 22 00:01:28,309 --> 00:01:32,387 ♫ 23 00:01:32,412 --> 00:01:36,481 ♫ 24 00:01:36,506 --> 00:01:40,678 ♫ 25 00:01:40,703 --> 00:01:44,686 Ebegümecini pişirdim 26 00:01:44,711 --> 00:01:48,751 Yedim yedim karnımı şişirdim 27 00:01:48,776 --> 00:01:52,826 Yedim yedim karnımı şişirdim 28 00:01:52,898 --> 00:01:56,958 Komşuları başıma üşürdüm 29 00:01:57,022 --> 00:02:01,068 Langıdı lanlan langıdı lanlan Samsak döveci 30 00:02:01,127 --> 00:02:04,888 Gümbüdü gümbam gümbam gümbam Ebegümeci 31 00:02:05,217 --> 00:02:09,283 Ebelerin ilacıdır ebegümeci 32 00:02:09,340 --> 00:02:13,366 Uyuz eşek yoncasıdır ebegümeci 33 00:02:13,438 --> 00:02:17,485 Langıdı lanlan langıdı lanlan Samsak döveci 34 00:02:17,546 --> 00:02:21,580 Gümbüdü gümbam gümbam gümbam Ebegümeci 35 00:02:21,645 --> 00:02:25,678 Ebelerin ilacıdır ebegümeci 36 00:02:25,740 --> 00:02:29,787 Uyuz eşek yoncasıdır ebegümeci 37 00:02:29,812 --> 00:02:33,900 Langıdı lanlan langıdı lanlan Samsak döveci 38 00:02:33,942 --> 00:02:37,902 Gümbüdü gümbam gümbam gümbam Ebegümeci 39 00:02:38,025 --> 00:02:42,085 Ebelerin ilacıdır ebegümeci 40 00:02:42,148 --> 00:02:45,848 Uyuz eşek yoncasıdır ebegümeci 41 00:02:46,184 --> 00:02:50,297 Langıdı lanlan langıdı lanlan Samsak döveci 42 00:02:50,350 --> 00:02:54,170 Gümbüdü gümbam gümbam gümbam Ebegümeci 43 00:02:54,449 --> 00:02:58,482 Ebelerin ilacıdır ebegümeci 44 00:02:58,565 --> 00:03:01,991 Uyuz eşek yoncasıdır ebegümeci 45 00:03:02,038 --> 00:03:06,718 ♫ 46 00:03:06,749 --> 00:03:10,822 ♫ 47 00:03:10,877 --> 00:03:14,930 ♫ 48 00:03:14,965 --> 00:03:19,038 ♫ 49 00:03:19,063 --> 00:03:23,148 ♫ 50 00:03:23,173 --> 00:03:27,225 ♫ 51 00:03:27,250 --> 00:03:31,339 ♫ 52 00:03:31,364 --> 00:03:37,027 ♫

İstanbul, Üsküdar, Beylerbeyi Mahallesi, Eskiçınar Sokağı, No: 11

İstanbul Üniversitesi, Sosyal Bilimler Enstitüsü, İstanbul Araştırmaları Anabilim Dalı, İstanbul'da Mimarlık ve Sanat dersi bünyesinde, Sketchup ile yaptığımız çalışmalardan biri. İstanbul, Üsküdar, Beylerbeyi Mahallesi, Eskiçınar Sokağı, Numara 11.

Bu çalışma, İstanbul'un yok olmaya yüz tutmuş, vakıf eserlerinin kapsamı dışında kalan yapılarının dijitale aktarma denemesi olarak ortaya çıktı.

📍 Google: https://goo.gl/maps/BYA23oBEwrdjT63b7
📍 Yandex: https://yandex.com.tr/harita/-/CCUB5-FZdD

Fotoğraf eşleştirme başta olmak üzere, iz düşüm ile her bir detayı mümkün oldukça yakalamaya çalıştık. Çalışmayı hızlandırmak için komponentler kullanılmıştır. Sütun başlığı, trabzanlar gibi bazı organik objeler Blender ile oluşturulup Sketchup içerisine alınmıştır.

Çalışma boyunca yararlandığımız, Evren ÇAVUŞOĞLU'nun verdiği "Sketchup 7'den 70'e" kursunu tavsiye ederim.

💾 SKP 2020; 400 MB.
https://www.cgtrader.com/free-3d-models/architectural/other/istanbul-uskudar-beylerbeyi-eskicinar-11

---

Microsoft Excel VBA ile Seçtiğiniz Bir Klasörde Alt Klasör ve Dosya Detaylarını Listelemek

Merhabalar.

Bir müddet üstünde çalıştığım fakat bilgi eksikliği nedeniyle tamamlayamadığım bir Excel VBA denemesi vardı.

Mehmet CANBULAT'ın Excel VBA eğitimindeki bilgileri ve bu bağlantıdaki bilgileri bir araya getirip yaptığım deneyde istediğimi kısmen başardım.

Öncelikle Mehmet CANBULAT'ın Recursive Programming detayını verdiği vidyoyu paylaşayım. Burada FSO (File System Object) olarak bilinen objenin SubFolders özelliğini temel aldım.



Ardından Shell.Application objesinin GetDetailsOf özelliğini vidyoda anlatılan özyinelemeli yapının içine yerleştirdim.

Jess adlı kullanıcının paylaştığı refernas kod şu:
Sub GetFileName() Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Dim objShell As Object Dim objFolder As Object Dim objFile As Variant Dim i As Integer Dim bone As Workbook Set bone = ActiveWorkbook bone.Sheets("Result").Activate 'Create an instance of the FileSystemObject Set objShell = CreateObject("Shell.Application") 'Get the folder object Set objFolder = objShell.Namespace("C:\the folder path") 'loops through each file i = 1 For Each objFile In objFolder.items 'File Name Cells(i + 1, 1).Value = objFolder.GetDetailsOf(objFile, 0) 'File Size Cells(i + 1, 2).Value = objFolder.GetDetailsOf(objFile, 1) 'Dimensions Cells(i + 1, 3).Value = objFolder.GetDetailsOf(objFile, 31) 'Height Cells(i + 1, 4).Value = objFolder.GetDetailsOf(objFile, 164) 'Width Cells(i + 1, 5).Value = objFolder.GetDetailsOf(objFile, 162) 'Horizontal Resolution Cells(i + 1, 6).Value = objFolder.GetDetailsOf(objFile, 161) 'Vertical Resolution Cells(i + 1, 7).Value = objFolder.GetDetailsOf(objFile, 163) i = i + 1 Next objFile Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

Aşağıdaki döngüyü 450'ye kadar uzattım ve diğer etiketler de ortaya çıktı. 320'den sonra etiket değerlerinin boş olduğunu gördüm. Dolayısıyla son etiket sıra numarasını 320'de bıraktım. Metadata başlık listeleyici kodu aşağıdadır:
Attribute VB_Name = "Mod_Dosya_Detay_Ad" Sub Dosya_Detay_Adlari() Dim objShell As Object Dim objFolder As Object Dim testStr As String Dim propertyCnt As Long Dim i As Long Dim FldPath As String FldPath = "%USERPROFILE%\Pictures\" Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.Namespace(Left(FldPath, Len(FldPath) - 1)) 'no slash in the end 'Do ' testStr = vbNullString ' testStr = objFolder.GetDetailsOf(0, propertyCnt) ' If testStr = vbNullString Then Exit Do ' propertyCnt = propertyCnt + 1 ' Debug.Print testStr 'Loop For i = 1 To 320 testStr = objFolder.GetDetailsOf(0, i) Debug.Print i & " = " & testStr Next i Stop End Sub
Bu kod sonucu etiket adlarının listesi aşağıdaki gibidir. Eşittir "=" işaretinden sonra değer olmayan veriler de vardır.
1 = Boyut 2 = Öğe türü 3 = Değiştirme tarihi 4 = Oluşturma tarihi 5 = Erişim Tarihi 6 = Öznitelikler 7 = Çevrimdışı durumu 8 = Kullanılabilirlik 9 = Algılanan tür 10 = Sahibi 11 = Tip 12 = Çekildiği tarih 13 = Katkıda bulunan sanatçılar 14 = Albüm 15 = Yıl 16 = Tarz 17 = Orkestra Şefleri 18 = Etiketler 19 = Derecelendirme 20 = Yazarlar 21 = Başlık 22 = Konu 23 = Kategoriler 24 = Açıklamalar 25 = Telif Hakkı 26 = # 27 = Uzunluk 28 = Bit hızı 29 = Korumalı 30 = Kamera Modeli 31 = Boyutlar 32 = Kamera üreticisi 33 = Şirket 34 = Dosya Açıklaması 35 = Yönetici anahtar sözcükleri 36 = Yönetici anahtar sözcükleri 37 = 38 = 39 = 40 = 41 = 42 = Program adı 43 = Süre 44 = Çevrimiçi 45 = Yineleniyor 46 = Konum 47 = İsteğe bağlı katılımcı adresleri 48 = İsteğe bağlı katılımcılar 49 = Düzenleyenin adresi 50 = Düzenleyenin adı 51 = Anımsatıcı saati 52 = Gerekli katılımcı adresleri 53 = Gerekli katılımcılar 54 = Kaynaklar 55 = Toplantı durumu 56 = Serbest/meşgul durumu 57 = Toplam Boyut 58 = Hesap adı 59 = 60 = Görev durumu 61 = Bilgisayar 62 = Yıldönümü 63 = Yardımcının adı 64 = Yardımcının telefonu 65 = Doğum Günü 66 = İş adresi 67 = İş Şehir 68 = İş - Ülke/Bölge 69 = İş - Posta Kutusu 70 = İş Posta Kodu 71 = İş - İl veya İlçe 72 = İş Cadde 73 = İş Faksı 74 = İş Giriş Sayfası 75 = İş Telefonu 76 = Geri Arama Numarası 77 = Araç telefonu 78 = Çocuklar 79 = Şirket ana telefonu 80 = Departman 81 = E-posta adresi 82 = E-posta2 83 = E-posta3 84 = E-posta listesi 85 = Görüntülenen e-posta adı 86 = Dosyala 87 = İlk ad 88 = Tam ad 89 = Cinsiyeti 90 = Verilen ad 91 = Hobiler 92 = Ev adresi 93 = Ev - Şehir 94 = Ev - Ülke/Bölge 95 = Ev - Posta Kutusu 96 = Ev - Posta Kodu 97 = Ev - İl veya İlçe 98 = Sokak 99 = Ev faksı 100 = Ev telefonu 101 = IM adresleri 102 = Baş harfler 103 = İş unvanı 104 = Plak Şirketi 105 = Soyadı 106 = Posta adresi 107 = İkinci ad 108 = Cep telefonu 109 = Takma ad 110 = Ofis konumu 111 = Diğer adres 112 = Diğer şehir 113 = Diğer ülke/bölge 114 = Diğer posta kutusu 115 = Diğer posta kodu 116 = Diğer il veya ilçe 117 = Diğer sokak 118 = Çağrı Cihazı 119 = Kişisel unvan 120 = Şehir 121 = Ülke/bölge 122 = Posta kutusu 123 = Posta Kodu 124 = İl veya ilçe 125 = Cadde 126 = Birincil e-posta 127 = Birincil telefon 128 = Meslek 129 = Eş/Hayat Arkadaşı 130 = Sonek 131 = TTY/TTD telefonu 132 = Teleks 133 = Web Sayfası 134 = İçerik durumu 135 = İçerik Türü 136 = Edinildiği tarih 137 = Arşivlendiği tarih 138 = Tamamlanma tarihi 139 = Aygıt kategorisi 140 = Bağlı 141 = Bulma yöntemi 142 = Kolay ad 143 = Yerel bilgisayar 144 = Üretici 145 = Model 146 = Eşleştirilmiş 147 = Sınıflandırma 148 = Durum 149 = İşlem Durumu 150 = İstemci Kimliği 151 = Katkıda Bulunanlar 152 = İçerik oluşturma tarihi 153 = Son yazdırma tarihi 154 = Son kaydetme tarihi 155 = Bölüm 156 = Belge kimliği 157 = Sayfa 158 = Slaytlar 159 = Toplam düzenleme süresi 160 = Sözcük sayımı 161 = Son tarih 162 = Bitiş tarihi 163 = Dosya sayısı 164 = Dosya uzantısı 165 = Dosya adı 166 = Dosya sürümü 167 = Bayrak rengi 168 = Bayrak Durumu 169 = Boş alan 170 = 171 = 172 = Grup 173 = Paylaşım türü 174 = Bit Derinliği 175 = Yatay Çözünürlük 176 = Genişlik 177 = Dikey Çözünürlük 178 = Yükseklik 179 = Önem derecesi 180 = Ek? 181 = Silindi 182 = Şifreleme durumu 183 = Bayrağı var 184 = Tamamlandı? 185 = Eksik 186 = Okuma durumu 187 = Paylaşılan 188 = Oluşturanlar 189 = Tarih 190 = Klasör adı 191 = Klasör yolu 192 = Klasör 193 = Katılımcılar 194 = Yol 195 = Konuma göre 196 = Tür 197 = Kişi adları 198 = Giriş Türü 199 = Dil 200 = Ziyaret edildiği tarih 201 = Açıklama 202 = Bağlantı durumu 203 = Bağlantı hedefi 204 = URL 205 = 206 = 207 = 208 = Oluşturulan medya 209 = Piyasaya Çıkış Tarihi 210 = Kodlayan 211 = Bölüm numarası 212 = Üreticiler 213 = Yayımcı 214 = Sezon numarası 215 = Alt Konu Başlığı 216 = Kullanıcı web URL'si 217 = Yazıcılar 218 = 219 = Ekler 220 = Gizli adresleri 221 = Gizli 222 = Bilgi adresleri 223 = Bilgi 224 = Konuşma Kimliği 225 = Alınma tarihi 226 = Gönderildiği tarih 227 = Gönderen adresleri 228 = Kimden 229 = Ekleri var 230 = Gönderenin adresi 231 = Gönderenin adı 232 = Depolama Alanı 233 = Alıcı adresleri 234 = Yapılacak iş başlığı 235 = Kime 236 = Gelinen yer 237 = Albüm Sanatçısı 238 = Albüm sanatçısı sıralaması 239 = Albüm Kimliği 240 = Albüm sıralaması 241 = Katkıda bulunan sanatçılar sıralaması 242 = Vuruş/dakika 243 = Besteciler 244 = Besteci sıralaması 245 = Disk 246 = Başlangıç anahtarı 247 = Derleme bölümü 248 = Havası 249 = Küme parçası 250 = Dönem 251 = Renk 252 = Ebeveyn Derecelendirmesi 253 = Ebeveyn derecelendirme nedeni 254 = Kullanılan alan 255 = EXIF sürümü 256 = Etkinlik 257 = Pozlandırma dengeleme 258 = Pozlandırma Programı 259 = Poz Süresi 260 = F durağı 261 = Flaş Modu 262 = Odak uzunluğu 263 = 35mm odak uzunluğu 264 = ISO Hızı 265 = Mercek üreticisi 266 = Mercek modeli 267 = Işık Kaynağı 268 = En fazla açıklık 269 = Ölçüm Modu 270 = Yön 271 = Kişiler 272 = Program modu 273 = Doygunluk 274 = Nesne Uzaklığı 275 = Beyaz Dengesi 276 = Öncelik 277 = Proje 278 = Kanal numarası 279 = Bölüm Adı 280 = Kapalı Açıklamalı Alt Yazı 281 = Yeniden çalıştır 282 = SAP 283 = Yayım tarihi 284 = Program Açıklaması 285 = Kayıt süresi 286 = İstasyon arama işareti 287 = İstasyonun adı 288 = Özet 289 = Parçacıklar 290 = Otomatik özet 291 = İlgi 292 = Dosya sahipliği 293 = Duyarlık 294 = Kendisiyle Paylaşılan 295 = Paylaşım durumu 296 = 297 = Ürün adı 298 = Ürün Sürümü 299 = Destek bağlantısı 300 = Kaynak 301 = Başlangıç tarihi 302 = Paylaşılıyor 303 = Kullanılabilirlik durumu 304 = Durum 305 = Faturalama bilgisi 306 = Tamamlandı 307 = Görev sahibi 308 = Başlık sıralaması 309 = Toplam dosya büyüklüğü 310 = Yasal Ticari Markalar 311 = Video sıkıştırma 312 = Yönetmenler 313 = Veri Hızı 314 = Çerçeve yüksekliği 315 = Resim Karesi Hızı 316 = Çerçeve genişliği 317 = Küresel 318 = Stereo 319 = Video yönü 320 = Toplam bit hızı

Bir dizi hatadan sonra, aşağıdaki kod ile 5000 adet dosyalı klasörlerde deneyler yaptım.

Gereklilikler
⚠️🚨 Kod sadece, Windows işletim sisteminde çalışır. Bu kod, Windows 10 64 bit üzerinde, Office 2016'da denenmiştir. Eski sürüm Windows işletim sistemlerinde çalışmayabilir.
⚠️🚨 Kodu çalıştırmadan önce, Microsoft Visual Basic for Applications düzenleyicide Tools / References kutusunda, Microsoft Scripting Runtime ✔️ kütüphanesini etkinleştirmelisiniz.
✔️ Kod; HDD ve SSD harddisklerde, FAT32, exFat gibi taşınabilir belleklerde çalışmıştır. En iyi sonuç SSD disklerde sağlanmıştır. Bir exFat taşınabilir bellekte, 5000 adet dosya, 1 dakika 10 saniyede listelenmiştir.

Algoritma oldukça sade olup çalışma mantığı görseldeki gibidir.

Dim FSO As Scripting.FileSystemObject Dim ws3 As Worksheet 'ws3: worksheet 3: get_details_of Dim mf As String 'mf: selected main folder Dim ayrac As String 'Klasor ayrac isareti Dim bos As String 'Degeri olmayan hucre icin varsayilan ifade Dim lr As Long 'lr: last row: son satir Dim lc As Long 'lc: last column: son sutun Dim mss As Long 'mss: dongu icinde yazilmaya musait son satir Dim bast As Date 'bast: baslangic tarih degeri Dim bitt As Date 'bitt: bitis tarih degeri Dim rng As Range 'rng: range: hafizadaki hucre araligi Dim cll As Range 'cll: cell: hucre araligi gezmek icin 1 hucre birimi Dim objShell As Object 'Dosya ve klasor detayi almak icin sistem objesi Dim objFolder As Object 'Dosya ve klasor detayi almak icin klasor objesi Dim objFile As Variant 'Dosya ve klasor detayi almak icin dosya dizisi Sub Klasoru_ve_Altindakileri_Sec_3() Application.Calculation = xlCalculationManual 'Otomatik hesaplamayi devredisi birak Application.ScreenUpdating = False 'Dosya eklendikce ekrani güncellemeyi devredisi birak 'Yukaridaki komutlar kodun hizli calismasini saglar Set FSO = New Scripting.FileSystemObject Set ws3 = get_details_of 'Listeleme yapilacak sayfayi tanimla lr = ws3.Cells(Rows.Count, 1).End(xlUp).Row 'Son satir sayisini al lc = ws3.Cells(1, Columns.Count).End(xlToLeft).Column 'Son sutun sayisini al With Application.FileDialog(msoFileDialogFolderPicker) If .Show = -1 Then mf = .SelectedItems(1) 'Kok klasor secilirse, adresi degiskene ata Else Exit Sub 'Iptal tusuna basilirsa koddan cik End If End With bast = Now 'Islem baslangic tarihini al 'Sutun baslik bilgilerini yaz ws3.Cells(1, 1).Value2 = "Seçilen klasör" ws3.Cells(1, 2).Value2 = "Ad" ws3.Cells(1, 3).Value2 = "Boyut" ws3.Cells(1, 4).Value2 = "Öğe türü" ws3.Cells(1, 5).Value2 = "Değiştirme tarihi" ws3.Cells(1, 6).Value2 = "Oluşturma tarihi" ws3.Cells(1, 7).Value2 = "Erişim Tarihi" ws3.Cells(1, 8).Value2 = "Öznitelikler" ws3.Cells(1, 9).Value2 = "Çevrimdışı durumu" ws3.Cells(1, 10).Value2 = "Kullanılabilirlik" ws3.Cells(1, 11).Value2 = "Algılanan tür" ws3.Cells(1, 12).Value2 = "Sahibi" ws3.Cells(1, 13).Value2 = "Tip" ws3.Cells(1, 14).Value2 = "Çekildiği tarih" ws3.Cells(1, 15).Value2 = "Katkıda bulunan sanatçılar" ws3.Cells(1, 16).Value2 = "Albüm" ws3.Cells(1, 17).Value2 = "Yıl" ws3.Cells(1, 18).Value2 = "Tarz" ws3.Cells(1, 19).Value2 = "Orkestra Şefleri" ws3.Cells(1, 20).Value2 = "Etiketler" ws3.Cells(1, 21).Value2 = "Derecelendirme" ws3.Cells(1, 22).Value2 = "Yazarlar" ws3.Cells(1, 23).Value2 = "Başlık" ws3.Cells(1, 24).Value2 = "Konu" ws3.Cells(1, 25).Value2 = "Kategoriler" ws3.Cells(1, 26).Value2 = "Açıklamalar" ws3.Cells(1, 27).Value2 = "Telif Hakkı" ws3.Cells(1, 28).Value2 = "#" 'MP3 gibi dosyalarda parca sira numarasini gösterir ws3.Cells(1, 29).Value2 = "Uzunluk" ws3.Cells(1, 30).Value2 = "Bit hızı" ws3.Cells(1, 31).Value2 = "Korumalı" ws3.Cells(1, 32).Value2 = "Kamera Modeli" ws3.Cells(1, 33).Value2 = "Boyutlar" ws3.Cells(1, 34).Value2 = "Kamera üreticisi" ws3.Cells(1, 35).Value2 = "Şirket" ws3.Cells(1, 36).Value2 = "Dosya Açıklaması" ws3.Cells(1, 37).Value2 = "Yönetici anahtar sözcükleri 1" ws3.Cells(1, 38).Value2 = "Yönetici anahtar sözcükleri 2" ws3.Cells(1, 39).Value2 = "Dosya uzantısı" ws3.Range("A1").Resize(1, lc).Font.Bold = True 'Sutun baslik bilgilerini kalin yap ws3.Range("A2").Resize(lr, lc).Interior.Color = xlNone 'Onceden yapilan listelemede kullanilan alani sec ve hucre arkaplan rengini kaldir ws3.Range("A2").Resize(lr, lc).ClearContents ''Onceden yapilan listelemede kullanilan alani sec ve sadece verileri sil Sub_Folder_Files_3 FSO.GetFolder(mf).Path 'Recursive programming: Alt klasor ve dosyalarini almak icin kod cagirma 'Kok klasor adresini temel al ve donguye gir 'UYARI: Recursive programming islemi bittikten sonra, derleyici tekrar buraya doner ve asagidaki kodlari calistirir If lr > 1 Then Set rng = ws3.Range("A2").Resize(lr - 1, lc) 'A2, son satir ve sutun dahil, araligi hafizaya al For Each cll In rng If cll <> bos Then 'Her bir hucre varsayilan bosluk degerine esit degilse, yani deger, okunabilir bir veri ise cll.Interior.Color = RGB(230, 255, 230) 'Hucre arkaplan rengini boya End If Next cll Set rng = Nothing 'Hucre arkaplan boyama islemi bitince hafizadaki veriyi sil ws3.Range("A1").Resize(lr, lc).Font.Name = "Ebrima" 'Istege bagli font bicimlendirme, Ilgaz gibi kelimelerde büyük i ve kucuk l harflerinin fark edilebilmesi icin kullanilmistir Application.Calculation = xlCalculationAutomatic 'Islem bittigi icin otomatik hesaplamayi aktif et Application.ScreenUpdating = True 'Ekrani guncellemeyi aktif et ThisWorkbook.Save 'Dosyayi tedbiren kaydet ws3.Activate 'Listelemenin yapildigi get_details_of sayfasini goster bitt = Now 'Islem bitis tarihini al MsgBox "İşlem, " & Format(bitt - bast, "hh:mm:ss") & " sürede bitti.", vbInformation 'Islem bitis tarihinden, islem baslangic tarihini cikar ve saat:dakika:saniye formatiyla goster Else MsgBox "Hiçbir dosya listelenmedi. Klasör boş olabilir.", vbExclamation End If End Sub Sub Sub_Folder_Files_3(sfn As String) 'sfn: sub-folder name: alt klasor adi 'mf: main folder adli klasor adresini sfn degiskenine ata Dim act_fol As Scripting.Folder Dim sub_fol As Scripting.Folder Dim fls As Scripting.File Dim fct As String 'fct: fotografin cekildigi tarih Dim fct2 As String Dim j As Long Set ws3 = get_details_of Set act_fol = FSO.GetFolder(sfn) 'act_fol: active folder: islenmekte olan aktif klasor Set objShell = CreateObject("Shell.Application") 'GetDetailsOf islevi icin dosya klasor sistemi tanimlama ayrac = Application.PathSeparator lr = ws3.Cells(Rows.Count, 1).End(xlUp).Row lc = ws3.Cells(1, Columns.Count).End(xlToLeft).Column bos = "<Veri yok>" 'Ilgili dosya klasor detayi alinamazsa varsayilan bu degeri ata Set objFolder = objShell.Namespace(sfn & ayrac) 'FSO sisteminden alınan klasor adresini ve ayraci, Shell sistemine tanit For Each objFile In objFolder.Items 'Her bir dosya ve klasoru donguye al mss = lr + 1 ws3.Cells(mss, 1).Value2 = sfn & ayrac 'Secilen klasor ve alt klasor yolunu yaz ws3.Cells(mss, 2).Value2 = "'" & objFolder.GetDetailsOf(objFile, 0) 'Ad 'Dosya adi, 13.03.2022 gibi tarih veya 00002020 gibi tam sayi degerleri icerirse, Excel'in bunu donusturmemesi icin, tek tirnak eklenmistir If objFolder.GetDetailsOf(objFile, 1) <> "" Then ws3.Cells(mss, 3).Value2 = objFolder.GetDetailsOf(objFile, 1) 'Boyut Else ws3.Cells(mss, 3).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 2) <> "" Then ws3.Cells(mss, 4).Value2 = objFolder.GetDetailsOf(objFile, 2) 'Öğe türü Else ws3.Cells(mss, 4).Value2 = bos End If ws3.Cells(mss, 5).Value2 = Format(objFolder.GetDetailsOf(objFile, 3), "dd.mm.yyyy dddd-hh:mm") 'Değiştirme tarihi ws3.Cells(mss, 6).Value2 = Format(objFolder.GetDetailsOf(objFile, 4), "dd.mm.yyyy dddd-hh:mm") 'Oluşturma tarihi ws3.Cells(mss, 7).Value2 = Format(objFolder.GetDetailsOf(objFile, 5), "dd.mm.yyyy dddd-hh:mm") 'Erişim Tarihi 'Dosya ve klasorlerin yukaridaki degerleri muhakkak oldugu icin, kosul eklenmemistir If objFolder.GetDetailsOf(objFile, 6) <> "" Then ws3.Cells(mss, 8).Value2 = objFolder.GetDetailsOf(objFile, 6) 'Öznitelikler Else ws3.Cells(mss, 8).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 7) <> "" Then ws3.Cells(mss, 9).Value2 = objFolder.GetDetailsOf(objFile, 7) 'Çevrimdışı durumu Else ws3.Cells(mss, 9).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 8) <> "" Then ws3.Cells(mss, 10).Value2 = objFolder.GetDetailsOf(objFile, 8) 'Kullanılabilirlik Else ws3.Cells(mss, 10).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 9) <> "" Then ws3.Cells(mss, 11).Value2 = objFolder.GetDetailsOf(objFile, 9) 'Algılanan tür Else ws3.Cells(mss, 11).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 10) <> "" Then ws3.Cells(mss, 12).Value2 = objFolder.GetDetailsOf(objFile, 10) 'Sahibi Else ws3.Cells(mss, 12).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 11) <> "" Then ws3.Cells(mss, 13).Value2 = objFolder.GetDetailsOf(objFile, 11) 'Tip Else ws3.Cells(mss, 13).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 12) <> "" Then fct = objFolder.GetDetailsOf(objFile, 12) 'Gorunmeyen karakter geldigi icin temizleme kodu eklendi fct2 = "" For j = 1 To Len(fct) If IsNumeric(Mid(fct, j, 1)) = True Then fct2 = fct2 & Mid(fct, j, 1) 'Karakter sayi ise yeni degiskene ekle End If If Mid(fct, j, 1) = "." Then fct2 = fct2 & Mid(fct, j, 1) 'Karakter, gun ay yil ayraci olan nokta ise yeni degiskene ekle End If If Mid(fct, j, 1) = " " Then fct2 = fct2 & Mid(fct, j, 1) 'Karakter, cekildigi tarih ve saati ayiran bosluk ise yeni degiskene ekle End If If Mid(fct, j, 1) = ":" Then fct2 = fct2 & Mid(fct, j, 1) 'Karakter, saat ve dakikayi ayiran ust uste iki nokta ise yeni degiskene ekle End If Next j ws3.Cells(mss, 14).Value2 = Format(Split(fct2, " ")(0), "dd.mm.yyyy dddd") & "-" & Split(fct2, " ")(1) 'Çekildiği tarih 'Tarihi gun ismi verecek sekilde formatla ve tireden sonra saati ekle Else ws3.Cells(mss, 14).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 13) <> "" Then ws3.Cells(mss, 15).Value2 = objFolder.GetDetailsOf(objFile, 13) 'Katkıda bulunan sanatçılar Else ws3.Cells(mss, 15).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 14) <> "" Then ws3.Cells(mss, 16).Value2 = objFolder.GetDetailsOf(objFile, 14) 'Albüm Else ws3.Cells(mss, 16).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 15) <> "" Then ws3.Cells(mss, 17).Value2 = objFolder.GetDetailsOf(objFile, 15) 'Yıl Else ws3.Cells(mss, 17).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 16) <> "" Then ws3.Cells(mss, 18).Value2 = objFolder.GetDetailsOf(objFile, 16) 'Tarz Else ws3.Cells(mss, 18).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 17) <> "" Then ws3.Cells(mss, 19).Value2 = objFolder.GetDetailsOf(objFile, 17) 'Orkestra Şefleri Else ws3.Cells(mss, 19).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 18) <> "" Then ws3.Cells(mss, 20).Value2 = objFolder.GetDetailsOf(objFile, 18) 'Etiketler Else ws3.Cells(mss, 20).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 19) <> "" Then ws3.Cells(mss, 21).Value2 = objFolder.GetDetailsOf(objFile, 19) 'Derecelendirme Else ws3.Cells(mss, 21).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 20) <> "" Then ws3.Cells(mss, 22).Value2 = objFolder.GetDetailsOf(objFile, 20) 'Yazarlar Else ws3.Cells(mss, 22).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 21) <> "" Then ws3.Cells(mss, 23).Value2 = objFolder.GetDetailsOf(objFile, 21) 'Başlık Else ws3.Cells(mss, 23).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 22) <> "" Then ws3.Cells(mss, 24).Value2 = objFolder.GetDetailsOf(objFile, 22) 'Konu Else ws3.Cells(mss, 24).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 23) <> "" Then ws3.Cells(mss, 25).Value2 = objFolder.GetDetailsOf(objFile, 23) 'Kategoriler Else ws3.Cells(mss, 25).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 24) <> "" Then ws3.Cells(mss, 26).Value2 = objFolder.GetDetailsOf(objFile, 24) 'Açıklamalar Else ws3.Cells(mss, 26).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 25) <> "" Then ws3.Cells(mss, 27).Value2 = objFolder.GetDetailsOf(objFile, 25) 'Telif Hakkı Else ws3.Cells(mss, 27).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 26) <> "" Then ws3.Cells(mss, 28).Value2 = objFolder.GetDetailsOf(objFile, 26) '# Else ws3.Cells(mss, 28).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 27) <> "" Then ws3.Cells(mss, 29).Value2 = objFolder.GetDetailsOf(objFile, 27) 'Uzunluk Else ws3.Cells(mss, 29).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 28) <> "" Then ws3.Cells(mss, 30).Value2 = objFolder.GetDetailsOf(objFile, 28) 'Bit hızı Else ws3.Cells(mss, 30).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 29) <> "" Then ws3.Cells(mss, 31).Value2 = objFolder.GetDetailsOf(objFile, 29) 'Korumalı Else ws3.Cells(mss, 31).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 30) <> "" Then ws3.Cells(mss, 32).Value2 = objFolder.GetDetailsOf(objFile, 30) 'Kamera Modeli Else ws3.Cells(mss, 32).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 31) <> "" Then ws3.Cells(mss, 33).Value2 = objFolder.GetDetailsOf(objFile, 31) 'Boyutlar Else ws3.Cells(mss, 33).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 32) <> "" Then ws3.Cells(mss, 34).Value2 = objFolder.GetDetailsOf(objFile, 32) 'Kamera üreticisi Else ws3.Cells(mss, 34).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 33) <> "" Then ws3.Cells(mss, 35).Value2 = objFolder.GetDetailsOf(objFile, 33) 'Şirket Else ws3.Cells(mss, 35).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 34) <> "" Then ws3.Cells(mss, 36).Value2 = objFolder.GetDetailsOf(objFile, 34) 'Dosya Açıklaması Else ws3.Cells(mss, 36).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 35) <> "" Then ws3.Cells(mss, 37).Value2 = objFolder.GetDetailsOf(objFile, 35) 'Yönetici anahtar sözcükleri 1, bu deger test asamasindadir, dolu bir degere sahip dosyaya henuz rastlanmamistir Else ws3.Cells(mss, 37).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 36) <> "" Then ws3.Cells(mss, 38).Value2 = objFolder.GetDetailsOf(objFile, 36) 'Yönetici anahtar sözcükleri 2, bu deger test asamasindadir, dolu bir degere sahip dosyaya henuz rastlanmamistir Else ws3.Cells(mss, 38).Value2 = bos End If If objFolder.GetDetailsOf(objFile, 164) <> "" Then ws3.Cells(mss, 39).Value2 = objFolder.GetDetailsOf(objFile, 164) 'Dosya uzantısı Else ws3.Cells(mss, 39).Value2 = bos End If lr = lr + 1 Next objFile For Each sub_fol In act_fol.SubFolders 'Aktif klasorde alt klasor varsa, donguye gir Sub_Folder_Files_3 sub_fol.Path 'Alt klasor adresini al ve kodu bir daha calistir Next sub_fol 'Alt klasor ve dosyalari listeleme isi bitince esas koda geri don 'Kaynak: https://youtu.be/hT2ufvY9b6w?t=1445 'Kaynak: https://alittletrick.com/get-file-names-from-a-folder-by-a-macro/ End Sub
Faydalı olmasını dilerim.

Sayısal Fiyatı Kelimelere Çevirmek

Merhaba.

Sayısal olarak verilen fiyatları kelimelere çevirmek için kodun bazı yerlerinde düzenleme yapılmıştır. Çünkü, orijinal kod çalışınca, "1000", "100" gibi sayılar, "Bir Bin", "Bir Yüz" olarak dönüşüyordu.

Kodu VBA düzenleyiciye yapıştırdıktan sonra, dosyayı, XSLM veya XLSB olarak kaydederseniz kod korunur.

Boş bir hücreye =Fiyati_Metne_Cevir(A1) işlevi yazarak fonksiyonu kullanabilirsiniz.

Option Explicit Function Fiyati_Metne_Cevir(ByVal MyNumber) Dim Dollars, Cents, Temp As String Dim DecimalPlace, Count ReDim Place(9) As String Place(2) = " Bin " Place(3) = " Milyon " Place(4) = " Milyar " Place(5) = " Trilyon " ' String representation of amount MyNumber = Trim(Str(MyNumber)) ' Position of decimal place 0 if none DecimalPlace = InStr(MyNumber, ".") 'Convert cents and set MyNumber to dollar amount If DecimalPlace > 0 Then Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2)) MyNumber = Trim(Left(MyNumber, DecimalPlace - 1)) End If Count = 1 Do While MyNumber <> "" Temp = GetHundreds(Right(MyNumber, 3)) If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars If Len(MyNumber) > 3 Then MyNumber = Left(MyNumber, Len(MyNumber) - 3) Else MyNumber = "" End If Count = Count + 1 Loop Select Case Dollars Case "" Dollars = "Sıfır TL" Case "" Dollars = "Bir TL" Case Else Dollars = Dollars & " TL" End Select Select Case Cents Case "" Cents = "" Case "Bir" Cents = " ve Bir Kuruş" Case Else Cents = " ve " & Cents & " Kuruş" End Select If Dollars Like "Bir Bin*" Then Dollars = Replace(Dollars, "Bir Bin", "Bin") End If Dollars = Replace(Dollars, " ", " ") Fiyati_Metne_Cevir = Trim(Dollars & Cents) End Function ' Converts a number from 100-999 into text Private Function GetHundreds(ByVal MyNumber) Dim Result As String If Val(MyNumber) = 0 Then Exit Function MyNumber = Right("000" & MyNumber, 3) 'Convert the hundreds place If Mid(MyNumber, 1, 1) = "1" Then Result = "Yüz " End If If Mid(MyNumber, 1, 1) = "2" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & " Yüz " End If If Mid(MyNumber, 1, 1) = "3" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & " Yüz " End If If Mid(MyNumber, 1, 1) = "4" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & " Yüz " End If If Mid(MyNumber, 1, 1) = "5" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & " Yüz " End If If Mid(MyNumber, 1, 1) = "6" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & " Yüz " End If If Mid(MyNumber, 1, 1) = "7" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & " Yüz " End If If Mid(MyNumber, 1, 1) = "8" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & " Yüz " End If If Mid(MyNumber, 1, 1) = "9" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & " Yüz " End If 'Convert the tens and ones place If Mid(MyNumber, 2, 1) <> "0" Then Result = Result & GetTens(Mid(MyNumber, 2)) Else Result = Result & GetDigit(Mid(MyNumber, 3)) End If GetHundreds = Result End Function ' Converts a number from 10 to 99 into text. * Private Function GetTens(TensText) Dim Result As String Result = "" 'null out the temporary function value If Val(Left(TensText, 1)) = 1 Then ' If value between 10-19 Select Case Val(TensText) Case 10: Result = "On" Case 11: Result = "On Bir" Case 12: Result = "On İki" Case 13: Result = "On Üç" Case 14: Result = "On Dört" Case 15: Result = "On Beş" Case 16: Result = "On Altı" Case 17: Result = "On Yedi" Case 18: Result = "On Sekiz" Case 19: Result = "On Dokuz" Case Else End Select Else ' If value between 20-99 Select Case Val(Left(TensText, 1)) Case 2: Result = "Yirmi " Case 3: Result = "Otuz " Case 4: Result = "Kırk " Case 5: Result = "Elli " Case 6: Result = "Altmış " Case 7: Result = "Yetmiş " Case 8: Result = "Seksen " Case 9: Result = "Doksan " Case Else End Select Result = Result & GetDigit _ (Right(TensText, 1)) 'Retrieve ones place End If GetTens = Result End Function ' Converts a number from 1 to 9 into text. Private Function GetDigit(Digit) Select Case Val(Digit) Case 1: GetDigit = "Bir" Case 2: GetDigit = "İki" Case 3: GetDigit = "Üç" Case 4: GetDigit = "Dört" Case 5: GetDigit = "Beş" Case 6: GetDigit = "Altı" Case 7: GetDigit = "Yedi" Case 8: GetDigit = "Sekiz" Case 9: GetDigit = "Dokuz" Case Else: GetDigit = "" End Select End Function 'Kaynak: https://www.excelforum.com/tips-and-tutorials/1015010-convert-a-numeric-value-to-words-without-vba.html 'Doğrudan link: https://www.excelforum.com/attachments/tips-and-tutorials/654676d1576780633-convert-a-numeric-value-to-words-without-vba-number_to_text.xlsm

Kaynak: https://www.excelforum.com/tips-and-tutorials/1015010-convert-a-numeric-value-to-words-without-vba.html
Doğrudan link: https://www.excelforum.com/attachments/tips-and-tutorials/654676d1576780633-convert-a-numeric-value-to-words-without-vba-number_to_text.xlsm