VBA forums?

[Dougmeister]

Ok, I know that it's not *real* programming <grin>, but I need to do some stuff in Outlook and need to know some good sites to go to for advice.

(Basic gist: VBA code to move emails from folder A on server to folder with same name in PST file)

I'll give more details here if you think it's appropriate, but I am also looking for suggestions of other sites.

Thanks in advance.

 

[Evadman]

(Basic gist: VBA code to move emails from folder A on server to folder with same name in PST file)

Can you expand on the project that you are trying to do? VBA has basically the same syntax, but figuring out the different objects between Microsoft programs can be annoying. I have done a decent amount with outlook and can probably help.

 

[Dougmeister]

I have a folder "ABC" in my mailbox on the Outlook server.

I have sub-folders named "ABC-1", "ABC-2", and "ABC-3".

I have rules/filters set up to move messages with the text "one" to ABC-1, "two" to "ABC-2", and "three" to "ABC-3".

I have an identical folder structure created in my "Personal Folders".

I would like to be able to read/process/etc. the emails in "ABC-1", then click a button that will:

* determine the name of the folder I am currently in
* grab all selected emails
* move them to the corresponding folder in the PST file

If it is easier, I can manually code the destination paths, but the real trick here is to have it all done by one piece of code, regardless of the folder/sub-folder you are in.

(Does that make sense?)

 

[Evadman]

Makes perfect sense. Below is a function I wrote that takes a group of selected emails and processes the attachments by saving them to disk, removing the attachment, and notating the save location in the body of the email.

This is really close to what you want to do, but instead of moving the attachment, you want to move the email itself. This bit will get you about 90% there. Do you know your way around vba?

Sub SaveAndRemoveAttachments()

    'Declaration
    Dim CurrentItems, CurrentItem, EmailAttachments, myAttachment As Object
    Dim SaveDirectory As String
    Dim myOlApp As New Outlook.Application
    Dim OutlookSess As Outlook.Explorer
    Dim SelectedEmails As Outlook.Selection
    Dim FSO As Object
    Dim FolderCheck() As String
    Dim Path As String
    
    'SecurityManager.DisableOOMWarnings = True
    
    'Ask for destination folder
    SaveDirectory = InputBox("Destination", "Save Attachments", "<a defailt location>")
    
    'leave if cancel pressed or no path passed in
    If SaveDirectory = "" Then
        Exit Sub
    End If
    SaveDirectory = Replace(SaveDirectory, "/", "\")
    
    'check here to see if folder exists.  If it doesn't use FSO to create it.
    Set FSO = CreateObject("Scripting.FileSystemObject")

    FolderCheck = Split(SaveDirectory, "\")
    For i = 0 To UBound(FolderCheck)
        Path = FSO.BuildPath(Path, FolderCheck(i))
        If FSO.FolderExists(Path) = False Then
            FSO.CreateFolder (Path)
        End If
    Next
    
    On Error Resume Next
    
    'work on selected items
    Set OutlookSess = myOlApp.ActiveExplorer
    Set SelectedEmails = OutlookSess.Selection
    
    'get the selected items
    For Each CurrentItem In SelectedEmails
        Set EmailAttachments = CurrentItem.Attachments
        If EmailAttachments.Count > 0 Then 'check if there are attachments
            'add removal header
            CurrentItem.Body = CurrentItem.Body & vbCrLf & vbCrLf & vbCrLf & "Removed Attachments:" & vbCrLf
            For i = 1 To EmailAttachments.Count    'remove each attachment and add message stating removed
                EmailAttachments(i).SaveAsFile SaveDirectory & DatePart("YYYY", CurrentItem.CreationTime) & Right("0" & DatePart("M", CurrentItem.CreationTime), 2) & Right("0" & DatePart("D", CurrentItem.CreationTime), 2) & "-" & Right("0" & DatePart("H", Now()), 2) & Right("0" & DatePart("N", CurrentItem.CreationTime), 2) & Right("0" & DatePart("S", CurrentItem.CreationTime), 2) & "_" & EmailAttachments(i).DisplayName
                CurrentItem.Body = CurrentItem.Body & "File: " & EmailAttachments(i).DisplayName & " To: " & SaveDirectory & DatePart("YYYY", CurrentItem.CreationTime) & Right("0" & DatePart("M", CurrentItem.CreationTime), 2) & Right("0" & DatePart("D", CurrentItem.CreationTime), 2) & "-" & Right("0" & DatePart("H", Now()), 2) & Right("0" & DatePart("N", CurrentItem.CreationTime), 2) & Right("0" & DatePart("S", CurrentItem.CreationTime), 2) & "_" & EmailAttachments(i).DisplayName & vbCrLf
            Next i
            
            'Remove attachment from email
            Do Until EmailAttachments.Count = 0
                If IsEmpty(EmailAttachments) Then
                    Exit Do
                End If
                'remove it (use this method in Outlook 2000)
                EmailAttachments(1).Delete 'EmailAttachments.Remove 1 for office XP
            Loop
            CurrentItem.Save 'save the email without attachment
        End If
    Next
    
    'cleanup
    Set CurrentItems = Nothing
    Set CurrentItem = Nothing
    Set EmailAttachments = Nothing
    Set myAttachment = Nothing
    Set myOlApp = Nothing
    Set OutlookSess = Nothing
    Set SelectedEmails = Nothing
    
    'SecurityManager.DisableOOMWarnings = False
End Sub

 

[Dougmeister]

Makes perfect sense. Below is a function I wrote that takes a group of selected emails and processes the attachments by saving them to disk, removing the attachment, and notating the save location in the body of the email.

This is really close to what you want to do, but instead of moving the attachment, you want to move the email itself. This bit will get you about 90% there. Do you know your way around vba?

Enough to hurt myself ;-)

I will take a look. Thanks!