We help IT Professionals succeed at work.
Get Started

VBS copying Outlook Contact items from Public Folder

PaulRKrueger asked
Last Modified: 2012-05-09
I'm using the following script to copy contact items from a public folder to a user's private folder. It works just fine. I do have a request. Starting on line 133, the script copies the contact, marks it as unread, and then moves the contact to the user's private folder.

I would like this behavior changed. The problem I have is that I have to allow all of my users the ability to create contacts in the public folder for this to work. Additionally, if multiple users are running the script at the same time, some of them will pick up a duplicate contact here or there. What do I need to do to have it duplicate the contact in their private folder without creating a copy in the public folder first?

If you don't want to wade through the whole code below here's the significant portion:

For intIndex = olkPublic.Items.count To 1 Step -1
                    Set olkContact = olkPublic.Items(intIndex).Copy
                  olkContact.Unread = "False"
                    olkContact.Move olkContacts

' Written by 
' This script is called by its companion script TBCUpdate.vbs and performs the 
' actual creation, comparison, and updating of the user's TBC Directory.
' The TBC Directory is populated from the TBC Directory public folder. That 
' folder is populated via a scheduled task that runs on 
' The scheduled task is called "Update TBC Directory Public Folder" and runs
' TBC Directory Update\UpdatePublicFolder\Adfind.bat" at 12:00 am daily.

' *** Check to see if the user is a member of the GPO_NoOLContacts group ***
Dim objADObject, strGroup, objGroupList, objSysInfo, strUser, objUser, wshNetwork

' Bind to the user object in Active Directory with the LDAP provider.
Set objSysInfo = CreateObject("ADSystemInfo")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
Set objADObject = GetObject(objUser.AdsPath)
Set wshNetwork = CreateObject("WScript.Network") 

'strGroup = "GPO_NoOLContacts"
'If IsMember(strGroup) Then
'	wscript.quit 
'End If

if weekday(date) = vbsunday then
	moddate = -4
end if

if weekday(date) = vbmonday then
	moddate = -5
end if

if weekday(date) = vbtuesday then
	moddate = -6
end if

if weekday(date) = vbwednesday then
	moddate = 0
end if

if weekday(date) = vbthursday then
	moddate = -1
end if

if weekday(date) = vbfriday then
	moddate = -2
end if

if weekday(date) = vbsaturday then
	moddate = -3
end if

Set wshShell = WScript.CreateObject( "WScript.Shell" )
strComputerName = wshShell.ExpandEnvironmentStrings( "%COMPUTERNAME%" )

Set objFSO = CreateObject("Scripting.FileSystemObject")
filedate = DateAdd("d", moddate, Date())
filedate = Replace(filedate,"/","-")
filename = "g:\TBC Directory - updated " & filedate & ".txt"
Set objFile = objFSO.OpenTextFile(filename,8)
objFile.WriteLine(Now() & " Running PublictoPrivate.vbs from machine: " & strComputerName)

Const olFolderContacts = 10
Const olPublicFoldersAllPublicFolders = 18 
Dim olkApp, olkSes, olkContacts, olkPublic, olkContact, intIndex, olPV, olkPublicVersion, plkPersonalVersion
Wscript.echo "Checking TBC Directory."
Set olkApp = CreateObject("Outlook.Application")
Set olkSes = olkApp.GetNamespace("MAPI")

' Find Outlook default profile name and start Outlook in that profile
profile = ReadReg("HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\DefaultProfile")
Wscript.echo "Connecting to default Outlook profile: " & profile
objFile.WriteLine(Now() & " Connecting to default Outlook profile: " & profile)
olkSes.Logon profile

' Create the TBC Directory if it doesn't exist
Set tbcFolder = olkSes.GetDefaultFolder(olFolderContacts)
	On Error Resume Next
    Set myNewFolder = tbcFolder.Folders.Add("TBC Directory")
	if Err.number = 0 then	myNewFolder.ShowAsOutlookAB = True
	On Error GoTo 0

' Location of the user's TBC Directory folder
Set olkContacts = olkSes.GetDefaultFolder(olFolderContacts).Folders("TBC Directory")

' Location of the Public TBC Directory folder 
Set olkPublic = olkSes.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("TBC Directory").Folders("TBC Directory")

' Find the version of the user's personal copy of the TBC Directory
' It looks for the only contact with an "*" in the last name
For intIndex = olkContacts.Items.count To 1 Step -1
	olkPV = olkContacts.items(intIndex).lastname
	if inStr(olkPV, "*") > 0 then 
		olkPersonalVersion = olkContacts.items(intIndex).lastname
		exit for
	end if

' Find the version of the public folder copy of the TBC Directory
' It looks for the only contact with an "*" in the last name
For intIndex = 1 To olkPublic.Items.count Step +1
	olkPV = olkPublic.items(intIndex).lastname
	if inStr(olkPV, "*") > 0 then 
		olkPublicVersion = olkPublic.items(intIndex).lastname
		exit for
	end if

wscript.echo "Personal version: " & olkPersonalVersion
wscript.echo "Public version  : " & olkPublicVersion
objFile.WriteLine(Now() & " Personal version: " & olkPersonalVersion)
objFile.WriteLine(Now() & " Public version:   " & olkPublicVersion)

' If the versions are not equal
if olkPublicVersion <> olkPersonalVersion then
	' Delete all contacts
	wscript.echo "Removing personal copy of the TBC Directory"
	objFile.WriteLine(Now() & " Removing personal copy of the TBC Directory")
	For intIndex = olkContacts.Items.count To 1 Step -1
        	olkContacts.Items.Remove intIndex
	wscript.echo "Total items in TBC Directory: " & olkContacts.Items.count
	objFile.WriteLine(Now() & " Total items in TBC Directory: " & olkContacts.Items.count)
	' Copy contacts from the public folder to the private folder
	Set olkPublic = olkSes.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("TBC Directory").Folders("TBC Directory")
	Wscript.echo "Updating " & olkPublic.Items.count & " TBC Directory Contacts..."
	objFile.WriteLine(Now() & " Updating " & olkPublic.Items.count & " TBC Directory Contacts...")
	For intIndex = olkPublic.Items.count To 1 Step -1
       	 	Set olkContact = olkPublic.Items(intIndex).Copy
			olkContact.Unread = "False"
       	 	olkContact.Move olkContacts
		if intIndex Mod 100 = 0 then 
			Wscript.echo "Only " & intIndex &" left."
			objFile.WriteLine(Now() & " Only " & intIndex &" left.")
		end if
		if (intIndex < 100) and (intIndex Mod 25 = 0) then Wscript.echo "Only " & intIndex &" left."
end if

Wscript.echo "Your local TBC Directory contains " & olkContacts.Items.count & " items and is up to date."
Wscript.echo ""
Wscript.echo "If someone is missing from the TBC Directory, please contact them and ask that "
Wscript.echo "they update their record in . More information can be found on "
Wscript.echo "IT's page."
Wscript.echo ""
Wscript.echo "This window will close shortly. Please wait while the server data is updated..."
objFile.WriteLine(Now() & " Your TBC Directory contains " & olkContacts.Items.count & " items and is up to date.")
Set olkContacts = Nothing
Set olkPublic = Nothing
Set olkContact = Nothing
Set olkSes = Nothing
Set olkApp = Nothing
Set objGroupList = Nothing
Set objADObject =  Nothing

' Functions and Stuff

Function IsMember(strGroup)
' Function to test for group membership.
' strGroup is the NT name (sAMAccountName) of the group to test.
' objGroupList is a dictionary object, with global scope.
' Returns True if the user or computer is a member of the group.

  If IsEmpty(objGroupList) Then
    Call LoadGroups
  End If
  IsMember = objGroupList.Exists(strGroup)
End Function

Sub LoadGroups
' Subroutine to populate dictionary object with group memberships.
' objADObject is the user or computer object, with global scope.
' objGroupList is a dictionary object, with global scope.

  Dim arrbytGroups, j
  Dim arrstrGroupSids(), objGroup

  Set objGroupList = CreateObject("Scripting.Dictionary")
  objGroupList.CompareMode = vbTextCompare

  objADObject.GetInfoEx Array("tokenGroups"), 0
  arrbytGroups = objADObject.Get("tokenGroups")
  If TypeName(arrbytGroups) = "Byte()" Then
    ReDim arrstrGroupSids(0)
    arrstrGroupSids(0) = OctetToHexStr(arrbytGroups)
    Set objGroup = GetObject("LDAP://<SID=" & arrstrGroupSids(0) _
      & ">")
    objGroupList(objGroup.sAMAccountName) = True
    Set objGroup = Nothing
    Exit Sub
  End If
  If UBound(arrbytGroups) = -1 Then
    Exit Sub
  End If

  ReDim arrstrGroupSids(UBound(arrbytGroups))
  For j = 0 To UBound(arrbytGroups)
    arrstrGroupSids(j) = OctetToHexStr(arrbytGroups(j))
    Set objGroup = GetObject("LDAP://<SID=" & arrstrGroupSids(j) _
      & ">")
    objGroupList(objGroup.sAMAccountName) = True
  Set objGroup = Nothing

End Sub

Function OctetToHexStr(arrbytOctet)
' Function to convert OctetString (byte array) to Hex string.

  Dim k
  OctetToHexStr = ""
  For k = 1 To Lenb(arrbytOctet)
    OctetToHexStr = OctetToHexStr _
      & Right("0" & Hex(Ascb(Midb(arrbytOctet, k, 1))), 2)
End Function

Function ReadReg(RegPath)
' Function to read string value of registry key

     Dim objRegistry, Key
     Set objRegistry = CreateObject("Wscript.shell")
     Key = objRegistry.RegRead(RegPath)
     ReadReg = Key
End Function

Open in new window

Watch Question
This problem has been solved!
Unlock 1 Answer and 10 Comments.
See Answer
Why Experts Exchange?

Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.

Jim Murphy
Programmer at Smart IT Solutions

When asked, what has been your best career decision?

Deciding to stick with EE.

Mohamed Asif
Technical Department Head

Being involved with EE helped me to grow personally and professionally.

Carl Webster
CTP, Sr Infrastructure Consultant
Ask ANY Question

Connect with Certified Experts to gain insight and support on specific technology challenges including:

  • Troubleshooting
  • Research
  • Professional Opinions
Did You Know?

We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE