PowerPoint VBA: "No currently active document window" upon closing the file - vba

Question

The script takes photos from the indicated folder and places them on slides according to the limit imposed by the user, e.g. 1000 photos / presentation. After that it has to create a new presentation.
It was working. But he stopped. Now I stop with a PowerPoint VBA error: "No currently active document window" at the moment when the script is to close the PowerPoint file and open a new one in which to continue saving the presentation.
Saving and closing a newly created presentation
Application.DisplayAlerts = ppAlertsNone
ActivePresentation.Save
ActiveWindow.Close <----- error here
Application.DisplayAlerts = ppAlertsAll
How to eliminate this error for the script to continue running?
All Code:
Option Explicit
Option Base 1
Option Private Module
Private il_plik As Integer
Private dostep_do_zdjec As Variant
Private tablica() As Variant
'Dla odwiedzających forum elektroda.pl - jeśli im się na coś przyda :)
Sub a_Dodaj_zdjecia_do_ppt()
Dim ogranicznik As Integer, roz_cznk_prw_str As Integer, roz_cznk_przezr As Integer
Dim plik As Integer, indeks As Integer, prezent As Integer, maks_zdj_prez As Integer
Dim maks_prez As Double
Dim cznk_prw_str As String, cznk_przezr As String, filterek As String, dostep_do_prez As String
Dim nazwa_prezent As String, nazwa_zdj As String, opis_zdj As String, prw_str As String
Dim opis_nagl_calej_prez As String, data_zdj As String, godzina_zdj As String
Dim info01 As String, info02 As String, info03 As String, info04 As String, info05 As String, info06 As String
Dim stempel_daty As Date
Dim il_zdj_w_prez As Variant
Dim nPrzezPrez As Object
'On Error GoTo koniec_blad
'-----------------------------------------------------------------------------------------------------------------------
'Ograniczenie maksymalnej ilości zdjęć na jedną prezentację
ogranicznik = 3000
'Ustawienia czcionki strony przewodniej - można sobie zmieniać poprzez tę zmienną
cznk_prw_str = "Arial" 'oryginalnie było "Calibri" - jednak ta czcionka z polskimi ą, ę, itd. nie wyświetlała się u mnie najlepiej
roz_cznk_prw_str = 36 '40
'Ustawienia czcionki strony przezrocza - można sobie zmieniać poprzez tę zmienną
cznk_przezr = "Arial" 'oryginalnie było "Calibri" - jednak ta czcionka z polskimi ą, ę, itd. nie wyświetlała się u mnie najlepiej
roz_cznk_przezr = 16 '18
'
'-----------------------------------------------------------------------------------------------------------------------
'
'Określenie opisu w nagłówku pojedynczej prezentacji - domyślne dla całej prezentacji
opis_nagl_calej_prez = Trim(InputBox("Proszę podać treść nagłówka dla przezroczy w prezentacji", "Treść nagłówka w prezentacji", "Zdjęcie wykonane w Kluczborku"))
'Określenie ilości zdjęć w pojedynczej prezentacji - domyślnie 500 szt.
il_zdj_w_prez = InputBox("Proszę podać ilość zdjęć na 1 prezentację", "Ilość zdjęć do umieszczenia w prezentacji", 500)
'Jeśli podano złą wartość
If il_zdj_w_prez = "" Or Not IsNumeric(Trim(il_zdj_w_prez)) Then
MsgBox "Podano złą wartość lub w ogóle jej nie podano" & vbCrLf & vbCrLf & "Koniec procedury", vbOKOnly + vbExclamation, "Uwaga !"
GoTo koniec
End If
'Jeśli podano dobrą wartość, ale w 'granicach przyzwoitości' typu Integer dla zmiennej 'ogranicznik'
il_zdj_w_prez = Abs(CInt(Trim(il_zdj_w_prez)))
If il_zdj_w_prez > ogranicznik Then
MsgBox "Przekroczono wartość graniczną" & vbCrLf & vbCrLf & "Koniec procedury", vbOKOnly + vbExclamation, "Uwaga !"
GoTo koniec
End If
'Określenie dostępu do katalogu ze zdjęciami
With Application.FileDialog(msoFileDialogFolderPicker)
filterek = ActivePresentation.Path
.AllowMultiSelect = False
.ButtonName = "Wybierz"
.InitialFileName = filterek
.Title = "Proszę wybrać katalog ze zdjęciami"
If .Show = -1 Then
dostep_do_zdjec = .SelectedItems(1)
Else
MsgBox "Nie podano dostępu do katalogu zdjęć" & vbCrLf & vbCrLf & "Koniec procedury", vbOKOnly + vbExclamation, "Uwaga !"
GoTo koniec
End If
End With
'Określenie dostępu do katalogu zapisywanych prezentacji
With Application.FileDialog(msoFileDialogFolderPicker)
filterek = ActivePresentation.Path
.AllowMultiSelect = False
.ButtonName = "Wybierz"
.InitialFileName = filterek
.Title = "Proszę podać miejsce zapisu prezentacji"
If .Show = -1 Then
dostep_do_prez = .SelectedItems(1)
Else
MsgBox "Nie podano dostępu do katalogu prezentacji" & vbCrLf & vbCrLf & "Koniec procedury", vbOKOnly + vbExclamation, "Uwaga !"
GoTo koniec
End If
End With
'Początek obróbki
MsgBox "Teraz rozpocznie się pobieranie nazw zdjęć" & vbCrLf & vbCrLf & "Może to trochę potrwać, zależnie od ich ilości", vbOKOnly, "Uwaga !"
'Pozyskanie nazw plików oraz ich posortowanie, wzrastająco, według daty utworzenia
'Pobrane zostaną tylko zdjęcia z rozszerzeniami: '*.bmp', '*.gif', '*.jpg', '*.jpeg', '*.png'
Call b_Lista_plikow_w_katalogu(dostep_do_zdjec)
Call c_sortowanie_babelkowe(tablica)
'Korekta liczby zdjęć w prezentacji, jeśli zadeklarowano większą ich ilość niż liczba wszystkich zdjęć do obróbki
If il_zdj_w_prez > il_plik Then il_zdj_w_prez = il_plik
'Określenie ilości prezentacji, jaka zostanie utworzona,
'w oparciu o ogólną ilość zdjęć i tych, przypadających na pojedynczą prezentację
maks_prez = (il_plik / il_zdj_w_prez) - Fix(il_plik / il_zdj_w_prez)
If maks_prez > 0 And maks_prez < 0.5 Then
maks_prez = Round(il_plik / il_zdj_w_prez, 0) + 1
Else
maks_prez = Round(il_plik / il_zdj_w_prez, 0)
End If
'Wartości początkowe zmiennych wyznaczających zakres 'od-do' zdjęć w prezentacji
maks_zdj_prez = il_zdj_w_prez
plik = 1
For prezent = 1 To maks_prez
'Utworzenie nazwy nowopowstającej prezentacji
Select Case prezent
Case Is <= 9: nazwa_prezent = "Prez_" & "000" & prezent & ".ppt"
Case Is <= 99: nazwa_prezent = "Prez_" & "00" & prezent & ".ppt"
Case Is <= 999: nazwa_prezent = "Prez_" & "0" & prezent & ".ppt"
Case Else: nazwa_prezent = "Prez_" & "" & prezent & ".ppt"
End Select
'Utworzenie i zapisanie na dysku nowopowstającej prezentacji - okno prezentacji widoczne - 'msoTrue'
Presentations.Add(WithWindow:=msoTrue).SaveAs dostep_do_prez & "\" & nazwa_prezent
'Zmiana wielkości okna programu
'ActiveWindow.View.Zoom = 75
'Wartość początkowa zmiennej ustalającej położenie danego przezrocza w prezentacji
indeks = 0
For plik = plik To maks_zdj_prez
'Wydzielenie nazwy kopiowanego zdjęcia oraz daty i godziny jego utworzenia
nazwa_zdj = Mid(tablica(plik), InStr(1, tablica(plik), ";", 1) + 1, Len(tablica(plik)) - InStr(1, tablica(plik), ";", 1))
stempel_daty = CDate(Mid(tablica(plik), 1, InStr(1, tablica(plik), ";", 1) - 1))
data_zdj = Format(stempel_daty, "dd.mm.yyyy")
godzina_zdj = Format(stempel_daty, "hh:mm")
'Zmienna na ewentualny, dodatkowy opis w nagłówku przezrocza pobrany z tablicy - tu niewykorzystana
opis_zdj = "Opis dodatkowy"
'Dodanie nowego przezrocza
indeks = indeks + 1
ActivePresentation.Slides.Add Index:=indeks, Layout:=ppLayoutBlank
'Przypisanie obiektu przezrocza do zmiennej - skrócenie zapisu obiektu
Set nPrzezPrez = ActivePresentation.Slides(indeks)
'Wkopiowanie zdjęcia
'LinkToFile:=msoFalse - teoretycznie uniezależnia wkopiowane zdjęcie od 'zdjęcia macierzystego' pobranego z katalogu
nPrzezPrez.Shapes.AddPicture FileName:=dostep_do_zdjec & "\" & nazwa_zdj, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=28, Top:=40, Width:=665, Height:=460
'Skalowanie wkopiowanego zdjęcia - zmianą liczby przy 'ScaleHeight' i 'ScaleWidth'
With nPrzezPrez.Shapes(1)
.LockAspectRatio = msoTrue
'.ScaleHeight 1.4, msoTrue, msoScaleFromMiddle 'msoScaleFromTopLeft 'msoScaleFromMiddle 'msoScaleFromBottomRight
'.ScaleWidth 1.4, msoTrue, msoScaleFromMiddle
.Width = 665
.Height = 460
End With
'Dodanie nagłówka
nPrzezPrez.Shapes.AddShape(msoShapeWave, 8.5, 9#, 703#, 62.38).TextFrame.TextRange.Text = "Zdjęcie nr " & Format(plik, "#,##0") & ": " & opis_nagl_calej_prez
'nPrzezPrez.Shapes.AddShape(msoShapeWave, 8.5, 9#, 703#, 62.38).TextFrame.TextRange.Text = "Zdjęcie nr " & Format(plik, "#,##0") & " (" & nazwa_zdj & ")"
'Inny układ opisu nagłówka - "Zdjęcie nr " & Format(plik, "#,##0") & ": " & nazwa_zdj & " - " & opis_zdj
'Formatowanie nagłówka
With nPrzezPrez.Shapes(2)
With .TextFrame
.AutoSize = ppAutoSizeNone
.WordWrap = msoFalse
With .TextRange
.ParagraphFormat.Alignment = ppAlignLeft
With .Font
.Name = cznk_przezr: .Size = roz_cznk_przezr: .Bold = msoTrue
.Color.RGB = RGB(0, 0, 0)
'.Color.SchemeColor = ppForeground
End With
End With
End With
With .Fill
.ForeColor.RGB = RGB(215, 228, 189)
.Solid
.Transparency = 0#
.Visible = msoTrue
End With
With .Line
.BackColor.RGB = RGB(255, 255, 255)
.ForeColor.RGB = RGB(79, 98, 40)
.Visible = msoTrue
End With
End With
'Dodanie stopki
nPrzezPrez.Shapes.AddShape(msoShapeWave, 8.5, 472#, 703#, 62.38).TextFrame.TextRange.Text = "DATA: " & data_zdj & ", godzina " & godzina_zdj
'Formatowanie stopki
With nPrzezPrez.Shapes(3)
With .TextFrame
.AutoSize = ppAutoSizeNone
.WordWrap = msoFalse
With .TextRange
.ParagraphFormat.Alignment = ppAlignLeft
With .Font
.Name = cznk_przezr: .Size = roz_cznk_przezr: .Bold = msoTrue
.Color.RGB = RGB(0, 0, 0)
'.Color.SchemeColor = ppForeground
End With
End With
End With
With .Fill
.ForeColor.RGB = RGB(215, 228, 189)
.Solid
.Transparency = 0#
.Visible = msoTrue
End With
With .Line
.BackColor.RGB = RGB(255, 255, 255)
.ForeColor.RGB = RGB(79, 98, 40)
.Visible = msoTrue
End With
End With
'Usunięcie dotychczasowych przypisań do zmiennych
Set nPrzezPrez = Nothing
nazwa_zdj = ""
stempel_daty = #1/1/1980#
data_zdj = ""
godzina_zdj = ""
opis_zdj = ""
'Co każde 1000 zdjęć 'odpuść' odrobinę na inne czynności - 'Niepraktyczne' w tym zadaniu
'If plik Mod 1000 = 0 Then DoEvents
Next plik
'Zmienna z tytułem prezentacji do strony przewodniej
prw_str = "PREZENTACJE" & vbCrLf & vbCrLf & "TYTUŁ" & vbCrLf & vbCrLf & "ILOŚĆ ZDJĘĆ: " & Format(indeks, "#,##0") & vbCrLf & vbCrLf & "OSTATNIA AKTUALIZACJA:" & vbCrLf & Format(Now(), "dd.mm.yyyy")
'Wstawienie strony przewodniej
ActivePresentation.Slides.Add Index:=1, Layout:=ppLayoutTitleOnly
'Sformatowanie strony przewodniej
With ActivePresentation.Slides(1).Shapes(1)
.Left = 54#
.Top = 167.75
.Width = 612.12
.Height = 115.62
With .TextFrame
.AutoSize = ppAutoSizeNone
.WordWrap = msoTrue
With .TextRange
.ParagraphFormat.Alignment = ppAlignCenter
.Text = prw_str
With .Font
.Name = cznk_prw_str: .Size = roz_cznk_prw_str
.Color.RGB = RGB(0, 0, 0)
'.Color.SchemeColor = ppForeground
End With
End With
End With
With .Fill
.Solid
.Transparency = 0#
.Visible = msoFalse
End With
With .Line
.Visible = msoFalse
End With
End With
'Zapis i zamknięcie nowoutworzonej prezentacji
Application.DisplayAlerts = ppAlertsNone
ActivePresentation.Save
' ActiveWindow.Close
ActivePresentation.Close
Application.DisplayAlerts = ppAlertsAll
'Czyszczenie zmiennej z tytułem prezentacji do strony przewodniej - na wszelki wypadek
prw_str = ""
'Jeśli przekroczono dopuszczalne wartości zmiennych, określone na początku, to korekta
'Można tu zastosować zmienną 'indeks'
maks_zdj_prez = il_zdj_w_prez + plik - 1
If maks_zdj_prez > il_plik Then maks_zdj_prez = il_plik
Next prezent
'Komunikat końcowy
info01 = "Procedura zakończona" & vbCrLf & vbCrLf
info02 = "Utworzono " & Format(maks_prez, "#,##0") & " prezentacje(-ę/-i) w: " & vbCrLf & vbCrLf
info03 = dostep_do_prez & vbCrLf & vbCrLf
info04 = "z " & Format(il_plik, "#,##0") & " zdjęć, po maksimum " & Format(il_zdj_w_prez, "#,##0") & " w każdej," & vbCrLf & vbCrLf
info05 = "pobranych z:" & vbCrLf & vbCrLf
info06 = dostep_do_zdjec
MsgBox info01 & info02 & info03 & info04 & info05 & info06, vbOKOnly, "Uwaga !"
Exit Sub
'Wykonaj jeśli w trakcie obróbki pojawił się jakiś błąd
koniec_blad:
On Error GoTo 0: On Error Resume Next
Application.DisplayAlerts = ppAlertsNone
With Presentations(nazwa_prezent)
.Saved = True: .Close
End With
Application.DisplayAlerts = ppAlertsAll
Set nPrzezPrez = Nothing
'Wykonaj po błędzie wyboru katalogu lub odwołaniu operacji ustalającej ilość zdjęć w prezentacji
koniec:
End
End Sub
Sub b_Lista_plikow_w_katalogu(dostep_do_zdjec As Variant)
Dim igt As Integer
Dim dlg As Integer, poz As Integer, licz As Integer
Dim rozsz_pliku As String
Dim ciag_prw As String, ciag_odtw As String, znak As String
Dim plik As Variant
Dim apli As Object, katalog As Object
On Error GoTo koniec
Set apli = CreateObject("Shell.Application")
Set katalog = apli.Namespace(dostep_do_zdjec)
'Inicjalizacja tablicy przechowującej dane o plikach zdjęć
ReDim tablica(1)
igt = 0
'Wpisanie informacji o plikach do tablicy
For Each plik In katalog.Items
'Wykonaj jeśli ma rozszerzenie
If InStrRev(plik, ".", -1, 1) <> 0 Then
rozsz_pliku = LCase(Mid(plik, InStrRev(plik, ".", -1, 1), 5))
'Pobierane będą dane tylko niektórych plików
If rozsz_pliku = ".jpg" Or rozsz_pliku = ".jpeg" Then
ciag_prw = CStr(katalog.GetDetailsOf(plik, 12))
'Dziwna wartość po wykonaniu <<katalog.GetDetailsOf(plik, 12)>>, tj. "?01-?03-?2017 ??19:21"
'Poniżej odtworzenie zapisu daty
dlg = Len(ciag_prw)
poz = 0
For licz = 1 To dlg
poz = poz + 1
znak = Mid(ciag_prw, poz, 1)
If Asc(znak) <> 63 Then ciag_odtw = ciag_odtw & znak
Next licz
If ciag_odtw = "" Then ciag_odtw = "01-01-1980 00:00"
igt = igt + 1
ReDim Preserve tablica(igt)
tablica(igt) = ciag_odtw & ";" & katalog.GetDetailsOf(plik, 0)
ciag_odtw = ""
Else
ciag_prw = CStr(katalog.GetDetailsOf(plik, 3))
If ciag_prw = "" Then ciag_prw = "01-01-1980 00:00"
igt = igt + 1
ReDim Preserve tablica(igt)
tablica(igt) = ciag_prw & ";" & katalog.GetDetailsOf(plik, 0)
ciag_prw = ""
End If
End If
Next plik
'Wstawia do zmiennej modułowej informację o ilości plików w tablicy
il_plik = igt
Set apli = Nothing
Set katalog = Nothing
Exit Sub
koniec:
Set apli = Nothing
Set katalog = Nothing
End Sub
Sub c_sortowanie_babelkowe(tablica As Variant)
Dim pocz As Integer, koniec As Integer
Dim i As Integer, j As Integer
Dim przech As Variant
On Error GoTo koniec
pocz = LBound(tablica)
koniec = UBound(tablica)
For i = pocz To koniec - 1
For j = i + 1 To koniec
If tablica(i) > tablica(j) Then
przech = tablica(j)
tablica(j) = tablica(i)
tablica(i) = przech
End If
Next j
Next i
Exit Sub
koniec:
End Sub
Edit://
I found a temporary solution to this. I fired this code, without the patch you wrote about on another computer, where I literally closed all windows in the window. Only the powerpoint was opened. The window with the script was on top. I didn't touch anything and the script worked fine on a large batch of photos (> 10k), creating a total of 11 presentation files. Can you explain to me as someone who is into programming and certainly VB programming does not know why this is happening and how to "remove" this problem?