VBA excel bestand vervangen door update bestand met dezelfde naam

[PK58]

Heren Specialisten,

een korte beschrijving van mijn probleem
De macro haalt update.xlsm op in Outlook, opend deze en kopieert de gegevens van "concept aanvraag;xlsm" naar "update.xlsm"
"update.xlsm" wordt hernoemd naar "conceptnw aanvraag.xlsm", tot zover loopt het goed.
Vervolgens zou het bestand waar de macro in gestart is ("concept aanvraag.xlsm") vervangen moeten door de geupdate versie onder dezelfde naam en op de zelfde plaats.... ik heb van alles geprobeerd maar het lukt mij niet.

bij voorbaat dank voor het meedenken

 Sub Update_program()
 

    SaveEmailAttachmentsToFolder "Aanvraag Update", "xlsm", ""
    
End Sub
Private Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
                                 ExtString As String, DestFolder As String)
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object
    
    'om foutmeldingen te voorkomen map leegmaken
    
    On Error Resume Next
    Kill "D:\AANVRAAG\UPDATE\*.*"
    On Error GoTo 0

    On Error GoTo ThisMacro_err
    Application.DisplayAlerts = False
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.folders(OutlookFolderInInbox)

    I = 0
    ' controleer subfolder in mailbox op berichten en exit als er geen zijn
    If SubFolder.Items.Count = 0 Then
        MsgBox "Geen update in: " & OutlookFolderInInbox, _
            vbInformation, "Niets gevonden in Outlook"
          Set SubFolder = Nothing
          Set Inbox = Nothing
         Set ns = Nothing
        Exit Sub
    End If

    'mappen aanmaken
    If DestFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
          Set fs = CreateObject("Scripting.FileSystemObject")
                DestFolder = "D:\AANVRAAG\UPDATE"
           If Not fs.FolderExists(DestFolder) Then
            fs.CreateFolder DestFolder
        End If
    End If

    If Right(DestFolder, 1) <> "\" Then
        DestFolder = DestFolder & "\"
    End If

    ' controleer elk bericht op bijlage en extensies
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
        
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                FileName = DestFolder & Atmt.FileName
                Atmt.SaveAsFile FileName
                I = I + 1
              End If
        Next Atmt
    Next Item
    
    'mailbox leeg maken
    For Each Item In SubFolder.Items
     Item.Delete
    Next Item
    'omdat de file anders niet te vinden is deze noodgreep
                     Name "D:\AANVRAAG\UPDATE\update.xlsm" As "D:\aanvraag\update\updt.xlsm"
                     Name "D:\AANVRAAG\UPDATE\updt.xlsm" As "D:\aanvraag\update\update.xlsm"
Application.DisplayAlerts = True
    ' Show this message when Finished
    If I > 0 Then
       MsgBox "update gevonden", vbInformation, "Update in Outlook!"
             '

             Application.ScreenUpdating = False
    saveAsFileName = "D:\aanvraag\update\concept aanvraag.xlsm"
    
    ' folders aanmaken indien nodig

    
    folders = Split(saveAsFileName, "\")
       path = folders(0)
         For I = 1 To UBound(folders) - 1
        path = path & "\" & folders(I)
    If Dir(path, vbDirectory) = "" Then MkDir path
    Next
'controle op nieuw update bestand

     Set objFSB = CreateObject("Scripting.FileSystemObject")
      If objFSB.FileExists("D:\aanvraag\update\update.xlsm") Then GoTo line Else Exit Sub

line:
Workbooks.Open ("D:\aanvraag\update\update.xlsm")
          Application.ScreenUpdating = False
          
    saveAsFileName = "D:\aanvraag\update\conceptnw aanvraag.xlsm"
    
'beveiliging uitschakelen

 Workbooks("update.xlsm").Activate
    Dim ws As Worksheet
         For Each ws In ActiveWorkbook.Sheets
        ws.Unprotect Password:="peter"
    Next ws
'kopieer gegevens naar update
Workbooks("concept aanvraag.xlsm").Activate

Sheets("aanvraag").Range("a12:e200").Copy Destination:=Workbooks("update.xlsm").Sheets("aanvraag").Range("a12:e200")
Sheets("spoed aanvraag").Range("a12:e200").Copy Destination:=Workbooks("update.xlsm").Sheets("spoed aanvraag").Range("a12:e200")
Sheets("bijlage").Range("a2:n2000").Copy Destination:=Workbooks("update.xlsm").Sheets("bijlage").Range("a2:n2000")
Sheets("spoed bijlage").Range("a2:n2000").Copy Destination:=Workbooks("update.xlsm").Sheets("spoed bijlage").Range("a2:n2000")
Sheets("openstaand").Range("a2:f2000").Copy Destination:=Workbooks("update.xlsm").Sheets("openstaand").Range("a2:f2000")
Sheets("geleverd").Range("a2:g6000").Copy Destination:=Workbooks("update.xlsm").Sheets("geleverd").Range("a2:g6000")

Workbooks("update.xlsm").Activate
'beveiliging weer aanzetten
  Dim wb As Worksheet
       For Each wb In ActiveWorkbook.Sheets
        wb.Protect Password:="peter"
    Next wb
    
  ActiveWorkbook.SaveAs FileName:=saveAsFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
  
  ActiveWorkbook.Close
  
  'Hier moet "concept aanvraag.xslm" vervangen worden door de nieuwe update.xslm (conceptnw aanvraag.xslm) 
  'die dan weer concept aanvraag moet worden genoemd en bewaard in "D:\aanvraag\ " (waar het oude concept "aanvraag.xlsm "staat)

  
  
       
    Else
        MsgBox "Geen mail met bijlage.", vbInformation, "Klaar!"
    End If

      ' Error information
ThisMacro_err:
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
   Resume ThisMacro_exit
' Clear memory
ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Set fs = Nothing
    Set wsh = Nothing
    Exit Sub
    

End Sub

 

[edmoor]

Zet je code even in een code-tag zodat het juiste lettertype wordt gebruikt en de inspringpunten zichtbaar zijn. Zoals het er nu staat is het erg vervelend lezen en zal men het overslaan.

 

[PK58]

code tag

Hallo Edmoor,

bedankt voor de reactie

Ik heb de code tag toegevoegd.

mvg
Peter