I have tried to use the two scripts together but does not seem to work. I
added the Set objFolder to point to the public folder "test". Can someone
look at the code to see what needs to be changed?

Thanks,
Tommy

Sub ReconnectLinks()
 Dim objApp As Application
 Dim objNS As NameSpace
 Dim objFolder As MAPIFolder
 Dim colItems As Items
 Dim objItem As Object
 Dim colLinks As Links
 Dim objLink As Link
 Dim colContacts As Items
 Dim objContact As ContactItem
 Dim strFind As String
 Dim intCount As Integer

 Set objApp = CreateObject("Outlook.Application")
 Set objNS = objApp.GetNamespace("MAPI")
 
Set objFolder = GetFolder("Public Folders/All Public Folders/test")
 
 ' Set objFolder = objNS.PickFolder
 If TypeName(objFolder) <> "Nothing" Then
   Set colContacts = objNS.GetDefaultFolder(olFolderContacts).Items
   Set colItems = objFolder.Items
   For Each objItem In colItems

     Set colLinks = objItem.Links
     intCount = colLinks.Count
     If intCount > 0 Then
       For I = intCount To 1 Step -1
         Set objLink = colLinks.Item(I)
         On Error Resume Next

         If objLink.Item Is Nothing Then

           strFind = "[FullName] = " & AddQuotes(objLink.Name)
           Set objContact = colContacts.Find(strFind)

           If Not objContact Is Nothing Then
             ' remove the old link
             colLinks.Remove I
             ' add the replacement link
             colLinks.Add objContact
           End If
         End If
       Next
       If Not objItem.Saved Then
         objItem.Save
       End If
     End If
   Next
 End If

 Set objLink = Nothing
 Set colLinks = Nothing
 Set objItem = Nothing
 Set objItems = Nothing
 Set objFolder = Nothing
 Set objNS = Nothing
 Set objApp = Nothing
End Sub

Private Function AddQuotes(MyText) As String
 AddQuotes = Chr(34) & MyText & Chr(34)
End Function

Public Function GetFolder(strFolderPath As String) As MAPIFolder
 ' folder path needs to be something like
 '   "Public Folders\All Public Folders\Company\Sales"
 Dim objApp As Outlook.Application
 Dim objNS As Outlook.NameSpace
 Dim colFolders As Outlook.Folders
 Dim objFolder As Outlook.MAPIFolder
 Dim arrFolders() As String
 Dim I As Long
 On Error Resume Next

 strFolderPath = Replace(strFolderPath, "/", "\")
 arrFolders() = Split(strFolderPath, "\")
 Set objApp = CreateObject("Outlook.Application")
 Set objNS = objApp.GetNamespace("MAPI")
 Set objFolder = objNS.Folders.Item(arrFolders(0))
 If Not objFolder Is Nothing Then
   For I = 1 To UBound(arrFolders)
     Set colFolders = objFolder.Folders
     Set objFolder = Nothing
     Set objFolder = colFolders.Item(arrFolders(I))
     If objFolder Is Nothing Then
       Exit For
     End If
   Next
 End If

 Set GetFolder = objFolder
 Set colFolders = Nothing
 Set objNS = Nothing
 Set objApp = Nothing
End Function