title: Moving emails into shared mailbox
body: <p>I need some help with a problem, we have a shared mailbox at work and I have some VBA that will modify the subject line of the email once it has been read and at the press of a button.</p>
  
  <p>This issue is the current code wont move the email to a sub folder within that mailbox.</p>
  
  <p>Attached is the code I have, I'm not very good at VBA so this has been developed with help from others. </p>
  
  <pre><code>Sub ForAction()
  
  'Declaration
  Dim myOlApp As New Outlook.Application
  Dim myOlExp As Outlook.Explorer
  Dim myOlSel As Outlook.Selection
  Dim strRawSubj
  Dim strNewSubj1
  Dim strNewSubj2
  Dim strNewSubj3
  Dim ns As Outlook.NameSpace
  Dim moveToFolder As Outlook.MAPIFolder
  Dim myItems, myItem As Object
  'Dim MyData As Object
  
  'On Error Resume Next
  
  'work on selected items
  Set myOlExp = myOlApp.ActiveExplorer
  Set myOlSel = myOlExp.Selection
  Set ns = Application.GetNamespace("MIPI")
  Set moveToFolder = ns.Folders("new.orders@domain.com.au").Folders("Inbox").Folders("01 Assigned Tickets")
  
  'for all items do...
  For Each myItem In myOlSel
  
    strDate = myItem.SentOn
    If strDate = "" Then
      strDate = "0"
      Else
         If strDate = "4501/01/01" Then
         moddate = myItem.LastModificationTime
      mod2date = Format(moddate, "yyyymmdd:hhmm")
      newdate = mod2date &amp; "-UNSENT"
      Else
   ' DE - date format of yyyymmdd:hhmm - includes minutes and seconds - eg 20100527:1215
     strNewDate = Format(strDate, "yyyymmdd:hhmm")
      End If
    End If
    ' DE - Strip the [SEC= from the Subject line, remove RE: and FW:, then trim to max 50 char
    strRawSubj = myItem.Subject
    If strRawSubj = "" Then
      strRawSubj = "Receipt"
      Else
       ' GP - Check for Id
  If InStr(strRawSubj, "ForActionEmail-") &gt; 0 Then GoTo Terminate
  
       strNewSubj1 = Left(strRawSubj, NumA)
          ' DE - Headers with no Email Id were being eaten, so a workaround for that
          If strNewSubj1 = "" Then
          strNewSubj1 = strRawSubj
          End If
      ' DE - Remove FW and RE prefixes
      strNewSubj2 = Replace(strNewSubj1, "FW: ", "", , 1, vbTextCompare)
      strNewSubj3 = Replace(strNewSubj2, "RE: ", "", , 1, vbTextCompare)
      ' DE - Trim subject to 150 chars to be reasonable - should be plenty unless people are writing a book
      strShortSubj = Left(strNewSubj3, 150)
    End If
  
    strname = strNewDate &amp; "-" &amp; "ForActionEmail-" &amp; strShortSubj 
  
  Set MyData = NewObject
  MyData.SetText strname
  'MyData.PutInClipboard
  myItem.Subject = strname
  myItem.Save
  myItem.move moveToFolder
  
  
  Next
  
  SaveMessagesEnd:
  
  'free variables
  Set myItems = Nothing
  Set myItem = Nothing
  Set myOlApp = Nothing
  Set myOlExp = Nothing
  Set myOlSel = Nothing
  
  Exit Sub
  
  ErrorHandler:
  Exit Sub
  
  Terminate:
  End Sub
  </code></pre>