Word Makro für "speichern unter" wahlweise 3 Ordner

Dieses Thema Word Makro für "speichern unter" wahlweise 3 Ordner im Forum "Microsoft Office Suite" wurde erstellt von frajo, 30. Sep. 2004.

Thema: Word Makro für "speichern unter" wahlweise 3 Ordner in Word 97 möchte ich beim Start eines Makros drei Ordner zur Auswahl angeboten bekommen mit speichern unter....

  1. in Word 97 möchte ich beim Start eines Makros drei Ordner zur Auswahl angeboten bekommen mit speichern unter.
    Zweck: ich rufe Dateien von einem Ort auf, auf den sie nicht gespeichert werden sollen, sondern in drei andere Ordner. Gibt es ein Makro? Ich suche eine Lösung ohne Favoriten.
    Bin für jeden Tip dankbar.
     
  2. Hi frajo,

    hab ich nicht ganz verstanden ???

    Ich hab dir mal den Makro SpeichernAls_3OrdnerZurAuswahl zusammengestellt.
    Die Pfadangaben in den Konstanten s_Ordner1 ... 3 mußt du deinen Gegebenheiten anpassen.

    Probier ihn erstmal an Beispiel-Dokumenten aus, ob er deinen Wünschen entsprechend arbeitet.

    Gruß Matjes :)

    Code:
    '*****************************************************************
    Public Sub SpeichernAls_3OrdnerZurAuswahl()
     ->Der Makro speichert das aktive Dokument in 3 zur Auswahl
     ->stehenden Odrnern (s_Ordner1 ... 3, bitte anpassen )
     ->
     ->Nach erfolgreichem Speichern wird abgefragt, ob das
     ->ursprüngliche Document gelöscht werden soll.
     ->ja: Löschen des ursprünglichen Documents
    
    '*****************************************************************
      Const s_Ordner1 As String = c:\Ordner1
      Const s_Ordner2 As String = c:\Ordner2
      Const s_Ordner3 As String = c:\Ordner3
    
      Dim s_DateiName As String, s_FullName As String
      Dim doc As Document, s_tmp As String, s_Eingabe As String
      Set doc = ActiveDocument
      
     ->Dateinamen feststellen
      s_DateiName = doc.Name
     ->vollen Namen mit Pfad feststellen
      s_FullName = doc.FullName
      
     ->Speicherziel abfragen
      s_Eingabe = 
      Do->solange die Eingabe nicht , 1, 2 oder 3
      s_Eingabe = InputBox( _
        Bitte wählen Sie die Nummer für den Speicherort aus: & vbLf & _
        1 für Odner1  & s_Ordner1 & vbLf & _
        2 für Odner1  & s_Ordner2 & vbLf & _
        3 für Odner1  & s_Ordner3 & vbLf & _
        keine Eingabe -> Abbruch, _
        Auswahl des Speicherortes)
      Loop While (s_Eingabe <> ) And (s_Eingabe <> 1) And _
                  (s_Eingabe <> 2) And (s_Eingabe <> 3)
      
     ->SpeicherString zusammenstellen
      Select Case s_Eingabe
        Case 1: s_tmp = s_Ordner1
        Case 2: s_tmp = s_Ordner2
        Case 3: s_tmp = s_Ordner3
        Case Else: GoTo EndeBearbeitung->keine Eingabe -> Abbruch ?
      End Select
      
     ->an ausgewähltem Ort speichern
      On Error GoTo SpeicherFehler
      doc.SaveAs s_tmp & \ & s_DateiName
      On Error GoTo 0
     ->Datei schliessen
      doc.Close SaveChanges:=False
      
      If vbYes = MsgBox( _
                  Soll die Ursprüngliche Datei gelöscht werden?, _
                  vbQuestion + vbDefaultButton2 + vbYesNo) Then
        Kill s_FullName->ursprüngliche Datei löschen
      End If
      
      GoTo EndeBearbeitung
    SpeicherFehler:
      MsgBox (Es trat ein Fehler beim Speichern auf)
    EndeBearbeitung:
      Set doc = Nothing
    End Sub
     
  3. Hi Matjes,
    super, danke. Habe es probiert, läuft gut. :) Hätte allerdings gerne die Möglichkeit, den Dateinamen selbst zu vergeben, kannst du mir das auch machen? Am besten wäre es wenn ich den Dateinamen-Vorschlag modifizieren könnte.
    Gruß frajo

     
  4. Hi frajo,

    wie gewünscht ;D

    Wenn ich ein Zeichen bei der Dateinamen-Überprüfung (ZeichenFuerDateiNamenZulaessig) ausgeschlossen habe, das doch zulässig sein sollte, las es mich wissen.

    Gruß Matjes ;)


    Code:
    '*****************************************************************
    Public Sub SpeichernAls_3OrdnerZurAuswahl()
     ->Der Makro speichert das aktive Dokument in 3 zur Auswahl
     ->stehenden Odrnern (s_Ordner1 ... 3, bitte anpassen )
     ->
     ->Nach erfolgreichem Speichern wird abgefragt, ob das
     ->ursprüngliche Document gelöscht werden soll.
     ->ja: Löschen des ursprünglichen Documents
    
    '*****************************************************************
      Const s_Ordner1 As String = c:\Ordner1
      Const s_Ordner2 As String = c:\Ordner2
      Const s_Ordner3 As String = c:\Ordner3
    
      Dim s_DateiName As String, s_FullName As String
      Dim doc As Document, s_tmp As String, s_Eingabe As String
      Dim b_Dateiname_ok As Boolean, s_Dateiname2 As String
      Dim x As Long, s_letter As String
      
      Set doc = ActiveDocument
      
     ->Dateinamen feststellen
      s_DateiName = doc.Name
     ->vollen Namen mit Pfad feststellen
      s_FullName = doc.FullName
      
     ->Speicherziel abfragen
      s_Eingabe = 
      Do->solange die Eingabe nicht , 1, 2 oder 3
      s_Eingabe = InputBox( _
        Bitte wählen Sie die Nummer für den Speicherort aus: & vbLf & _
        1 für Odner1  & s_Ordner1 & vbLf & _
        2 für Odner1  & s_Ordner2 & vbLf & _
        3 für Odner1  & s_Ordner3 & vbLf & _
        keine Eingabe -> Abbruch, _
        Auswahl des Speicherortes)
      Loop While (s_Eingabe <> ) And (s_Eingabe <> 1) And _
                  (s_Eingabe <> 2) And (s_Eingabe <> 3)
      
     ->SpeicherString zusammenstellen
      Select Case s_Eingabe
        Case 1: s_tmp = s_Ordner1
        Case 2: s_tmp = s_Ordner2
        Case 3: s_tmp = s_Ordner3
        Case Else: GoTo EndeBearbeitung->keine Eingabe -> Abbruch ?
      End Select
      
      b_Dateiname_ok = False
      s_Dateiname2 = s_DateiName
      Do
        s_Dateiname2 = InputBox( _
          Unter welchem Namen soll die Datei gespeichert werden?, _
          Eingabe des Dateinamens, s_Dateiname2)
       ->mindestens 5 Zeichen
        If Len(s_DateiName) > 5 Then
         ->Dateityp wie die der Ursprungsdatei ?
          If Right(s_Dateiname2, 4) = Right(s_DateiName, 4) Then
            For x = 1 To Len(s_Dateiname2) - 4
              s_letter = Mid(s_Dateiname2, x, 1)
              If Not ZeichenFuerDateiNamenZulaessig(s_tmp) Then
                MsgBox (' & s_letter &-> ist unzulässig in einem Dateinamen :-()
                b_Dateiname_ok = False
              Else
                b_Dateiname_ok = True
              End If
            Next
          
          Else
            MsgBox (Dateityp entspricht nicht dem der Ausgangsdatei :-()
          End If
        Else
          s_Dateiname2 = s_DateiName
        End If
        
      Loop While (b_Dateiname_ok = False)
    
     ->an ausgewähltem Ort speichern
      On Error GoTo SpeicherFehler
      doc.SaveAs s_tmp & \ & s_Dateiname2
      On Error GoTo 0
     ->Datei schliessen
      doc.Close SaveChanges:=False
      
      If vbYes = MsgBox( _
                  Soll die Ursprüngliche Datei gelöscht werden?, _
                  vbQuestion + vbDefaultButton2 + vbYesNo) Then
        Kill s_FullName->ursprüngliche Datei löschen
      End If
      
      GoTo EndeBearbeitung
    SpeicherFehler:
      MsgBox (Es trat ein Fehler beim Speichern auf)
    EndeBearbeitung:
      Set doc = Nothing
    End Sub
    
    Function ZeichenFuerDateiNamenZulaessig(str As String) As Boolean
      Select Case str
        Case a To z, A To Z, 0 To 9, ä, Ä, ö, Ö, ü, Ü, ß
          ZeichenFuerDateiNamenZulaessig = True
        Case !, §, $, %, &, (, ), =, {, [, ], }, +, ~
          ZeichenFuerDateiNamenZulaessig = True
        Case #, ;, _, -, ., ,, @,  
          ZeichenFuerDateiNamenZulaessig = True
        Case Else
          ZeichenFuerDateiNamenZulaessig = False
      End Select
    End Function
     
  5. Hi Matjes,
    danke, wollte es gerade testen, aber nicht ausführen (speichern), sondern nur abbrechen, also nicht speichern, das ging nicht: Dateityp entspricht nicht dem der Ausgangsdatei :-(
    Das war wohl auch im weiteren Sinne deine Frage?
    Gruß frajo
     
  6. Hi frajo,

    hab diesen Abbruch jetzt auch eingebaut. :D

    Diese Dateinamens-Überprüfung wird erst mit dem OK-Button der Dateinamens-Eingabe erreicht. Die Frage ist hier, ob Du bei der Namensgebung deiner Dateien auf Ablehnung von bestimmten Zeichen triffst, die eigentlich für einen Dateinamen zulässig sind.

    Gruß Matjes :)

    Code:
    Option Explicit
    '*****************************************************************
    Public Sub SpeichernAls_3OrdnerZurAuswahl()
     ->Der Makro speichert das aktive Dokument in 3 zur Auswahl
     ->stehenden Odrnern (s_Ordner1 ... 3, bitte anpassen )
     ->
     ->Nach erfolgreichem Speichern wird abgefragt, ob das
     ->ursprüngliche Document gelöscht werden soll.
     ->ja: Löschen des ursprünglichen Documents
    
    '*****************************************************************
      Const s_Ordner1 As String = c:\Ordner1
      Const s_Ordner2 As String = c:\Ordner2
      Const s_Ordner3 As String = c:\Ordner3
    
      Dim s_DateiName As String, s_FullName As String
      Dim doc As Document, s_tmp As String, s_Eingabe As String
      Dim b_Dateiname_ok As Boolean, s_Dateiname2 As String
      Dim x As Long, s_letter As String, ret As Integer
      
      Set doc = ActiveDocument
      
     ->Dateinamen feststellen
      s_DateiName = doc.Name
     ->vollen Namen mit Pfad feststellen
      s_FullName = doc.FullName
      
     ->Speicherziel abfragen
      s_Eingabe = 
      Do->solange die Eingabe nicht , 1, 2 oder 3
      s_Eingabe = InputBox( _
        Bitte wählen Sie die Nummer für den Speicherort aus: & vbLf & _
        1 für Odner1  & s_Ordner1 & vbLf & _
        2 für Odner1  & s_Ordner2 & vbLf & _
        3 für Odner1  & s_Ordner3 & vbLf & _
        keine Eingabe -> Abbruch, _
        Auswahl des Speicherortes)
      Loop While (s_Eingabe <> ) And (s_Eingabe <> 1) And _
                  (s_Eingabe <> 2) And (s_Eingabe <> 3)
      
     ->SpeicherString zusammenstellen
      Select Case s_Eingabe
        Case 1: s_tmp = s_Ordner1
        Case 2: s_tmp = s_Ordner2
        Case 3: s_tmp = s_Ordner3
        Case Else: GoTo EndeBearbeitung->keine Eingabe -> Abbruch ?
      End Select
      
      b_Dateiname_ok = False
      s_Dateiname2 = s_DateiName
      Do
        s_Dateiname2 = InputBox( _
          Unter welchem Namen soll die Datei gespeichert werden?, _
          Eingabe des Dateinamens, s_Dateiname2)
        If s_Dateiname2 =  Then
          ret = MsgBox(Wollen Sie wirklich abbrechen?, _
                        vbQuestion + vbYesNo + vbDefaultButton2)
          If ret = vbYes Then
            GoTo EndeBearbeitung
          Else
            s_Dateiname2 = s_DateiName
          End If
        Else
         ->mindestens 5 Zeichen
          If Len(s_Dateiname2) > 5 Then
           ->Dateityp wie die der Ursprungsdatei ?
            If Right(s_Dateiname2, 4) = Right(s_DateiName, 4) Then
              For x = 1 To Len(s_Dateiname2) - 4
                s_letter = Mid(s_Dateiname2, x, 1)
                If Not ZeichenFuerDateiNamenZulaessig(s_tmp) Then
                  MsgBox (' & s_letter &-> ist unzulässig in einem Dateinamen :-()
                  b_Dateiname_ok = False
                Else
                  b_Dateiname_ok = True
                End If
              Next
            
            Else
              MsgBox (Dateityp entspricht nicht dem der Ausgangsdatei :-()
            End If
          Else
            s_Dateiname2 = s_DateiName
          End If
        End If
      Loop While (b_Dateiname_ok = False)
    
     ->an ausgewähltem Ort speichern
      On Error GoTo SpeicherFehler
      doc.SaveAs s_tmp & \ & s_Dateiname2
      On Error GoTo 0
     ->Datei schliessen
      doc.Close SaveChanges:=False
      
      If vbYes = MsgBox( _
                  Soll die Ursprüngliche Datei gelöscht werden?, _
                  vbQuestion + vbDefaultButton2 + vbYesNo) Then
        Kill s_FullName->ursprüngliche Datei löschen
      End If
      
      GoTo EndeBearbeitung
    SpeicherFehler:
      MsgBox (Es trat ein Fehler beim Speichern auf)
    EndeBearbeitung:
      Set doc = Nothing
    End Sub
    
    Function ZeichenFuerDateiNamenZulaessig(str As String) As Boolean
      Select Case str
        Case a To z, A To Z, 0 To 9, ä, Ä, ö, Ö, ü, Ü, ß
          ZeichenFuerDateiNamenZulaessig = True
        Case !, §, $, %, &, (, ), =, {, [, ], }, +, ~
          ZeichenFuerDateiNamenZulaessig = True
        Case #, ;, _, -, ., ,, @,  
          ZeichenFuerDateiNamenZulaessig = True
        Case Else
          ZeichenFuerDateiNamenZulaessig = False
      End Select
    End Function
     
  7. Hi Matjes,
    jetzt schlägt es mir den Dateinamen nicht mehr vor, geht das nicht?
    Gruß frajo
     
  8. Hi frajo,

    hab noch eine Variablen-Namen geändert, leider an einer Stelle nicht :'(

    Bitte probier es mit dieser Version noch einmal.

    Gruß Matjes :)

    Code:
    Public Sub SpeichernAls_3OrdnerZurAuswahl()
     ->Der Makro speichert das aktive Dokument in 3 zur Auswahl
     ->stehenden Odrnern (s_Ordner1 ... 3, bitte anpassen )
     ->
     ->Nach erfolgreichem Speichern wird abgefragt, ob das
     ->ursprüngliche Document gelöscht werden soll.
     ->ja: Löschen des ursprünglichen Documents
    
    '*****************************************************************
      Const s_Ordner1 As String = c:\Ordner1
      Const s_Ordner2 As String = c:\Ordner2
      Const s_Ordner3 As String = c:\Ordner3
    
      Dim s_DateiName As String, s_FullName As String
      Dim doc As Document, s_tmp As String, s_Eingabe As String
      Dim b_Dateiname_ok As Boolean, s_Dateiname2 As String
      Dim x As Long, s_letter As String, ret As Integer
      
      Set doc = ActiveDocument
      
     ->Dateinamen feststellen
      s_DateiName = doc.Name
     ->vollen Namen mit Pfad feststellen
      s_FullName = doc.FullName
      
     ->Speicherziel abfragen
      s_Eingabe = 
      Do->solange die Eingabe nicht , 1, 2 oder 3
      s_Eingabe = InputBox( _
        Bitte wählen Sie die Nummer für den Speicherort aus: & vbLf & _
        1 für Odner1  & s_Ordner1 & vbLf & _
        2 für Odner1  & s_Ordner2 & vbLf & _
        3 für Odner1  & s_Ordner3 & vbLf & _
        keine Eingabe -> Abbruch, _
        Auswahl des Speicherortes)
      Loop While (s_Eingabe <> ) And (s_Eingabe <> 1) And _
                  (s_Eingabe <> 2) And (s_Eingabe <> 3)
      
     ->SpeicherString zusammenstellen
      Select Case s_Eingabe
        Case 1: s_tmp = s_Ordner1
        Case 2: s_tmp = s_Ordner2
        Case 3: s_tmp = s_Ordner3
        Case Else: GoTo EndeBearbeitung->keine Eingabe -> Abbruch ?
      End Select
      
      s_Dateiname2 = s_DateiName
      Do
        s_Dateiname2 = InputBox( _
          Unter welchem Namen soll die Datei gespeichert werden?, _
          Eingabe des Dateinamens, s_Dateiname2)
        If s_Dateiname2 =  Then
          ret = MsgBox(Wollen Sie wirklich abbrechen?, _
                        vbQuestion + vbYesNo + vbDefaultButton2)
          If ret = vbYes Then
            GoTo EndeBearbeitung
          Else
            s_Dateiname2 = s_DateiName
            b_Dateiname_ok = False
          End If
        Else
         ->mindestens 5 Zeichen
          If Len(s_Dateiname2) > 5 Then
           ->Dateityp wie die der Ursprungsdatei ?
            If Right(s_Dateiname2, 4) = Right(s_DateiName, 4) Then
              For x = 1 To Len(s_Dateiname2) - 4
                s_letter = Mid(s_Dateiname2, x, 1)
                If Not ZeichenFuerDateiNamenZulaessig(s_letter) Then
                  MsgBox (' & s_letter &-> ist unzulässig in einem Dateinamen :-()
                  b_Dateiname_ok = False
                  Exit For
                Else
                  b_Dateiname_ok = True
                End If
              Next
            
            Else
              MsgBox (Dateityp entspricht nicht dem der Ausgangsdatei :-()
            End If
          Else
            s_Dateiname2 = s_DateiName
            b_Dateiname_ok = False
          End If
        End If
      Loop While (b_Dateiname_ok = False)
    
     ->an ausgewähltem Ort speichern
      On Error GoTo SpeicherFehler
      doc.SaveAs s_tmp & \ & s_Dateiname2
      On Error GoTo 0
     ->Datei schliessen
      doc.Close SaveChanges:=False
      
      If vbYes = MsgBox( _
                  Soll die Ursprüngliche Datei gelöscht werden?, _
                  vbQuestion + vbDefaultButton2 + vbYesNo) Then
        Kill s_FullName->ursprüngliche Datei löschen
      End If
      
      GoTo EndeBearbeitung
    SpeicherFehler:
      MsgBox (Es trat ein Fehler beim Speichern auf)
    EndeBearbeitung:
      Set doc = Nothing
    End Sub
    
    Function ZeichenFuerDateiNamenZulaessig(str As String) As Boolean
      Select Case str
        Case a To z, A To Z, 0 To 9, ä, Ä, ö, Ö, ü, Ü, ß
          ZeichenFuerDateiNamenZulaessig = True
        Case !, §, $, %, &, (, ), =, {, [, ], }, +, ~
          ZeichenFuerDateiNamenZulaessig = True
        Case #, ;, _, -, ., ,, @,  
          ZeichenFuerDateiNamenZulaessig = True
        Case Else
          ZeichenFuerDateiNamenZulaessig = False
      End Select
    End Function
     
  9. Hi Matjes,
    vielen Dank für deine Geduld, aber der Dateiname wird immer noch nicht vorgeschlagen.
    Gruß frajo
     
  10. Hi frajo,

    bei mir kommt nach dem Aufruf
    a) Auswahl Ordner
    -> Eingabe z.B. 3
    b) Eingabe des Dateinamens
    (im Eingabefenster steht dann der bisherige Dateiname)

    und dort steht bei dir nichts ?

    Gruß Matjes :)
     
Die Seite wird geladen...

Word Makro für "speichern unter" wahlweise 3 Ordner - Ähnliche Themen

Forum Datum
Word 2013 VBA: Makro aus einer anderen Datei aufrufen Microsoft Office Suite 16. Juni 2014
Makro zum drucken der ersten Seite von Stck. 200 Word2007 Doc in einem Verz. Windows XP Forum 9. Aug. 2012
Schriftfarbe per Makro in Word 2003 suchen Microsoft Office Suite 28. Nov. 2011
Word Makro kann nicht aufgezeichnet werden Windows XP Forum 12. Apr. 2010
WORD: Makros deaktiviert?? Microsoft Office Suite 16. Apr. 2009