Numara Sırasına göre Almak

Mikdad · 20 Ocak 2020

Evet hocam haklısınız, haftalık olarak 2 defa bu işlemi yapıyorum. yani benim için çok önemli.
Hocam dosyayı İndiremiyorum. Sanırım Altın Üyeliğim Bitmiş

Mikdad · 20 Ocak 2020

altın üyelik için ödeme yaptım aktif edilmesini bekliyorum.

Mikdad · 20 Ocak 2020

Hocam Allah razı olsun anca bu kadar güzel olabilirdi. Emeğinize sağlık

Mikdad · 19 Şubat 2020

Selamun Aleykum dostlarım, bu aşağıdaki kod ile sunum dosyalarını her sunumu bir BÖLÜM şeklinde birleştirebiliyor. Haluk Hocam Allah razı olsun çok yardımcı olmuştu. şimde sıkıntım şu .
sunum dosyasının ismi 5.pptx bunu birliştir dediği zaman 5.pptx adında bir bölüm oluşturup içine sunumun tüm sayfalarını atıyor. benim yapmak istediğim şey ise şu . eğer bölüm ismi 5.pptx ise bölümündeki her dosyanın altına veya uygun bir yerine 5.Dosya diye yazmasını istiyorum. üç beş sunum dosyası olsa hiç problem oluşturmaz ama haftalık olarak en az 1500 sunumu bu şekilde birleştirip numaralandırmak zorunda kalıyorum. bu büyük bir iş yükü oluşturuyor.
örnek dosya da sunuyorum.

İndir Birlestirilmis Dosya111

Dosyayı indir Birlestirilmis Dosya111

dosya.co

Kod:

Sub SunumBirlestir()
 
    Dim i As Integer, j As Integer, myFile As String
    Dim LogFile As String, FileNum As Long, myMsg As Variant
    Dim intCount As Integer, intCount2 As Integer
   
    ActivePresentation.SaveAs "E:\SlaytBirlestir\BirlestirilmisDosya.pptx", ppSaveAsOpenXMLPresentation, msoTrue
   
    LogFile = ActivePresentation.Path & "\Log.txt"
    FileNum = FreeFile
   
    Open LogFile For Output As FileNum
        Print #FileNum, "Alınan dosyalar:" & vbCrLf
        For i = 1 To 1500
            myFile = "E:\Slaytları Buraya Kopyalayın\TOPLU\" & 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
   
    ActivePresentation.Save
   
    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 · 19 Şubat 2020

Mikdad' Alıntı:
.............
.......
... eğer bölüm ismi 5.pptx ise bölümündeki her dosyanın altına veya uygun bir yerine 5.Dosya diye yazmasını istiyorum. üç beş sunum dosyası olsa hiç problem oluşturmaz ama haftalık olarak en az 1500 sunumu bu şekilde birleştirip numaralandırmak zorunda kalıyorum. bu büyük bir iş yükü oluşturuyor.

Yani; bu 1500 tane dosyayı tek tek açıp, 1. slaytın herhangibir tarafına "...#. Dosya" metni yazılıp, kapatılacak. Öyle mi ?

.

Mikdad · 19 Şubat 2020

yani mevcut kod üzerinden düşünecek olursak, zaten bu 1500 dosyayı açıp ana slaytta bir bölüm açıp içine kayıt ediyor. sizin daha önce yazdığınız kod ile. bu işlemi yaparken bölüme verdiği ismi sayfaların altına yazabilir mi?bir mühür veya sayfa numarası gibi

Haluk · 19 Şubat 2020

Kod:

Sub Test8()
    'Haluk 19/02/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 intCount As Integer, intCount2 As Integer
    Dim shp As Shape
    
    ActivePresentation.SaveAs "C:\Users\" & Environ("Username") & "\Desktop\BirlestirilmisDosya.pptx", ppSaveAsOpenXMLPresentation, msoTrue
    
    LogFile = ActivePresentation.Path & "\Log.txt"
    FileNum = FreeFile
    
    Open LogFile For Output As FileNum
        Print #FileNum, "Alınan dosyalar:" & vbCrLf
        For i = 1 To 1500
            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
                Set shp = ActivePresentation.Slides(intCount + 1).Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
                          Left:=400, Top:=100, Width:=180, Height:=20)
                shp.TextFrame.TextRange.Text = Dir(myFile)
                shp.TextFrame.TextRange.Font.Size = 13
                shp.TextFrame.TextRange.Font.Bold = msoTrue
                shp.TextFrame.TextRange.Font.Color = RGB(0, 0, 255)
                shp.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
                shp.Line.DashStyle = msoLineSolid
                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
    
    ActivePresentation.Save
    
    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 · 20 Şubat 2020

Haluk' Alıntı:

Kod:

Sub Test8()
    'Haluk 19/02/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 intCount As Integer, intCount2 As Integer
    Dim shp As Shape
   
    ActivePresentation.SaveAs "C:\Users\" & Environ("Username") & "\Desktop\BirlestirilmisDosya.pptx", ppSaveAsOpenXMLPresentation, msoTrue
   
    LogFile = ActivePresentation.Path & "\Log.txt"
    FileNum = FreeFile
   
    Open LogFile For Output As FileNum
        Print #FileNum, "Alınan dosyalar:" & vbCrLf
        For i = 1 To 1500
            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
                Set shp = ActivePresentation.Slides(intCount + 1).Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
                          Left:=400, Top:=100, Width:=180, Height:=20)
                shp.TextFrame.TextRange.Text = Dir(myFile)
                shp.TextFrame.TextRange.Font.Size = 13
                shp.TextFrame.TextRange.Font.Bold = msoTrue
                shp.TextFrame.TextRange.Font.Color = RGB(0, 0, 255)
                shp.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
                shp.Line.DashStyle = msoLineSolid
                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
   
    ActivePresentation.Save
   
    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

.

Değerli Hocam Siz Bir Harikasınız. Allah Razı olsun Sadece her bölümün ilk sayfasında çıkıyor ama olsun daha fazla kasmaya gerek yok sanırım. bu kadarı da mükemmel olmuş. Ellerinize Sağlık

Haluk · 20 Şubat 2020

Eğer bölümlerdeki her slayt üzerinde bölüm adının yer almasını istiyorsanız;

Kod:

Sub Test9()
    'Haluk 20/02/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 intCount As Integer, intCount2 As Integer
    Dim shp As Shape, x As Integer, y As Integer
    
    ActivePresentation.SaveAs "C:\Users\" & Environ("Username") & "\Desktop\BirlestirilmisDosya.pptx", ppSaveAsOpenXMLPresentation, msoTrue
    
    LogFile = ActivePresentation.Path & "\Log.txt"
    FileNum = FreeFile
    
    Open LogFile For Output As FileNum
        Print #FileNum, "Alınan dosyalar:" & vbCrLf
        For i = 1 To 1500
            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
    
    With ActivePresentation.SectionProperties
        For x = 1 To .Count
            For j = 1 To ActivePresentation.SectionProperties.SlidesCount(x)
                y = y + 1
                Set shp = ActivePresentation.Slides(y).Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
                          Left:=400, Top:=100, Width:=180, Height:=20)
                shp.TextFrame.TextRange.Text = .Name(x)
                shp.TextFrame.TextRange.Font.Size = 13
                shp.TextFrame.TextRange.Font.Bold = msoTrue
                shp.TextFrame.TextRange.Font.Color = RGB(0, 0, 255)
                shp.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
                shp.Line.DashStyle = msoLineSolid
            Next
        Next
    End With
    
    ActivePresentation.Save
    
    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 · 24 Şubat 2020

Haluk Hocam Allah Razı Olsun. Şuan tüm Sayfalara isim yazdırılıyor. son olarak bu isimlerin yazılı olduğu çerçevenin içi saydam . haliyle altındaki resim ile karışıyor. bu ismin yazıldığı çerçevenin alt zemininin beyaz olmasını sağlamamız mümkün mü?

Haluk · 24 Şubat 2020

Beyaz için;

Kod:

                shp.Fill.ForeColor.RGB = RGB(255, 255, 255) ' Beyaz

Kırmızı için;

Kod:

                shp.Fill.ForeColor.RGB = RGB(255, 0, 0) ' Kirmizi

Kodu nereye yapıştıracağınızı biliyorsunuz, herhalde ....

.

Mikdad · 24 Şubat 2020

Hocam Allah Razı Olsun. Yüreğinize Elinize Sağlık. Mükemmel Oldu. İyi Varsınız. Hakkınızı Helal Eden Lütfen Çok Emeğiniz Geçti

Mikdad · 4 Mart 2020

Haluk Hocam, Bu Kod ile tam olarak istediğimiz her şeyi yaptık. çok işime yarıyor Allah razı Olsun. sadece şunu sormak istiyorum.
sunum dosyalarını numara sırasına göre alıyor sıkıntısız bir şekilde. benim tek eksiğim 56-1.pptx şeklinde bazı dosyalar oluyor bunu bunu da almasını istiyorum. ama tire işareti kullandığım için kabul etmiyor.
56-1.pptx dosyasını referans olarak alacak olursak,
1.pptx slaytından başlayıp
56-1.pptx sayısına kadar numara sırasına göre almaya devam edecek, sıraya 56-1.pptx geldiğinde de onu atlamayacak ve onu da kayıt edecek şekilde bir revize edebilir miyiz. ?

Haluk' Alıntı:

Kod:

Sub SunumBirlestir()
  
  Dim i As Integer, j As Integer, myFile As String
    Dim LogFile As String, FileNum As Long, myMsg As Variant
    Dim intCount As Integer, intCount2 As Integer
    Dim shp As Shape, x As Integer, y As Integer
    
   ActivePresentation.SaveAs "E:\SlaytBirlestir\BirlestirilmisDosya.pptx", ppSaveAsOpenXMLPresentation, msoTrue
    
    LogFile = ActivePresentation.Path & "\Log.txt"
    FileNum = FreeFile
    
    Open LogFile For Output As FileNum
        Print #FileNum, "Alınan dosyalar:" & vbCrLf
        For i = 1 To 1500
            myFile = "E:\Slaytları Buraya Kopyalayın\TOPLU\" & 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
    
    With ActivePresentation.SectionProperties
        For x = 1 To .Count
            For j = 1 To ActivePresentation.SectionProperties.SlidesCount(x)
                y = y + 1
                Set shp = ActivePresentation.Slides(y).Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
                          Left:=2, Top:=32, Width:=100, Height:=20)
                shp.TextFrame.TextRange.Text = .Name(x)
                shp.TextFrame.TextRange.Font.Size = 15
                shp.TextFrame.TextRange.Font.Bold = msoTrue
                shp.Fill.ForeColor.RGB = RGB(255, 235, 205) ' Beyaz
                shp.TextFrame.TextRange.Font.Color = RGB(178, 34, 34)
                shp.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
                shp.Line.DashStyle = msoLineSolid
            Next
        Next
    End With
    
    ActivePresentation.Save
    
    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

Kodu nereye yapıştıracağınızı biliyorsunuz, herhalde ....

.

Haluk · 4 Mart 2020

Konu hakkında hazırladığım daha önceki çalışmaları da göz önüne aldığımda, şimdiki sorunuzu ufak bir ücret karşılığında çözebileceğimi bildiririm...

Detay için özel mesajla irtibat kurabilirsiniz.

.

Numara Sırasına göre Almak

Mikdad

Mikdad

Mikdad

Mikdad

İndir Birlestirilmis Dosya111

Haluk

Özel Üye

Mikdad

Haluk

Özel Üye

Mikdad

Haluk

Özel Üye

Mikdad

Haluk

Özel Üye

Mikdad

Mikdad

Haluk

Özel Üye