Autmatisch runnen VBA

[Fermacelli]

Beste kenners,

Ik heb de onderstaande code geschreven voor het volgende:

Dagelijks krijg ik een voorraaddump van mijn Warehouse Management Systeem welke automatisch in de Outlook map "Dumps" geplaatst.
Nu heb ik de code via een website gevonden welke het mogelijk maakt dit Excel bestand automatisch te verplaatsen naar een map op de C schijf, genaamd "Dump". Dit werkt en is voor mij als VBA leek als een 'overwinning', maar hopelijk is er nog meer mogelijk .

Is het mogelijk een code toe te voegen dat als Outlook opstart, dit automatisch wordt uitgevoerd? Dat ik dus niet meer de code hoef te runnen via het VBA menu?

Kan iemand van jullie me wellicht helpen?


Codering:

Sub GetAttachments()

On Error GoTo GetAttachments_err

Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0

Dim SubFolder As MAPIFolder

Set SubFolder = Inbox.Folders("Dumps")

If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If

For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
FileName = "C:\Users\kmarcell\Dump\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item

If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into your selected folder." _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, _
"Finished!"
End If

GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub


GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
Exit Sub


End Sub

 

[edmoor]

Zet de routine in Outlook en dan dit in de ThisOutlookSession sectie:
Call GetAttachments()

Daarnaast zou je, gezien de lengte van je lidmaatschap toch moeten weten dat code in codetags geplaatst hoort te worden :d

 

[Fermacelli]

De routine "Call GetAttachments()" heb ik in Outlook -> ThisOutlookSession gezet zoals in de afbeelding te zien valt.
Bij het opstarten van Outlook vindt de run echter nog niet plaats.

Wat doe ik verkeerd :shocked:?

 

[Warme bakkertje]

Zal eerder zoiets zijn.

Private Sub Application_Startup()

    Call GetAttachments
    
End Sub

 

[edmoor]

Precies. En zorg dat in het vertrouwenscentrum het gebruik van Macro's ingeschakeld is.

 

[snb]

En laat 'Call' achterwege.

 

[snb]

Deze code is overigens voldoende:

Private Sub Application_Startup()
    For Each it In GetNamespace("MAPI").GetDefaultFolder(6).Folders("dump").items
      For Each at In it.attachments
         at.SaveAsFile "C:\Users\kmarcell\Dump\" & at.FileName
      Next
    Next
End Sub

en je kunt hem natuurlijk ook automatisch starten als je Excel opent:

Private Sub Workbook_open()
    For Each it In createobject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(6).Folders("dump").items
      For Each at In it.attachments
         at.SaveAsFile "C:\Users\kmarcell\Dump\" & at.FileName
      Next
      it.delete
    Next
End Sub

 

[Fermacelli]

Dank jullie allen. Question solved

@Edmoor - Vertrouwenscentrum had ik inderdaad ook ergens anders gelezen. Thx