Numara Sırasına göre Almak

[Mikdad]

selamun Aleykum Dostlarım,
Sitede Haluk Beyin Yazmış Olduğu Sunumları Birleştirme Kodu Var.

Sub Test()
    'Haluk 29/05/2018
    Dim strPath As String
    Dim strExt As String
    Dim myFile As String
    
    strPath = "D:\TestFolder\"
    strExt = "*.PPT*"
    myFile = Dir$(strPath & strExt)
    
    While myFile <> ""
    strFile = strPath & myFile
        ActivePresentation.Slides.InsertFromFile strFile, ActivePresentation.Slides.Count, 1
        myFile = Dir()
    Wend
    
    MsgBox "İşlem tamam..."
End Sub

Bu kod numara sıralamasına göre almıyor
1,ppt
11.ppt
111.ppt
2.ppt
20.ppt
22.ppt şeklinde alıyor
olması gereken ise
1.ppt
2.ppt
3.ppt
şeklinde olmalı bu kodda nasıl bir değişiklik yapmalıyız. yardımcı olursanız çok sevinirim.

 

[Muzaffer Ali]

Merhaba.

Dosya isimleri metindir ona göre düşünerek isimlendirmelisiniz.

Örnek:
1.ppt yerine 001.ppt, 002.ppt, 003.ppt ...... şeklinde yazarsanız rakamları doğru sıralamış olursunuz.

 

[Haluk]

Koddaki 100 değerini kendinize göre değiştirin. Dosya uzantıları "ppt" ise, koddaki "pptx" kısmını da düzeltin.

Sub Test()
    'Haluk 07/01/2019
    'sa4truss@gmail.com
    Dim i As Integer, myFile As String
  
    For i = 1 To 100
        myFile = "D:\TestFolder\" & i & ".pptx"
        ActivePresentation.Slides.InsertFromFile myFile, ActivePresentation.Slides.Count, 1
    Next
  
    MsgBox "İşlem tamam..."
End Sub

.

 

[Mikdad]

1 to 100 yazan kısım maksimum slayt sayısı mı hocam
birde hocam şu şekilde hata verdi. sanırım örneğin 5.pptx yoksa hata veriyor. yani sayıların tümünün olması gerekiyor . ama bazen tüm sayılar sıra ile gitmiyor. yani 1,2,3,4,6,8,9,15 şeklinde de gidebiliyorlar hocam.

https://i.imgyukle.com/2020/01/07/VXPg0f.png

 

[Haluk]

100 ifadesi sizin en son dosyanızın adı, yani ..... 100.pptx

Klasörde olmayan dosyalarda hatayı engellemek için revize kod;

Sub Test2()
    'Haluk 07/01/2019
    'sa4truss@gmail.com
    Dim i As Integer, myFile As String
 
    For i = 1 To 100
        myFile = "D:\TestFolder\" & i & ".pptx"
        If Dir(myFile) <> Empty Then
            ActivePresentation.Slides.InsertFromFile myFile, ActivePresentation.Slides.Count, 1
        End If
    Next
 
    MsgBox "İşlem tamam..."
End Sub

 

[Mikdad]

Hocam son olarak aldığı dosyaları kontrol edebilmek adına:aldığı dosyaların isimlerini bir txt dosyasına atması mümkün mü? Yani işlem tamam dedikten sonra module nin altına siraladigi isimleri hır text dosyasına atarsa süper olur. Hakkınızı helal edin hocam

 

[Haluk]

........ Hakkınızı helal edin hocam

Helâl olsun,

Sub Test3()
    'Haluk 07/01/2019
    'sa4truss@gmail.com
    Dim i As Integer, j As Integer, myFile As String
    Dim LogFile As String, FileNum As Long, myMsg As Variant
    
    LogFile = ActivePresentation.Path & "\Log.txt"
    FileNum = FreeFile
    
    Open LogFile For Output As FileNum
        Print #FileNum, "Alınan dosyalar:" & vbCrLf
        For i = 1 To 100
            myFile = "D:\TestFolder\" & i & ".pptx"
            If Dir(myFile) <> Empty Then
                j = j + 1
                Print #FileNum, j & ") " & Dir(myFile)
                ActivePresentation.Slides.InsertFromFile myFile, ActivePresentation.Slides.Count, 1
            End If
        Next
    Close #FileNum
    
    myMsg = MsgBox("İşlem tamam... Log dosyasını görüntülemek istiyor musunuz?", vbYesNo)
    
    If myMsg = vbYes Then
        Shell "notepad.exe " & LogFile, vbNormalFocus
    End If
End Sub

.

 

[Mikdad]

Rabbim Gani Gani Razı Olsun Hocam. Harikasınız.
Son Olarak Her bu işlemi yapmak için ALT+F11 e basıp ordan çalıştır demek yerine ilk sayfaya bir button koydum .ama o buttona modul bağlantısını veremedim. onu yapma imkanı var mı?

 

[Haluk]

Buton eğer ActiveX elemanıysa; dizayn modundayken butonu seçin, çift tıklayın, modül sayfasında otomatik olarak aşağıdaki yer alacaktır....

Private Sub CommandButton1_Click()

End Sub

Aradaki satıra, aşağıdaki "kırmızı" ilaveyi yapın.....

Private Sub CommandButton1_Click()
    Call Test3
End Sub

.

 

[Mikdad]

Hocam ActiveX elemanı olarak button ekledim. kodu yapıştırdım daha sonra tasarım modundan çıktım. ama buttona tıklayınca bir şey olmuyor
Private Sub CommandButton1_Click()
Call Test3
End Sub

 

[Haluk]

Tamam, o işi boş verin..... siz PowerPoint araç çubuğuna Excel'deki gibi "Developer-Geliştirici" sekmesini ilave edin, oradan Makroyu çalıştırabilirsiniz.

.

 

[Mikdad]

tamamdır Hocam Herşey İçin Allah Razı Olsun . Tekrar Hakkınızı Helal Edin

 

[Mikdad]

Selamun Aleykum Hocam, herşey çok güzel çalışıyor. iki sorum çıktı onun ile ilgili bilgi talep edecektim sizden.
1) Slayt Dosyasının ismini değiştirdiğimde makro çalışmıyor. ismi değişsede çalışmasını nasıl sağlarız. (araç çubuğu ekle dedim yeni bir araç çubuğuna makroları getir dedim. eklediğimiz makroyu seçtim icon verdim. bu şekilde powerpointte üst tarafta sekme oldu. ama sunum dosyasının ismini değiştirince çalışmıyor.)
2) PowerPointte biliyorsunuz Bölüm ekleme özelliği var. bizim slaytlar 1.pptx 2.pptx .......550.pptx şeklinde gidiyor ya . her sunum dosyasını içe aktarırken yeni bölüm olarak eklesin ve bölüm ün ismi olarak ta slayt ismini versin. yani 5.pptx i aktarırken 5 diye bölüm acacak ve içine aktarıcak. 6.pptx için 6 diye bölüm oluşturacak ve aktaracak.
Allah Razı Olsun

 

[Haluk]

Section (Bölüm) oluşturulmasıyla ilgili olarak aşağıdakini deneyin, işinize yarar mı bilmiyorum...

Sub Test4()
    'Haluk 17/01/2020
    'sa4truss@gmail.com
    Dim i As Integer, j As Integer, myFile As String
    Dim LogFile As String, FileNum As Long, myMsg As Variant
    Dim mySlide As Slide
    
    LogFile = ActivePresentation.Path & "\Log.txt"
    FileNum = FreeFile
    
    Open LogFile For Output As FileNum
        Print #FileNum, "Alınan dosyalar:" & vbCrLf
        For i = 1 To 100
            myFile = "D:\TestFolder\" & i & ".pptx"
            If Dir(myFile) <> Empty Then
                j = j + 1
                ActivePresentation.SectionProperties.AddSection j, Dir(myFile)
                Print #FileNum, j & ") " & Dir(myFile)
                ActivePresentation.Slides.InsertFromFile myFile, ActivePresentation.Slides.Count, 1
                ActivePresentation.Slides(ActivePresentation.Slides.Count).MoveToSectionStart (j)
            End If
        Next
    Close #FileNum
    
    myMsg = MsgBox("İşlem tamam... Log dosyasını görüntülemek istiyor musunuz?", vbYesNo)
    
    If myMsg = vbYes Then
        Shell "notepad.exe " & LogFile, vbNormalFocus
    End If
End Sub

.

 

[Mikdad]

Hocam kod çalıştı ama sunum dosyasının 1. slaytını ikinci sılayt olarak aktarıyor. eğer bu ilk sayfanın ikinci sayfa olarak aktarılmasını düzeltirsek tamam olur.

 

[Haluk]

Onu da elle düzeltiverin, olsun ... bitsin

.

 

[Mikdad]

hocam yaklaşık 1300 sunum dosyasında elle düzeltmek çok zaman alıyor
ve sürekli bu sayı artıyor. hele her sunumda yaklaşık 12 sayfa olunca elle düzeltmek büyük işkence

birde dosya numarasını da yanlış atıyor hocam.

 

[Haluk]

Bana göre aşağıdaki kod oldu gibi....

Siz deneyince haber verirsiniz....

Sub Test6()
    'Haluk 17/01/2020
    'sa4truss@gmail.com
    Dim i As Integer, j As Integer, k As Integer, myFile As String
    Dim LogFile As String, FileNum As Long, myMsg As Variant
    Dim intCount As Integer, intCount2 As Integer
    
    LogFile = ActivePresentation.Path & "\Log.txt"
    FileNum = FreeFile
    
    Open LogFile For Output As FileNum
        Print #FileNum, "Alınan dosyalar:" & vbCrLf
        For i = 1 To 100
            myFile = "D:\TestFolder\" & i & ".pptx"
            If Dir(myFile) <> Empty Then
                j = j + 1
                Print #FileNum, j & ") " & Dir(myFile)
                ActivePresentation.SectionProperties.AddSection j, Dir(myFile)
                intCount = ActivePresentation.Slides.Count
                ActivePresentation.Slides.InsertFromFile myFile, intCount
                intCount2 = ActivePresentation.Slides.Count
                If j > 1 Then
                    For k = intCount2 To intCount + 1 Step -1
                        ActivePresentation.Slides(k).MoveToSectionStart (j)
                    Next
                End If
            End If
        Next
    Close #FileNum
    
    myMsg = MsgBox("İşlem tamam... Log dosyasını görüntülemek istiyor musunuz?", vbYesNo)
    
    If myMsg = vbYes Then
        Shell "notepad.exe " & LogFile, vbNormalFocus
    End If
End Sub

.

 

[Mikdad]

Hocam Siz Bir Harikasınız. Allah Gani Gani Razı Olsun. Süper Oldu.

Bana göre aşağıdaki kod oldu gibi....

Siz deneyince haber verirsiniz....

Sub Test6()
    'Haluk 17/01/2020
    'sa4truss@gmail.com
    Dim i As Integer, j As Integer, k As Integer, myFile As String
    Dim LogFile As String, FileNum As Long, myMsg As Variant
    Dim intCount As Integer, intCount2 As Integer
   
    LogFile = ActivePresentation.Path & "\Log.txt"
    FileNum = FreeFile
   
    Open LogFile For Output As FileNum
        Print #FileNum, "Alınan dosyalar:" & vbCrLf
        For i = 1 To 100
            myFile = "D:\TestFolder\" & i & ".pptx"
            If Dir(myFile) <> Empty Then
                j = j + 1
                Print #FileNum, j & ") " & Dir(myFile)
                ActivePresentation.SectionProperties.AddSection j, Dir(myFile)
                intCount = ActivePresentation.Slides.Count
                ActivePresentation.Slides.InsertFromFile myFile, intCount
                intCount2 = ActivePresentation.Slides.Count
                If j > 1 Then
                    For k = intCount2 To intCount + 1 Step -1
                        ActivePresentation.Slides(k).MoveToSectionStart (j)
                    Next
                End If
            End If
        Next
    Close #FileNum
   
    myMsg = MsgBox("İşlem tamam... Log dosyasını görüntülemek istiyor musunuz?", vbYesNo)
   
    If myMsg = vbYes Then
        Shell "notepad.exe " & LogFile, vbNormalFocus
    End If
End Sub

.

 

[Haluk]

hocam yaklaşık 1300 sunum dosyasında elle düzeltmek çok zaman alıyor
ve sürekli bu sayı artıyor. hele her sunumda yaklaşık 12 sayfa olunca elle düzeltmek büyük işkence

Dosyaları birleştireceğiniz ana PowerPoint dosyası anladığım kadarıyla 1 kereye mahsus değil, ara sıra bu işi yapıyorsunuz....

O zaman, en mantıklısı makro içeren bir PowerPoint şablonu kullanarak, kodlar çalıştıktan sonra oluşan dosyayı makrosuz PPTX olarak kaydetmek olacaktır.

Bu iş için yukarıdaki makroyu biraz revize ettikten sonra, kodları yerleştireceğiniz PowerPoint dosyasını *.potm uzantısıyla kaydetmek olacaktır. (Bu mesaj ekinde söz konusu şablon dosya verilmiştir). Şablon dosyasının ismini değiştirebilirsiniz.

Bundan sonra ihtiyaç duyduğunuzda bu şablon dosyasını çalıştırın, kodların çalışması bittiğinde bütün sunumlar Section'lar (Bölümler) halinde masaüstündeki BirlestirilmisDosya.pptx dosyasına kaydedilecektir.

Sözkonusu kodlar ekli *.potm dosyasına yerleştirilmiştir...

.