Bypassing Outlook Security Warning

I wrote a macro to loop through all sub folders in a selected folder and to save the emails found to the hard drive (while keeping the same file heirarchy).

Some of my coworkers have 1000s of emails that they want to save, but the huge pst files become hard to manage. So this way they can have the files in a more familiar folder system and burn them to a CD easily.

It works fine, but it does take a while to run. I get the warning shown below and that is fine, but the longest time that I can set to allow access is 10 minutes which is not enough time. I would like to avoid having the user have to allow access several times.

So is there a simple way to just disable this feature (at least temporarily)? Or can the 10 minute setting be changed somewhere (in the registry perhaps)?

Thanks

Jake

Hi Jake :hi:

I don't think there is a way of disabling it, since it's the dreaded "Outlook Object Model Guard" which by co-incedence, I posted about earlier today (here).

Although I'm a bit confused since I wouldn't expect to see it as a result of just saving mail messages...
e.g this shouldn't trigger it:

Code:

---

Dim m As MailItem
Set m = CreateItem(olMailItem)
    m.SaveAs "c:\temp\test.msg", olMSG

---

Yea:

Code:

---

Set mItem = SubFolder.Items(j)
mItem.SaveAs StrFile, 3

---

I had mItem as Object, instead of MailItem, but changing the data type did nothing.

Here is the code in its entirety. Perhaps there is something that I am doing that triggers the warning, but there is an alternative that would not?

Code:

---

Option Explicit
 
Sub SaveAllEmails_ProcessAllSubFolders()
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim StrSubject As String
    Dim StrName As String
    Dim StrFile As String
    Dim StrReceived As String
    Dim StrSavePath As String
    Dim StrFolder As String
    Dim StrFolderPath As String
    Dim StrSaveFolder As String
    Dim Prompt As String
    Dim Title As String
    Dim iNameSpace As NameSpace
    Dim myOlApp As Outlook.Application
    Dim SubFolder As MAPIFolder
    Dim mItem As Object
    Dim FSO As Object
    Dim ChosenFolder As Object
    Dim Folders As New Collection
    Dim EntryID As New Collection
    Dim StoreID As New Collection
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set myOlApp = CreateObject("Outlook.Application")
    Set iNameSpace = myOlApp.GetNamespace("MAPI")
    Set ChosenFolder = iNameSpace.PickFolder
    If ChosenFolder = "" Then
        GoTo ExitSub:
    End If
    Prompt = "Please enter the path to save all the emails to."
    Title = "Folder Specification"
    StrSavePath = BrowseForFolder
    If StrSavePath = "" Then
        GoTo ExitSub:
    End If
    If Not Right(StrSavePath, 1) = "\" Then
        StrSavePath = StrSavePath & "\"
    End If
    Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
    If Not FSO.FolderExists("C:\Data\") Then
        FSO.CreateFolder ("C:\Data\")
    End If
    If Not FSO.FolderExists("C:\Data\Mail") Then
        FSO.CreateFolder ("C:\Data\Mail")
    End If
    For i = 1 To Folders.Count
        StrFolder = StripIllegalChar(Folders(i))
        n = InStr(3, StrFolder, "\") + 1
        StrFolder = Mid(StrFolder, n, 256)
        StrFolderPath = StrSavePath & StrFolder & "\"
        StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
        If Not FSO.FolderExists(StrFolderPath) Then
            FSO.CreateFolder (StrFolderPath)
        End If
        Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
        On Error Resume Next
        For j = 1 To SubFolder.Items.Count
            Set mItem = SubFolder.Items(j)
            StrReceived = ArrangedDate(mItem.ReceivedTime)
            StrSubject = mItem.Subject
            StrName = StripIllegalChar(StrSubject)
            StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
            StrFile = Left(StrFile, 256)
            mItem.SaveAs StrFile, 3
        Next j
        On Error GoTo 0
    Next i
    ExitSub:
End Sub
 
Function StripIllegalChar(StrInput)
    Dim RegX As Object
    Set RegX = CreateObject("vbscript.regexp")
    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
    RegX.IgnoreCase = True
    RegX.Global = True
    StripIllegalChar = RegX.Replace(StrInput, "")
    ExitFunction:
    Set RegX = Nothing
End Function
 
Function ArrangedDate(StrDateInput)
    Dim StrFullDate As String
    Dim StrFullTime As String
    Dim StrAMPM As String
    Dim StrTime As String
    Dim StrYear As String
    Dim StrMonthDay As String
    Dim StrMonth As String
    Dim StrDay As String
    Dim StrDate As String
    Dim StrDateTime As String
    Dim RegX As Object
    Set RegX = CreateObject("vbscript.regexp")
    If Not Left(StrDateInput, 2) = "10" And _
        Not Left(StrDateInput, 2) = "11" And _
        Not Left(StrDateInput, 2) = "12" Then
        StrDateInput = "0" & StrDateInput
    End If
    StrFullDate = Left(StrDateInput, 10)
    If Right(StrFullDate, 1) = " " Then
        StrFullDate = Left(StrDateInput, 9)
    End If
    StrFullTime = Replace(StrDateInput, StrFullDate & " ", "")
    If Len(StrFullTime) = 10 Then
        StrFullTime = "0" & StrFullTime
    End If
    StrAMPM = Right(StrFullTime, 2)
    StrTime = StrAMPM & "-" & Left(StrFullTime, 8)
    StrYear = Right(StrFullDate, 4)
    StrMonthDay = Replace(StrFullDate, "/" & StrYear, "")
    StrMonth = Left(StrMonthDay, 2)
    StrDay = Right(StrMonthDay, Len(StrMonthDay) - 3)
    If Len(StrDay) = 1 Then
        StrDay = "0" & StrDay
    End If
    StrDate = StrYear & "-" & StrMonth & "-" & StrDay
    StrDateTime = StrDate & "_" & StrTime
    RegX.Pattern = "[\:\/\ ]"
    RegX.IgnoreCase = True
    RegX.Global = True
    ArrangedDate = RegX.Replace(StrDateTime, "-")
    ExitFunction:
    Set RegX = Nothing
End Function
 
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)
    Dim SubFolder As MAPIFolder
    Folders.Add Fld.FolderPath
    EntryID.Add Fld.EntryID
    StoreID.Add Fld.StoreID
    For Each SubFolder In Fld.Folders
        GetFolder Folders, EntryID, StoreID, SubFolder
    Next SubFolder
    ExitSub:
    Set SubFolder = Nothing
End Sub
 
Function BrowseForFolder(Optional OpenAt As String) As String
    Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then
                BrowseForFolder = ""
            End If
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then
                BrowseForFolder = ""
            End If
        Case Else
            BrowseForFolder = ""
    End Select
    ExitFunction:
    Set ShellApp = Nothing
End Function

---

Jake,

Have you tried Outlook redemption? I think that it's license allows internal/development use, although you'd have to check on that. Alternately, there is a program called Clickyes that I've used in the past. It works, but it does pause for a while to allow the warning to be cleared.

Alternately, can you run the routine from within Outlook itself? The warning is thrown because you're creating a new instance from outside. I don't think you'd get hit if you did it in Outlook alone.

I have run the macro from Outlook Tools | Macro | Macros... and also directly from the VBE, but I get the warning regardless.

Thanks

Indeed, Ken is right - it's the creation of the new Outlook instance that's triggering the Object Model Guard (which I just noticed has the most appropriate acronym of all time - OMG :biglaugh: )
Since you're running this fron Outlook, there's no need to create a new object, you can just assign the existing app

Code:

---

'Set myOlApp = CreateObject("Outlook.Application")
'should be
Set myOlApp = Application

---

Making that change should prevent the message

Despite the fact that it appears in many examples all over the web,

Code:

---

Set myOlApp = CreateObject("Outlook.Application")

---

will not create a new instance if there is already one running and, in a macro in Outlook, does exactly the same as

Code:

---

Set myOlApp = Application

---

I have to disagree with the others, I'm afraid, I don't think you can stop the message, just reply to it - manually or with ClickYes or equivalent.

Quote:

---

Originally Posted by TonyJollans

Despite the fact that it appears in many examples all over the web,

Code:

---

Set myOlApp = CreateObject("Outlook.Application")

---

will not create a new instance if there is already one running and, in a macro in Outlook, does exactly the same as

Code:

---

Set myOlApp = Application

---

---

Indeed, Outlook is a single instance app so CreateObject returns a reference to an existing session but while the two methods return the same object, they don't appear to do the same thing i.e. the method differs.
My theory is that it is the method that CreateObject employs (making an external check for the running instance and coming back from "outside" to reference it) that appears to be triggering the OMG

My evidence to support the theory is that when I change Jake's code to "Set myOlApp = Application" I don't get the message. (OL2003, WinXP sp2)
Presumably, setting the object variable directly to "Application" doesn't make any external call to the OMG isn't disturbed. It's effectively the same difference between early and late binding.

This is all speculation, since I can't find any documentation to support it. As Tony rightly points out, CreateObject is used in just about every example published, including those by M$, but frankly, that doesn't make it right.
If you can access an object directly to set a variable, I can't think of any reason why you would need to make a function call to return it instead.

Having said that, different versions of OL (or different service packs/security updates) may be effecting the outcome.

Hi Killian,

You are correct - just checked (OL 2003, XP Pro SP1). Very interesting.

The message is triggered by the SaveAs and, according to Help you've got no choice in the matter. Clearly that is not quite correct but I don't understand what happens.

Ok, so there may be hope. :) I'll check this in a few hours when I get into work.

You know I didn't even think about why CreateObject was being used. I don't code in OL much (thankfully). :)

Thanks

Quote:

---

Originally Posted by Killian

...the Object Model Guard (which I just noticed has the most appropriate acronym of all time - OMG :biglaugh: )

---

ROFL! I never noticed that!

Removing the CreateObject did the trick.

Thanks :)

Sorry Jake. In a roundabout way, that's what I was trying to suggest. I guess I forgot to turn on my "option explicit". ;)

Glad you got it sorted.

I don't use outlook much but Jakes script from post 4 works great and I can see a use for it..could you add it to the kb?

Submitted