I have an Outlook public folder with 2000+ contacts in custom forms. I am basically using the MS code for programmatically exporting OL items to Access (support.microsoft.com/?kbid=290792), modified to incl. custom form data, with the addition of loading ExpressClickYes to bypass OL security prompt and the quit command to regularly clear the memory (5-20 worked well).
Since my machine was upgraded from XP to Win7 and O2003 to O2007, the script no longer works. It appears that only the first batch of items is imported into Access, then the script just hangs (no error message, Outlook is again in the task manager). Without setting an interval for quitting OL, my script crashes around 214-217 items.
I've also read that you can set the registry to clear memory at certain amounts of items (support.microsoft.com/kb/293797), but that does not seem to make a difference. I'm setting all appropriate variables to Nothing right after the rst.Update command.
If you have any thoughts to point me in the right direction, please let me know. I'm posting the full code below with comments about the errors received. Thanks in advance.
Since my machine was upgraded from XP to Win7 and O2003 to O2007, the script no longer works. It appears that only the first batch of items is imported into Access, then the script just hangs (no error message, Outlook is again in the task manager). Without setting an interval for quitting OL, my script crashes around 214-217 items.
I've also read that you can set the registry to clear memory at certain amounts of items (support.microsoft.com/kb/293797), but that does not seem to make a difference. I'm setting all appropriate variables to Nothing right after the rst.Update command.
If you have any thoughts to point me in the right direction, please let me know. I'm posting the full code below with comments about the errors received. Thanks in advance.
Code:
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const WM_DESTROY = &H2
Private Declare Function RegisterWindowMessage _
Lib "user32" Alias "RegisterWindowMessageA" _
(ByVal lpString As String) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As Any, _
ByVal lpWindowName As Any) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
' Code above is to assist in starting/closing Express ClickYes utility
' to bypass Outlook security prompt
Public Function ImportContacts()
' This code is based in Microsoft Access.
'On Error GoTo ErrorHandler
' Set up for ExpressClickYes (bypass outlook security prompt):
Debug.Print "setting up dims"
Dim wnd As Long
Dim uClickYes As Long
Dim Res As Long
' Set up DAO objects (uses existing "CoMA-new" table):
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("CoMA-new")
' Set up Outlook objects:
Dim ol As New outlook.Application
Dim olns As outlook.Namespace
Dim cf As outlook.MAPIFolder
Dim c As outlook.ContactItem
Dim objItems As outlook.Items
Dim Prop As outlook.UserProperty
' Set up ErrorHandler objects:
Dim errNumber As Integer
Dim errDescription As String
Dim errSource As String
Dim strMsg As String
' Let user select a folder to export - exit script if no folder is selected:
Set olns = ol.GetNamespace("MAPI")
Set cf = olns.PickFolder
If cf Is Nothing Then
Exit Function
End If
Set objItems = cf.Items
' Test whether default type of selected folder are contacts - display message and exit script if not:
If cf.DefaultItemType <> olContactItem Then
MsgBox "Folder is not a contacts folder."
Exit Function
End If
' Test whether selected folder contains any contact items - display number of items; or display message and exit script if not (see bottom):
Debug.Print "counting contact items"
iNumContacts = objItems.Count
If iNumContacts <> 0 Then
MsgBox "Processing " & iNumContacts & " Contacts. This may take a while."
' Start Express ClickYes program to bypass Outlook security warning:
Debug.Print "starting express clickyes"
If Not fEnumWindows("Express ClickYes 1.2") Then
Call Shell("C:\Program Files\Express ClickYes\ClickYes.exe", 1)
DoEvents
End If
uClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME")
wnd = FindWindow("EXCLICKYES_WND", 0&)
Res = SendMessage(wnd, uClickYes, 1, 0)
' Ask at what number to begin and at which interval to quit and restart Outlook process:
cTitle1 = "CoMA Backups"
cMessage1 = "Please enter at which contact number to start the backup (I - 1 unless backup crashed previously):"
cInput1 = InputBox(cMessage1, cTitle1)
cMessage2 = "Please enter at which interval items should be processed (Q - 5-20 recommended):"
cInput2 = InputBox(cMessage2, cTitle1)
' Start loop through all items in the folder, starting at the designated contact number (cInput1)
For I = cInput1 To iNumContacts 'instead of "For I = 1 To iNumContacts"
Debug.Print "Starting to loop through contacts with number " & I
' Quit Outlook process after every "q" items that have been processed (to clear memory):
Q = cInput2
If I / Q = Int(I / Q) Then
Debug.Print "Quitting Outlook at predetermined interval."
ol.quit
'Sleep (1000) 'suspends Program execution for 1 seconds
End If
' Check if the current item is based on the proper custom form:
Debug.Print "checking proper form in outlook"
If objItems(I).MessageClass = "IPM.Contact.CoMA" Then 'ERROR 462: remote server machine does not exist or is unavailable (only if using SLEEP above)
Debug.Print "setting c=objItems(I)"
Set c = objItems(I) 'Outlook hangs or ERROR: remote procedure call failed"
' Add new row in Access table and write standard form data to it:
Debug.Print "adding row and writing standard form data"
rst.AddNew
rst!Title = c.Title 'another error location
rst!FirstName = c.FirstName
rst!Middle = c.MiddleName
rst!LastName = c.LastName
rst!Suffix = c.Suffix
rst!CompanyName = c.CompanyName
rst!JobTitle = c.JobTitle
rst!Department = c.Department
rst!Street = c.MailingAddressStreet
rst!City = c.MailingAddressCity
rst!StateOrProvince = c.MailingAddressState
rst!PostalCode = c.MailingAddressPostalCode
rst!Country = c.MailingAddressCountry
rst!WorkPhone = c.BusinessTelephoneNumber
rst!MobilePhone = c.MobileTelephoneNumber
rst!OtherPhone = c.OtherTelephoneNumber
rst!FaxNumber = c.BusinessFaxNumber
rst!Email1 = c.Email1Address
rst!Email2 = c.Email2Address
rst!Email3 = c.Email3Address
rst!URL = c.WebPage
rst!IM = c.IMAddress
rst!Comments = c.Body
' Write custom form properties to DB:
Debug.Print "writing custom form properties"
rst!ContactType = c.UserProperties("Contact Type")
rst!ContactStatus = c.UserProperties("Contact Status")
rst!OptedOut = c.UserProperties("Opted-Out")
rst!OptedIn = c.UserProperties("Opted-In")
rst!CLUE = c.UserProperties("CLUE Email")
rst!Holidays = c.UserProperties("Holidays")
rst!Special = c.UserProperties("Special")
rst!Agreement = c.UserProperties("Agreement")
rst!W9 = c.UserProperties("W-9")
rst!Resume = c.UserProperties("Resume")
rst!Samples = c.UserProperties("Samples")
rst!VOICE = c.UserProperties("Voice")
rst!OtherSoftware = c.UserProperties("Software")
rst!Fees = c.UserProperties("Fees")
rst!PayPal = c.UserProperties("PayPalBox")
rst!ATAStatus = c.UserProperties("ATA accreditation/credentials")
rst!OtherCredentials = c.UserProperties("Credentials")
rst!ChangeDate = c.UserProperties("ChangeDate2")
rst!ChangeUser = c.UserProperties("ChangeUser")
' Write data from custom multi-select fields (Languages, Specialties, Industries and Translation Software):
' Split up "Set TransSoft = c.GetInspector.ModifiedFormPages.Item("General").Controls("TransSoft")":
Set MyInspector = c.GetInspector
Set GenPage = MyInspector.ModifiedFormPages.Item("General")
Set SourceLang = GenPage.Controls("SourceLang")
Set TargetLang = GenPage.Controls("TargetLang")
Set Specialties = GenPage.Controls("Specialties")
Set Industries = GenPage.Controls("Industries")
Set TransSoft = GenPage.Controls("TransSoft")
' Arrange all selected fields for "Source Language" in a string, write result to DB, and clean up:
strSourceLang = ""
For J = 0 To (SourceLang.ListCount - 1)
If SourceLang.Selected(J) Then
arr = SourceLang.List(J)
strSourceLang = strSourceLang & arr & " - "
End If
Next
rst!SourceLanguages = strSourceLang
Set SourceLang = Nothing
Set GenPage = Nothing
Set MyInspector = Nothing
' Arrange all selected fields for "Target Language" in a string, write result to DB, and clean up:
strTargetLang = ""
For J = 0 To (TargetLang.ListCount - 1)
If TargetLang.Selected(J) Then
arr = TargetLang.List(J)
strTargetLang = strTargetLang & arr & " - "
End If
Next
rst!TargetLanguages = strTargetLang
Set TargetLang = Nothing
Set GenPage = Nothing
Set MyInspector = Nothing
' Arrange all selected fields for "Specialties" in a string, write result to DB, and clean up:
strSpecialties = ""
For J = 0 To (Specialties.ListCount - 1)
If Specialties.Selected(J) Then
arr = Specialties.List(J)
strSpecialties = strSpecialties & arr & " - "
End If
Next
rst!Specialties = strSpecialties
Set Specialties = Nothing
Set GenPage = Nothing
Set MyInspector = Nothing
' Arrange all selected fields for "Industries" in a string, write result to DB, and clean up:
strIndustries = ""
For J = 0 To (Industries.ListCount - 1)
If Industries.Selected(J) Then
arr = Industries.List(J)
strIndustries = strIndustries & arr & " - "
End If
Next
rst!Industries = strIndustries
Set Industries = Nothing
Set GenPage = Nothing
Set MyInspector = Nothing
' Arrange all selected fields for "Translation Software" in a string, write result to DB, and clean up:
strTransSoft = ""
For J = 0 To (TransSoft.ListCount - 1)
If TransSoft.Selected(J) Then
arr = TransSoft.List(J)
strTransSoft = strTransSoft & arr & " - "
End If
Next
rst!TranslationSoftware = strTransSoft
Set TransSoft = Nothing
Set GenPage = Nothing
Set MyInspector = Nothing
' Finish row in Access DB (?):
rst.Update
' Clean up:
Set c = Nothing
Set MyInspector = Nothing
Set GenPage = Nothing
Set SourceLang = Nothing
Set TargetLang = Nothing
Set Specialties = Nothing
Set Industries = Nothing
Set TransSoft = Nothing
Debug.Print "finished writing to access"
End If
' Return to beginning of the loop (next item):
Next I
' Close Access table after exporting all items:
rst.Close
MsgBox "Finished."
' Quit Outlook process:
Debug.Print "Quit Outlook."
ol.quit
' Suspend and Close Express ClickYes program to stop bypassing Outlook security warning:
Res = SendMessage(wnd, uClickYes, 0, 0)
Res = SendMessage(wnd, WM_DESTROY, 0, 0)
' Clean up:
Set rst = Nothing
Set olns = Nothing
Set cf = Nothing
Set objItems = Nothing
Set c = Nothing
Set MyInspector = Nothing
Set GenPage = Nothing
Set SourceLang = Nothing
Set TargetLang = Nothing
Set Specialties = Nothing
Set Industries = Nothing
Set TransSoft = Nothing
Set ol = Nothing
Set Prop = Nothing
Exit Function
' No contacts in the folder:
Else
MsgBox "No contacts to export."
' Suspend and Close Express ClickYes program to stop bypassing Outlook security warning:
Res = SendMessage(wnd, uClickYes, 0, 0)
Res = SendMessage(wnd, WM_DESTROY, 0, 0)
' Clean up:
Set rst = Nothing
Set olns = Nothing
Set cf = Nothing
Set objItems = Nothing
Set c = Nothing
Set MyInspector = Nothing
Set GenPage = Nothing
Set SourceLang = Nothing
Set TargetLang = Nothing
Set Specialties = Nothing
Set Industries = Nothing
Set TransSoft = Nothing
Set ol = Nothing
Set Prop = Nothing
Exit Function
End If
ErrorHandler:
' Error Message:
strMsg = "Error number: " & Err.Number & vbCrLf
strMsg = strMsg & "Error message: " & Err.Description & vbCrLf
strMsg = strMsg & "Error source: " & Err.Source
MsgBox strMsg, vbOKOnly + vbCritical, "Error"
' Suspend and Close Express ClickYes program to stop bypassing Outlook security warning:
Res = SendMessage(wnd, uClickYes, 0, 0)
Res = SendMessage(wnd, WM_DESTROY, 0, 0)
' Clean up:
Set rst = Nothing
Set olns = Nothing
Set cf = Nothing
Set objItems = Nothing
Set c = Nothing
Set TransSoft = Nothing
Set SourceLang = Nothing
Set TargetLang = Nothing
Set Specialties = Nothing
Set Industries = Nothing
Set GenPage = Nothing
Set MyInspector = Nothing
Set ol = Nothing
Set Prop = Nothing
Exit Function
End Function
