We help IT Professionals succeed at work.

VBS copying Outlook Contact items from Public Folder

PaulRKrueger
PaulRKrueger used Ask the Experts™
on
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
Next

' 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
Next

wscript.echo "Personal version: " & olkPersonalVersion
wscript.echo "Public version  : " & olkPublicVersion
objFile.WriteLine("")
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
	Next
	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."
	Next
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.")
objFile.WriteLine("---------------------------------------------------------------------------------------------")
objFile.WriteLine("")
Wscript.sleep(30000)
Set olkContacts = Nothing
Set olkPublic = Nothing
Set olkContact = Nothing
olkSes.Logoff
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
  Next
  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)
  Next
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

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
The copy creates the copy in the source folder ... that's just the way it works.  Duplicate operation shouldn't be an issue unless they happen to open the one on question but the times between copy and move should make that extremely unlikely

Chris

Author

Commented:
The problem is that, while it is unlikely, it has happened on more than one occasion this morning. Also, I don't want the users to be able to create / modify contacts in the public folder (which is what I have to do to make this work right now).
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
As I say the copy method simply works that way.

Potentially you could create a new contactitem and copy all the fields across which will avoid the problem with a pukka copy.

Chris

Author

Commented:
Ok, so I managed to fix my own problem. I modified the script so it doesn't create a copy of the contact - it just tries to move it. However, because the users no longer have permission to delete items the script generates the error below.

I set this section of the script to ignore errors and that seems to have done the trick.

Capture.JPG
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
I didn't suggest move as an alternative as you already indcated users were overlapping on the copies and therefore the same issue will apply to a moved contact and is therefore unacceptable for the same reason you dislike copy.

As I say the only way I can see is to create the new item and copy teh properties over.

Chris
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
>>> The question was:

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?

The answer is you cannot do it with a copy operation and need to create a new contactitem and copy the properties over.

The author proposal was to move it and this creates the same issues that underlined the original desire to avoid copy move default functionality.

As far as I can see I answered the question and I have investigated for example the redemption intrerface to confirm that this does not introduce an alternative copy method, (it does not).

Chris
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
http:#33109172 identifies the that's the way it works and you cannot do copy to folder without the teh copy initially being in the source folder first.  

http:#33109383 introduced the only alternative which is to create a new blank in the target folder and copy the data from the source item.

I repeat that the move, and subsequent copy back to the original folder is just as flawed as the copy in the source and then move the copy insofar as copy from source means others can use the copy in the source folder which errors when the copy is moved and move from source has the related issue that attempting to access an item that has moved is an error condition.

Chris

Author

Commented:
The question I asked was this: 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?

Your answer was ultimately this: Potentially you could create a new contactitem and copy all the fields  across which will avoid the problem with a pukka copy.

Unfortunately, I had already resolved my issue by the time you provided this response. Also, this was not a coded solution, which is what I was ultimately looking for.


You stated that: I didn't suggest move as an alternative as you already indcated users  were overlapping on the copies and therefore the same issue will apply  to a moved contact and is therefore unacceptable for the same reason you  dislike copy... I repeat that the move, and subsequent copy back to the original folder  is just as flawed as the copy in the source and then move the copy  insofar as copy from source means others can use the copy in the source  folder which errors when the copy is moved and move from source has the  related issue that attempting to access an item that has moved is an  error condition.

This is not correct, as it is working now without any issues and the users do not have the ability to create a duplicate contact within the directory (I have changed their permissions to read only). Using the original code with my current permissions, no contacts are copied to the local folder (because it can't create the duplicate). The new code, with the same permissions works as stated above.  I don't know what kind of copy is taking place as a result of the error I mentioned above, but I can assure you that it is not creating a copy of the contact prior to the move and is therefore not causing conflicts among my users.

Ultimately, I don't care about the points - I'll let an admin handle this. I have no problem awarding 100 points or so, but your answer was not worthy of 500.


Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
I missed the nature of the copy ... I thought you were moving the original contact out then copying it back.  I see now what you are doing and though I would never have suggested such, it is clearly working for you and meets your needs therefore I was clearly in error and apologise unreservedly.

Chris
Commented:
Question PAQ'd, 500 points refunded, and stored in the solution database.