Speichern als per UserForm / Letztes Blatt nicht drucken

[BuschB]

also es funktioniert auch mit MulitselectMulti, dann öffnet der mit einem Doppelklick alle markierten Dateien, ist aber nicht schlimm.
die Userform datei_exist ist fertig: (abgesehen davon die "Suche" via "Dir" auf Unterordner und deren Inhalte zu erweitern)

Code:

Option Explicit

Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
        ByVal hWnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
        ByVal lpParameters As String, _
        ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr

Private Sub datcancel_Click()
    With ActiveWorkbook.Sheets("Blatt 1")
        .Unprotect
        .Range("DB12").Value = 1
        .Protect DrawingObjects:=True, Contents:=True, Scenarios:=False
    End With
    Unload Me
   
End Sub

Private Sub datignore_Click()
    Unload Me

End Sub

Private Sub datdelete_Click()
Dim i As Integer
For i = 0 To DatName.ListCount - 1
    If DatName.Selected(i) Then
        If MsgBox("Wollen Sie " & DatName.List(i) & " wirklich löschen?", vbOKCancel, "") = vbOK Then
            Kill (save_as.save_path.Value & DatName.List(i))
            While ListArr <> ""
                DatName.AddItem ListArr
                ListArr = Dir
            Wend
        Else: Exit Sub
        End If
    End If
Next
If DatName = "" Then
    Unload Me
End If
End Sub

Private Sub DatName_DblClick(ByVal cancel As MSForms.ReturnBoolean)
Dim i As Integer
For i = 0 To DatName.ListCount - 1
    If DatName.Selected(i) Then
        ShellExecute 0&, "Open", save_as.save_path.Value & DatName.List(i), 0, 0, &H9&
    End If
Next
   
End Sub

Private Sub UserForm_Initialize()
    DatNr.Value = wbkname
    While ListArr <> ""
        DatName.AddItem ListArr
        ListArr = Dir
    Wend

End Sub

in Userform save_as fehlt nur noch die erwähnte Funktion, bei cancel_Click jegliche Speicheraktion zu stoppen, wie gesagt inklusive derer, welche BeforeSave initial getriggert hat.

[BuschB]

Sooooooo
Meine Abbrechenfunktion geht jetzt auch, das war es dann also fürs erste.
Nur noch die "Dir" um "Suche auch in Unterordnern" erweitern aber glaub das war bei den Attributen von Dir mit ein zu fügen, muss ich aber nochmal nachlesen.
Code:
Variablen:

Code:

Public wbkname As String
Public strDateiname As String
Public ListArr As Variant

Arbeitsmappe:

Code:

Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, cancel As Boolean)
With save_as
    If .Visible = False Then
        .Show
    End If
End With
If Me.Saved = False Then
    cancel = True
End If

End Sub

Private Sub Workbook_BeforePrint(cancel As Boolean)
    Sheets("Vorl. Blatt+").Visible = xlSheetVeryHidden

End Sub

Private Sub Workbook_Open()
    Sheets("Vorl. Blatt+").Visible = xlSheetVisible
   
End Sub

Userformen:
save_as:

Code:

Option Explicit
Private Sub cancel_Click()
    MsgBox "Die Datei wird nicht gespeichert, da Sie [Abbrechen] gedrückt oder nichts eingegeben haben.", , "Abbruch"
    Sheets("Vorl. Blatt+").Visible = xlSheetVisible
    Unload Me
   
End Sub

Private Sub UserForm_QueryClose(cancel As Integer, CloseMode As Integer)
    MsgBox "Die Datei wird nicht gespeichert, da Sie [Abbrechen] gedrückt oder nichts eingegeben haben.", , "Abbruch"
    Sheets("Vorl. Blatt+").Visible = xlSheetVisible
    Unload Me

End Sub

Private Sub finished_Click()
    Sheets("Vorl. Blatt+").Visible = xlSheetVeryHidden
    strDateiname = save_name.Value & ".xls"
If speicherDatei(ActiveWorkbook, strDateiname) = True Then
    Kill (save_path.Value & save_name.Value & ".xlsm")
    Unload Me
End If

End Sub

Private Sub send_Click()
    Sheets("Vorl. Blatt+").Visible = xlSheetVeryHidden
    strDateiname = save_name.Value & ".xls"
If speicherDatei(ActiveWorkbook, strDateiname) = True Then
    Sheets("Vorl. Blatt+").Visible = xlSheetVisible
    strDateiname = save_name.Value & ".xlsm"
If speicherDatei(ActiveWorkbook, strDateiname) = True Then
    With send_mail
        If .Visible = False Then
            .Show
        End If
    End With
    Unload Me
End If
End If

End Sub

Private Sub UserForm_Initialize()
    wbkname = ActiveSheet.Range("C12").Value & ActiveSheet.Range("I12").Value & ActiveSheet.Range("O12").Value & ActiveSheet.Range("U12").Value & ActiveSheet.Range("AA12").Value & ActiveSheet.Range("AG12").Value & ActiveSheet.Range("AM12").Value & ActiveSheet.Range("AS12").Value & ActiveSheet.Range("AY12").Value & ActiveSheet.Range("BE12").Value
    save_path.Value = Sheets("Blatt 1").Range("DC12").Value
    save_name.Value = "Schaltprogramm " & wbkname & " " & Sheets("Blatt 1").Range("AF20").Value & " " & Sheets("Blatt 1").Range("AF22").Value
   
End Sub

Private Sub work_in_progress_Click()
    strDateiname = save_name.Value & ".xlsm"
If speicherDatei(ActiveWorkbook, strDateiname) = True Then
    Unload Me
End If

End Sub

Function speicherDatei(ByVal wkb As Workbook, ByVal strDateiname As String) As Boolean
If save_name.Value = "" Then
    MsgBox "Die Datei wird nicht gespeichert, da Sie [Abbrechen] gedrückt oder nichts eingegeben haben.", , "Abbruch"
    Exit Function
Else
If save_path.Value = "" Then
    MsgBox "Die Datei wird nicht gespeichert, da Sie [Abbrechen] gedrückt oder nichts eingegeben haben.", , "Abbruch"
    Exit Function
Else
If Right(save_path.Value, 1) <> "\" Then save_path.Value = save_path.Value & "\"
End If
With wkb
With .Sheets("Blatt 1")
If Dir(save_path.Value & "*" & wbkname & "*", vbReadOnly) <> "" Then
    If Dir(save_path.Value & "*" & wbkname & "*", vbReadOnly) <> save_name.Value & ".xls" Then
        If Dir(save_path.Value & "*" & wbkname & "*", vbReadOnly) <> save_name.Value & ".xlsm" Then
            ListArr = Dir(save_path.Value & "*" & wbkname & "*", vbReadOnly)
            datei_exist.Show
            If .Range("DB12").Value = "1" Then
                .Unprotect
                .Range("DB12").ClearContents
                .Protect DrawingObjects:=True, Contents:=True, Scenarios:=False
                speicherDatei = False
               
                Unload Me
                Exit Function
            End If
        End If
    End If
End If
    .Unprotect
    .Range("DB12").ClearContents
    .Range("DC12").Value = save_path.Value
    .Protect DrawingObjects:=True, Contents:=True, Scenarios:=False
End With
    .SaveAs save_path.Value & strDateiname
End With
    speicherDatei = True
    MsgBox "Die Datei wurde unter " & save_path.Value & strDateiname & " gespeichert.", , "OK"
End If

End Function

send_mail:

Code:

Option Explicit
Private Sub cancel_Click()
    With save_as
        If .Visible = False Then
            .Show
        End If
    End With
    Unload Me
   
End Sub

Private Sub UserForm_QueryClose(cancel As Integer, CloseMode As Integer)
    With save_as
        If .Visible = False Then
            .Show
        End If
    End With
    Unload Me

End Sub

Private Sub send_Click()
If AktuelleArbeitsmappeSenden() = True Then
    MsgBox "Erstellung der E-Mail erfolgreich"
Else
    MsgBox "Erstellung der E-Mail fehlgeschlagen!"
End If
    Kill (save_as.save_path.Value & save_as.save_name.Value & ".xls")
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    ziel.Value = ""
    cc.Value = ""
    betreff.Value = save_as.save_name.Value
    nachricht.Value = ""
   
End Sub

Function AktuelleArbeitsmappeSenden() As Boolean
    On Error Resume Next
    Dim appOutlook As Object
    Dim meinElement As Object
    'Eine neue Instanz von Outlook erzeugen
    Set appOutlook = CreateObject("Outlook.Application")
    Set meinElement = appOutlook.CreateItem(0)
    With meinElement
        .To = ziel.Value
        .cc = cc.Value
        .Subject = betreff.Value
        .Body = nachricht.Value
        .Attachments.Add save_as.save_path.Value & save_as.save_name.Value & ".xls"
        .Display
    End With
    AktuelleArbeitsmappeSenden = True
    'Objekte aufräumen
    Set meinElement = Nothing
    Set appOutlook = Nothing
End Function

datei_exist:

Code:

Option Explicit

Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
        ByVal hWnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
        ByVal lpParameters As String, _
        ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr

Private Sub datcancel_Click()
    With ActiveWorkbook.Sheets("Blatt 1")
        .Unprotect
        .Range("DB12").Value = 1
        .Protect DrawingObjects:=True, Contents:=True, Scenarios:=False
    End With
    Unload Me
   
End Sub

Private Sub UserForm_QueryClose(cancel As Integer, CloseMode As Integer)
    With ActiveWorkbook.Sheets("Blatt 1")
        .Unprotect
        .Range("DB12").Value = 1
        .Protect DrawingObjects:=True, Contents:=True, Scenarios:=False
    End With
    Unload Me

End Sub

Private Sub datignore_Click()
    Unload Me

End Sub

Private Sub datdelete_Click()
Dim i As Integer
For i = 0 To DatName.ListCount - 1
    If DatName.Selected(i) Then
        If MsgBox("Wollen Sie " & DatName.List(i) & " wirklich löschen?", vbOKCancel, "") = vbOK Then
            Kill (save_as.save_path.Value & DatName.List(i))
            While ListArr <> ""
                DatName.AddItem ListArr
                ListArr = Dir
            Wend
        Else: Exit Sub
        End If
    End If
Next
If DatName = "" Then
    Unload Me
End If
End Sub

Private Sub DatName_DblClick(ByVal cancel As MSForms.ReturnBoolean)
Dim i As Integer
For i = 0 To DatName.ListCount - 1
    If DatName.Selected(i) Then
        ShellExecute 0&, "Open", save_as.save_path.Value & DatName.List(i), 0, 0, &H9&
    End If
Next
   
End Sub

Private Sub UserForm_Initialize()
    DatNr.Value = wbkname
    While ListArr <> ""
        DatName.AddItem ListArr
        ListArr = Dir
    Wend

End Sub

Danke an alle Helfer, hab auch wieder viel gelernt^^
Verbesserungsvorschläge sind weiterhin gern gesehen, aber soweit bin ich mit dem Programm zufrieden.

[schauan]

Hallöchen,

hier mal ein Beispiel zum Auslesen der Unterordner. Ein Filter ist auch dabei, hier für Textdateien *.txt.
Im Makro wird die Funktion getsubfolders aufgerufen, welche ein Array der Pfade ausgibt. Dann wird im Sub in einer Schleife der Dir-Befehl mit den ganzen Unterordnern ausgeführt.

Code:

'Globale Variable
Public glArr() As String
Public Counter As Long

Sub FileListing_In_SubFolder()
'Variablendeklarationen
Dim myArr, iCnt&, jCnt&, strFile$
Const strPath$ = "c:\test\"
'SubFolder zuweisen
myArr = GetSubFolders(strPath)
'Bildschirmflackern aus
Application.ScreenUpdating = False
'Ueberschriften setzen
Range("A1:B1") = Array("text file", "path")
'Schleife ueber Array
For jCnt = LBound(glArr) To UBound(glArr)
    'Fileeintrag auslesen
    strFile = Dir(myArr(jCnt) & "\*.txt")
    'Schleife solange Fileeintrag enthalten
    Do While Len(strFile) <> 0
        'Zeilenzaehler hochsetzen
        iCnt = iCnt + 1
        'Filename in Spalte A
        Cells(iCnt, 1) = strFile
        'Pfad in Spalte B
        Cells(iCnt, 2) = myArr(jCnt)
        strFile = Dir
    'Ende Schleife solange Fileeintrag enthalten
    Loop
'Ende Schleife ueber Array
Next jCnt
'Bildschirmflackern ein
Application.ScreenUpdating = True
End Sub

Function GetSubFolders(RootPath As String)
'Variablendeklarationen
Dim objFso As Object, objFld As Object, objSf As Object
Dim myArr, iCnt&
'Objekte instanzieren
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFld = objFso.getfolder(RootPath)
'Schleife ueber alle Unterverzeichnisse
For Each objSf In objFld.subfolders
    'Zaehler hochsetzen
    iCnt = iCnt + 1
    'Array erweitern
    ReDim Preserve glArr(iCnt)
    'Eintrag uebernehmen
    glArr(iCnt) = objSf.Path
    'Fkt rekursiv ausfuehren
    myArr = GetSubFolders(objSf.Path)
Next
'Ergebnis uebernehmen
GetSubFolders = glArr
'Objekte zuruecksetzen
Set objSf = Nothing
Set objFld = Nothing
Set objFso = Nothing
End Function

[BuschB]

Dankesehr, werde ich gleich morgen mit einarbeiten und im anschluss noch einmal alles testen, da mir am Freitag aufgefallen ist, das er sich irgendwo "aufhängt" wenn ich eine Datei die schon einmal gespeichert war, zur Weiterbearbeitung öffne und dann, nach Bearbeitung, wieder speichere, auch muss ich die Reihenfolge überarbeiten wenn sich der Dateiname im zuge der Weiterbearbeitung ändert, und ich auf datdelete klicke um die alte version zu löschen (da es ja in dem Fall die geöffnete Datei ist) werde da versuchen Me bei der Dir Suche ebenfalls aus zu schließen, mir aber den Dateinamen zu speichern und per MsgBox nach dem Speichern unter neuem Namen abfragen "Soll die Vorgängerversion 'Me' gelöscht werden?" oder sowas... Aber wie gesagt, alles Montag, melde mich dann nochmal zurück^^

[BuschB]

Ok, also wenn ich das jetzt richtig verstehe, hast du das gleich so gebaut das es die Dateien in einer "kleinen" Tabelle in den Spalten A:B auflistet, nicht nur die Ordner? 
In dem Fall könnte ich das nämlich direkt nutzen wenn ich die suche auf meinen Pfad und meine gesuchten Dateien umgebaut habe, muss dann nur noch schauen das ich das nicht in die Spalten A und B sondern gleich direkt in der Userform in die ListBox bekomme... Denke das bekomm ich hin^^

[schauan]

Hallöchen,

ja, genau so Statt in die Zellen schreibst Du es dann in die Listbox.

[BuschB]

Super, danke dir, probiere ich dann gleich mal aus, hatte nur gerade eine andere Idee, mir statt der Dateien in den Unterordnern per

Code:

Dir(save_path.Value & "*" & wbkname & "*", vbDirectory)

einfach die Unterordner selbst auf zu listen, sollten sich ja über 

Code:

Private Sub DatName_DblClick(ByVal cancel As MSForms.ReturnBoolean)
Dim i As Integer
For i = 0 To DatName.ListCount - 1
    If DatName.Selected(i) Then
        ShellExecute 0&, "Open", save_as.save_path.Value & DatName.List(i), 0, 0, &H9&
    End If
Next
   
End Sub

auch öffnen lassen und würde an der Stelle auch völlig ausreichen... aber wie gesagt, ich probier deins trotzdem aus und speichere es mir, kann es ggf an einer anderen Stelle anwenden


so, aber was ganz anderes, bei

Code:

Private Sub datdelete_Click()
Dim i As Integer
For i = 0 To DatName.ListCount - 1
    If DatName.Selected(i) Then
        If MsgBox("Wollen Sie " & DatName.List(i) & " wirklich löschen?", vbOKCancel, "") = vbOK Then
            Kill (save_as.save_path.Value & DatName.List(i))
            While ListArr <> ""
                DatName.AddItem ListArr
                ListArr = Dir
            Wend
        Else: Exit Sub
        End If
    End If
Next
If DatName = "" Then
    Unload Me
End If
End Sub

versuche ich nach dem Löschen der markierten Datei(en) die Listbox neu zu laden, aber irgendwie macht er das nicht...
Ich dachte halt, da es beim Initialisieren der Userform funktioniert, könnte ich das auch an dieser Stelle mit

Code:

            While ListArr <> ""
                DatName.AddItem ListArr
                ListArr = Dir
            Wend

lösen, aber naja, da ist wohl irgendein Unterschied oder der Code schneller mit dem Liste neu Laden als mit dem Löschen der Datei... 
Letzteres werd ich testen indem ich eine Verneinung Existenz der gelöschten Datei als Bedingung wähle.

[BuschB]

Ok, habe ein Problem... wenn ich eine Datei speichere, mit neuem Namen, lässt er die Datei mit altem Namen im Hintergrund geöffnet und verweigert mir damit den Zugriff bis ich Excel einmal komplett beendet habe, kann ich das irgendwie umgehen?

[schauan]

Hallöchen,

wenn Du mit SavaAs speicherst, sollte nur die eine Datei offen sein.
Wenn Du mit SaveCopyAs speicherst, dann beide

[BuschB]

Ja, eigentlich, aber ich überlege mit SaveCopyAs zu arbeiten und das andere Dokument per Befehl zu schließen damit ich es löschen kann ohne das ich die "Zugriff verweigert" Fehlermeldung bekomme.
wird vermutlich auch das beste sein da er sich auch manchmal mit Laufzeitfehler aufhängt wenn er ein SaveAs auf sich selbst ausführen soll...