Problem exporting Outlook Mailboxes to a text file using VBScript

I am trying to write a script to export the names and locations of any mailboxes a user has defined in Outlook to a text file.  This script would be run each time they logon to their computer.  The text file would contain entries in this format...

Mailbox - User, John Q
Exchange store
Personal Folders

While we use Exchange, a lot of our users setup local PST files to archive old email.  When upgrading or re-imaging their computer, we would use this text file to make sure we transfer and reconnect any additional mailboxes.

I found and modified the code below and it works great as long as the user has an Outlook account defined.  To get the mailbox information, it looks like the script is actually (very quickly) opening and closing Outlook.  However, if the user doesn't have an Outlook account setup, they will get a generic Windows "Welcome to Outlook - Please setup you profile" dialog box.   This is a problem for two reasons.  First, we have a lot of users who move from one computer to another and we don't want this dialog box popping up whenever they logon to a new PC.  Second, we have a lot of users who don't have an email account at all so they would get this dialog prompt every time they logon to a computer.  

The problem appears to be with this line of code specifically...

For Each lo_folder In go_outlook.Session.Folders

How can I check if the user has an Outlook setup on that computer?  If they do, the script would run.  If not, the script would exit.   Alternatively, is there another way to accomplish the same goal?


'Turn on explicit variables
 Option Explicit
'Define Variables 
 Dim objFso, objShell, objFileHandle, BackupPath
 Dim go_fso, go_outlook, go_namespace 'go_ = Global Objects...
 Dim gl_folders, gl_files, gl_psts 'gl_ = Global Long integers
 Dim strMailBoxDataFileName
 Set objFso     =  wscript.CreateObject("scripting.filesystemobject")
 Set objShell   =  WScript.CreateObject("WScript.Shell")
 BackupPath = objShell.SpecialFolders("AppData")
 strMailBoxDataFileName = BackupPath & "\MailBox_Data.txt"
'Main Section
'Export Mailbox data to Mailbox_Data.txt 
 Call s_init()
 Call s_main()
Sub s_init()
 Set go_fso = CreateObject( "Scripting.FileSystemObject" )
 Set go_outlook = CreateObject( "Outlook.Application" )
 Set go_namespace = go_outlook.GetNameSpace( "MAPI" )
End Sub
Sub s_main()
 Dim lo_folder, ls_path 'lo_ = Local Objects, 'ls_ = Local Strings...
 DIM objFSO, objTextFile
 Set objFSO = CreateObject("Scripting.FileSystemObject")
 Set objTextFile = objFSO.CreateTextFile( strMailBoxDataFileName )
 For Each lo_folder In go_outlook.Session.Folders
   On Error Resume Next
      ls_path = GetStorePath( lo_folder.StoreID )
   'Catch (and ignore) any errors
    If (Err.Number <> 0) Then
       On Error GoTo 0
    End If
    On Error GoTo 0
   objTextFile.Write( lo_folder.Name & vbCrLf)
   objTextFile.Write( ls_path & vbCrLf)
End Sub
Function GetStorePath(strStoreID)
 Dim intStart
 Dim intEnd
 Dim strProvider
 Dim strPathRaw
 intStart = InStr(9, strStoreID, "0000") + 4
 intEnd = InStr(intStart, strStoreID, "00")
 strProvider = Mid(strStoreID, intStart, intEnd - intStart)
 strProvider = Hex2ToString(strProvider)
 Select Case LCase(strProvider)
    Case "mspst.dll", "pstprx.dll"
      If Right(strStoreID, 6) = "000000" Then
         intStart = InStrRev(strStoreID, "00000000") + 8
         strPathRaw = Mid(strStoreID, intStart)
         GetStorePath = Trim(Hex4ToString(strPathRaw))
         intStart = InStrRev(strStoreID, "000000") + 6
         strPathRaw = Mid(strStoreID, intStart)
         GetStorePath = Trim(Hex2ToString(strPathRaw))
      End If
   Case "msncon.dll"
      intStart = InStrRev(strStoreID, "00", Len(strStoreID) - 2) + 2
      strPathRaw = Mid(strStoreID, intStart)
      GetStorePath = Trim(Hex2ToString(strPathRaw))
   Case "emsmdb.dll"
      GetStorePath = "Exchange store"
   Case Else
      GetStorePath = "Unknown store path"
 End Select
End Function
Public Function Hex4ToString(Data)
 Dim strTemp
 Dim strAll
 Dim i
 For i = 1 To Len(Data) Step 4
    strTemp = Mid(Data, i, 4)
    strTemp = "&H" & Right(strTemp, 2) & Left(strTemp, 2)
    strAll = strAll & ChrW(Eval(strTemp))
 Hex4ToString = strAll
End Function
Public Function Hex2ToString(Data)
 Dim strTemp
 Dim strAll
 Dim i
 For i = 1 To Len(Data) Step 2
    strTemp = "&H" & Mid(Data, i, 2)
    strAll = strAll & ChrW(Eval(strTemp))
 Hex2ToString = strAll
End Function 
 Function TerminateScript()
 End Function

Open in new window

Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

William ElliottSr Tech GuruCommented:
i would setup a prf file on the box and add it in the startup of the default users profile, this way when a user logs onto a box for the first time they have their profile autoconfigured for them.

how to create prf

load the hive
c:\documents and setting\default user\ntuser.dat
using regedit.exe
and add this key

[HKEY_LOCAL_MACHINE\<default user profile>\Software\Microsoft\Windows\CurrentVersion\RunOnce]
"outlook"="outlook /importprf c:\\windows\\default.prf"
David LeeCommented:
Hi, HealthPartners.

I see two possible solutions to get this working.  First, instead of running this code from the login script, run it when Outlook launches.  That way it'll only run for staff who have an account and launch Outlook from a given computer.  Second, get Redemption (  It'll give you the ability to check for an Outlook profile.  If one exists, then run the rest of the script.  If not, then do nothing.
HealthPartnersAuthor Commented:
I like the idea of running the script when Outlook is launched.  Not only would it solve both issues, it would be faster as well.  Instead of Outlook opening and closing at startup as well as when the user actually opened it themselves, it would only be opened once.

I've never done that before, how would you recommend doing it?  Does Outlook have an option to run a script upon startup?
The Ultimate Tool Kit for Technolgy Solution Provi

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy for valuable how-to assets including sample agreements, checklists, flowcharts, and more!

David LeeCommented:
Outlook has an event that is triggered each time Outlook starts.  Actually, two events: Application_MAPILogonComplete and Application_Startup.  The former occurs when the user has logged into Outlook.  The latter occurs after Outlook has finished initializing, to include initializing all add-ins.  You could use either to run your code.  You could either insert all of your code in one of those event procedures or insert a command that calls your code.  I recommend the latter.  It'd allow you to keep the core code in a central location.  That would allow you to make changes to it and have those changes take effect immediately on all computers.  If you put the code in Outlook, then you'd have to modify the code on each computer.  

There is a downside to this approach.  Outlook does not have a means of distributing code.  The code will have to be manually added to each computer you want to run this on.  
Sub Application_Startup()
    'Your code or a call to your code goes here.
    Dim objShell As Object
    Set objShell = CreateObject("WScript.Shell")
    'Change the script name and path on the following line as needed
    objShell.Run "Cscript.exe C:\Some Folder\MyScript.vbs", 2, False
    Set objShell = Nothing
End Sub
Sub Application_MAPILogonComplete()
    'Same as above
End Sub

Open in new window


Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
HealthPartnersAuthor Commented:
This is perfect, thanks for your help!
David LeeCommented:
You're welcome!
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.