Kein Zugriff auf Datei nach speichern im Dateisystem (VBA?!)

Sub Archiv()
Dim Sektion$, ApplicationTag$, Sender$, File$, Zielpfad$, Zwischenablage$, Steuerdateierweiterung$, Dateiname_hps$, Nrtype$

    '------------- Parameterbelegung ------------------  
    
    'Speicherpfad für beide Dateien (HPS und DOC)  
    Zielpfad = "\\testserver\testverzeichnis\"  
    Zwischenablage = "\\testserver\testverzeichnis\Zwischenablage\"  
    Steuerdateierweiterung = "hps"  
    
    '---------------------------------------------------  
   
    'Auslesen des Bereiches zwischen 2 Textmarken  
    Dim Textmarke_1, Textmarke_2, Textmarke_3, Textmarke_4
    
    'Textmarken, zwischen denen der Text ausgewählt wird  
    Textmarke_1 = "KUNDENNR"  
    Textmarke_2 = "KUNDENNR_ENDE"  
    Textmarke_3 = "LIEFERANTENNR"  
    Textmarke_4 = "LIEFERANTENNR_ENDE"  
    
    
    '########## Prüfen ob Kunde ############################  
    Dim kDoc As Document
    Dim kRange As Range
    
    Set kDoc = ActiveDocument
    If kDoc.Bookmarks.Exists(Textmarke_1) And kDoc.Bookmarks.Exists(Textmarke_2) Then
        Set kRange = kDoc.Range(Start:=kDoc.Bookmarks(Textmarke_1).Range.Start, End:=kDoc.Bookmarks(Textmarke_2).Range.Start)
        kRange.Select
        'Wenn Kundennummer gefunden wurde  
        If kRange <> " " And kRange <> "" Then  
            Nrtype = "Kunde"  
            'MsgBox (kRange)  
            
            Call Titel(Zielpfad, Zwischenablage, Steuerdateierweiterung, kRange, Nrtype)
            
        Else
            '########## Prüfen ob Lieferant #######################  
            Dim lDoc As Document
            Dim lRange As Range
            
            Set lDoc = ActiveDocument
            If lDoc.Bookmarks.Exists(Textmarke_3) And lDoc.Bookmarks.Exists(Textmarke_4) Then
                Set lRange = lDoc.Range(Start:=lDoc.Bookmarks(Textmarke_3).Range.Start, End:=lDoc.Bookmarks(Textmarke_4).Range.Start)
                lRange.Select
                'Wenn Lieferantennummer gefunden wurde  
                If lRange <> " " And lRange <> "" Then  
                    Nrtype = "Lieferant"  
                    'MsgBox (NrType)  
                    
                    Call Titel(Zielpfad, Zwischenablage, Steuerdateierweiterung, lRange, Nrtype)
                    
                Else
                    '####### wenn keine KDNR und keine LFRNR gefunden wird ####################  
                    Nrtype = "Unbekannt"  
                    Call Case_manuell(Zielpfad, Zwischenablage, Steuerdateierweiterung, Nrtype)
                End If
            Else
                '####### Falls keine Textmarken nach Lieferantensuche gefunden werden #######################  
                Call Case_manuell(Zielpfad, Zwischenablage, Steuerdateierweiterung, Nrtype)
            End If
        End If
    Else
    '####### Falls keine Textmarken gefunden werden ###########  
    Call Case_manuell(Zielpfad, Zwischenablage, Steuerdateierweiterung, Nrtype)
    End If
    
End Sub


Function Case_manuell(Zielpfad, Zwischenablage, Steuerdateierweiterung, Nrtype)
Dim Mldg, Stil, Titel, Hilfe, Ktxt, Antwort, Text1
Mldg = "Es wurden keine Textmarken gefunden" & vbCrLf & "Soll eine manuelle Zuweisung vorgenommen werden?"  
Stil = vbYesNo + vbCritical + vbDefaultButton1
Titel = "Fehler beim Auslesen der Textmarken"  
Antwort = MsgBox(Mldg, Stil, Titel)
If Antwort = vbYes Then
  Call Neue_Nummer(Zielpfad, Zwischenablage, Steuerdateierweiterung, Nrtype)
Else
   
End If
End Function


Function Neue_Nummer(Zielpfad, Zwischenablage, Steuerdateierweiterung, Nrtype)
    'Nach Nummerfragen  
    Dim manuelle_Nummer
    manuelle_Nummer = InputBox("Keine Kundennummer oder Lieferantennummer gefunden." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & "Bitte Nummer eingeben.", "Manuelle Nummerzuweisung für " & Nrtype, "")  
    If manuelle_Nummer = "" Then  
       manuelle_Nummer = " "  
    End If

    Call Titel(Zielpfad, Zwischenablage, Steuerdateierweiterung, manuelle_Nummer & " ", Nrtype)  
End Function


Function Titel(Zielpfad, Zwischenablage, Steuerdateierweiterung, Nummer, Nrtype) As Variant
    'Name des Dokuemtes eingeben  
    Dim DocName
    DocName = InputBox("Bitte Dokumentname eingeben:", "Dokumentname für Schreiben an " & Nrtype & " (Nr." & Nummer & ")", "neues Dokument")  
    If DocName = "" Then  
       DocName = "Neues Dokument"  
    End If
    
    'Nochmal fragen ob Dokument wirklich ins Archiv geschoben werden soll  
    Dim Archivantwort
    Archivantwort = MsgBox("Möchten Sie das Dokument wirklich ins Archiv einfügen?", vbYesNo + vbQuestion + vbDefaultButton1, "Einfügen bestätigen")  
    If Archivantwort = vbYes Then
        'speichern  
        Call Speichern(Zielpfad, Zwischenablage, Steuerdateierweiterung, Nummer, DocName)
    Else
        'nix  
    End If
End Function

Function Speichern(Zielpfad, Zwischenablage, Steuerdateierweiterung, Nummer, DocName) As Variant
    
    'Variablen zum Speichern  
    Dim Sektion$, ApplicationTag$, Sender$, File$
    
    'Dateipfad und Name fuer HPS und DOC aus Datum basteln  
    Dim Part(1 To 3) As String
    Part(1) = Zwischenablage
    Part(2) = Format(Date, "yyyymmdd") + "_" + Format(Time, "hhmmss")  
    Part(3) = "." & Steuerdateierweiterung  
    Dateiname_hps = Part(1) & Part(2) & Part(3)
    'MsgBox (Dateiname_hps)  

    'Erste Zeile (mit eckigen Klammern)  
    Sektion = "[Info]"  
    
    'ApplicationTag  
    ApplicationTag = "ApplicationTag=" & Nummer & DocName  
    'MsgBox (ApplicationTag)  

    'Sender  
    Sender = "Sender=" & Environ("Username")  
    'MsgBox (Sender)  

    'File  
    File = "File=" & Part(2) & ".doc"  
    'MsgBox (File)  
    
    'HPS schreiben  
    Open Dateiname_hps For Append As 1
    Print #1, Sektion$
    Print #1, ApplicationTag$
    Print #1, Sender$
    Print #1, File$
    Close #1
    
    'Dokumentpfad und Name der Word-Datei aus Datum basteln  
    Dim Part_doc(1 To 3) As String
    Part_doc(1) = Zwischenablage
    Part_doc(2) = Part(2)
    Part_doc(3) = ".doc"  
    Dateiname_doc = Part_doc(2) & Part_doc(3)
        
    'DOC schreiben in Zwischenablageordner  
    ChangeFileOpenDirectory Part_doc(1)
    ActiveDocument.SaveAs FileName:=Dateiname_doc, FileFormat:= _
        wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _  
        True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _  
        False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False
        
    'DOC schreiben in Zwischenablageordner mit Namenszusatz "_saved"  
    Dim Dateiname_Saved
    Dateiname_Saved = Part_doc(2) & "_saved" & Part_doc(3)  
    ChangeFileOpenDirectory Part_doc(1)
    ActiveDocument.SaveAs FileName:=Dateiname_Saved, FileFormat:= _
        wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _  
        True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _  
        False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False
         
        
    'von der Zwischenablage in den Zielpfad kopieren  
    Dim Datei_hps
    Datei_hps = Part(2) & Part(3)
    Call Copy_to_Target(Zwischenablage, Zielpfad, Datei_hps, Dateiname_doc)
    
End Function

Function Copy_to_Target(Zwischenablage, Zielpfad, Datei_hps, Dateiname_Dokument)
    
    'HPS und DOC kopieren  
    FileCopy Zwischenablage & Datei_hps, Zielpfad & Datei_hps
    FileCopy Zwischenablage & Dateiname_Dokument, Zielpfad & Dateiname_Dokument
    
    'HPS und DOC aus Zwischenablageordner löschen (nur geöffnetes DOC ist noch da!)  
    Kill Zwischenablage & Datei_hps
    Kill Zwischenablage & Dateiname_Dokument
End Function