Solved: 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 coincedence, 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:[VBA]Dim m As MailItem

Set m = CreateItem(olMailItem)
m.SaveAs "c:\temp\test.msg", olMSG[/VBA]

Yea:

[vba]
Set mItem = SubFolder.Items(j)
mItem.SaveAs StrFile, 3
[/vba]

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?

[vba]
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
[/vba]

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[VBA]'Set myOlApp = CreateObject("Outlook.Application")
'should be
Set myOlApp = Application[/VBA]Making that change should prevent the message

Despite the fact that it appears in many examples all over the web,[vba]Set myOlApp = CreateObject("Outlook.Application")[/vba]will not create a new instance if there is already one running and, in a macro in Outlook, does exactly the same as[vba]Set myOlApp = Application[/vba]

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,[vba]Set myOlApp = CreateObject("Outlook.Application")[/vba]will not create a new instance if there is already one running and, in a macro in Outlook, does exactly the same as[vba]Set myOlApp = Application[/vba]

---

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 threoy 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