Email kopieren naar map op server

Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "c:\users\Krist\Downloads\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
End Sub

'Save Selected E-Mails As Outlook Msg Files
'
'This program saves selected Outlook Inbox e-mail items
'as Outlook Msg files in a user-specified location.

'The Msg file name is the same as the e-mail subject line cleaned
'of illegal characters by the function CleanString(strData).

'In this example program I have appended a random number To the Msg file
'name To prevent overwriting of existing like e-mail subject lines.

'MSDN SaveAs method web page
'http://msdn.microsoft.com/en-us/library/aa210279%28office.11%29.aspx

'Thanks to SS. Kanagal, Jr. for key ideas enabeling me to solve the problem.

Option Explicit

' Declare variables.
Dim objOutlook, objNamespace, objFolder
Dim strScriptPath, strScriptName, strScriptFolder, olMSG
Dim objItem, j, SelectionStringStartPos, lngCount, intAttach
Dim EMailSubjectString, SelectionString, TempSubjectString
Dim SaveAsFilePath, Results

'vbBinaryCompare = 0
'vbTextCompare   = 1

Const olFolderInbox = 6

olMSG            = 3

SelectionString = "FW: "        'String to look for in e-mail subject line
SaveAsFilePath  = "C:\TMP\ZZZ\"    'Folder path to store e-mails

Randomize    'Initialize random number generator

' Determine local path.
strScriptPath   = Wscript.ScriptFullName
strScriptName   = Wscript.ScriptName
strScriptFolder = Left(strScriptPath, Len(strScriptPath) - Len(strScriptName) - 1)

' Retrieve Outlook Inbox folder.
Set objOutlook   = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")

Set objFolder    = objNameSpace.GetDefaultFolder(olFolderInbox)

' Enumerate messages in Inbox.
Results        = "" 'Initialize debug text buffer (technically not needed)
lngCount       = objFolder.Items.Count
For j          = lngCount To 1 Step - 1

   Set objItem             = objFolder.Items(j)
   EMailSubjectString      = objFolder.Items(j)
   SelectionStringStartPos = Instr(UCase(EMailSubjectString), SelectionString)    'Search for string  

   If SelectionStringStartPos > 0 Then    'E-Mail subject line contains selection string
   
      TempSubjectString = CleanString(EMailSubjectString) 'Clean e-mail subject line of invalid characters, etc.
      TempSubjectString = TempSubjectString & " (" & Int(100000*Rnd()) & ")" 'Create Msg file name
      objFolder.Items(j).SaveAs SaveAsFilePath &  TempSubjectString & ".Msg", olMSG 'Save the e-mail
      Results = Results & TempSubjectString & vbCrLf 'Debug statement

   End If

Next 'j

'Clean Up.
Set objOutlook   = Nothing
Set objNamespace = Nothing
Set objFolder    = Nothing
Set objItem      = Nothing

Wscript.Echo Results 'Debug statement
Wscript.Quit

'################################################################
'This function cleans the e-mail subject of invalid or
'undesirable characters
'Source: http://www.outlookcode.com/codedetail_print.aspx?id=827
'################################################################
Function CleanString(strData)
    'Replace invalid strings.

    strData = Replace(strData, "´",   "'")
    strData = Replace(strData, "`",   "'")
    strData = Replace(strData, "{",   "(")
    strData = Replace(strData, "[",   "(")
    strData = Replace(strData, "]",   ")")
    strData = Replace(strData, "}",   ")")
    strData = Replace(strData, "  ",  " ")    'Replace two spaces with one space
    strData = Replace(strData, "   ", " ")    'Replace three spaces with one space    
    'Cut out invalid signs.
    strData = Replace(strData, ": ",  "_")    'Colan followded by a space
    strData = Replace(strData, ":",   "_")    'Colan with no space
    strData = Replace(strData, "/",   "_")
    strData = Replace(strData, "\",   "_")
    strData = Replace(strData, "*",   "_")
    strData = Replace(strData, "?",   "_")
    strData = Replace(strData, """",  "'")
    strData = Replace(strData, "<",   "_")
    strData = Replace(strData, ">",   "_")
    strData = Replace(strData, "|",   "_")
    CleanString = Trim(strData)
End Function

'This program may be easily modified to save e-mails in other file format types such as:
'olDoc(4), olHTML(5), olMSG(3), olRTF(1), olTemplate(2), olTXT(0), olVCal(7), or olVCard(6)

'Other Outlook folders can be accessed using the appropriate constants such as:
'Const olFolderDeletedItems = 3
'Const olFolderOutbox = 4
'Const olFolderSentMail = 5
'Const olFolderInbox = 6
'Const olFolderDrafts = 16
'Const olFolderJunk = 23

[COLOR=#000000][FONT=Consolas]Private WithEvents Items As Outlook.Items[/FONT][/COLOR]
Private Sub Application_Startup()
  Dim Ns As Outlook.NameSpace
  Set Ns = Application.GetNamespace("MAPI")
  Set Items = Ns.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
  If TypeOf Item Is Outlook.MailItem Then
    SaveMailAsFile Item
  End If
End Sub

Private Sub SaveMailAsFile(oMail As Outlook.MailItem)
  Dim dtDate As Date
  Dim sName As String
  Dim sFile As String
  Dim sExt As String
  
  sPath = "d:\mails"
  sExt = ".msg"
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "_"
  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & sExt

  oMail.SaveAs sPath & sName, olSaveAsMsg 
End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr) [COLOR=#000000][FONT=Consolas]End Sub[/FONT][/COLOR]