I have created some buttons in outlook that moves emails to private
folders but the received date/time is changed to current date/time.

Can some help?



Sub buttons()
Public Function GetFolder(strFolderPath As String) As MAPIFolder
' folder path needs to be something like
' "Public Folders\All Public Folders\Company\Sales"
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long
On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function
Sub ItemMove(DestFolder As String)
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myDestFolder As Outlook.MAPIFolder
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myDestFolder = GetFolder(DestFolder)
' If myDestFolder = Nothing Then
' MsgBox "Folder '" & DestFolder & "' could not be found", ,
"Folder Not found"
' Else
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
For x = 1 To myOlSel.Count
myOlSel.Item(x).Move myDestFolder
Next x
Set myNameSpace = Nothing
Set myDestFolder = Nothing
' End If
End Sub
Sub TCMMove()
Call ItemMove("Personal Folders/TCM")
End Sub

Sub PrivateMove()
Call ItemMove("Personal Folders Private/Privat")
End Sub

Archived from group: microsoft>public>office>developer>outlook>vba