Link Public Folders using VBA

Yes, don't use that folder. Use one of the subfolders of the current user, say %LocalAppData%, as described in my article:

Deploy and update a Microsoft Access application with one click

There isn't much to "upgrade" doing so.

Gustav,

Thanks for your response.

Most of the databases still maintained were originally Access 2000 mdb databases.
They have been slightly modified to run with Access 2013, but are still mdb base.

My solution would be a method using VBA to link Public Folders. Any ideas along that line?

Now, I'm uncertain what "link Public Folders" mean. Normally, you link tables.

I like the way you put the question and how you anticipate 'some aggressive' responses ahead of time. Basically what you ask is doable.
BUT
As it is server/situation/workstation related when developing the VBA we need to test the values returned by the code to get the correct syntax and access the proper links.

In other words it would be difficult to do the VBA and not have a similar setup on the machine of the developer which is my case right now.

All this being said, if you are patient enough and no one beats me to it I could give it a try on Monday when I get to the office as we have a setup with Outlook and have Public folders I can then make some tests and will take it from there Will try to link and unlink public folder thru VBA and if I am able to succeed then, I will let you know for sure will need some path from you to access the correct links your end but this will be on an ongoing conversation then.

Gowflow

Gowflow, thanks for our help. Monday would be great.

Gustav Brock, "Public Folders" is the name of shared folders provided by Exchange Server accessible by Outlook. Not operating system shares.

Oh. I have some old code that could get you started, as it will return the currently attached MAPI profile.

So:

• retrieve the Connect string from the linked folder
• replace in this the entry for the current MAPI profile with the new
• reassign the Connect string
• Relink the table

Public Function GetMapiProfile( _
  ByVal varConnect As Variant) _
  As Variant
  
' To be used in a query to extract a MAPI profile name from the
' Connect field of table MSysObjects for an attached table from
' Exchange/Outlook.
' Returns Null if profile is missing or empty (zero length).
'
' Requires function GetConnectKey().
'
' 2004-04-23. Cactus Data ApS. CPH.

  ' Key in connect string holding name of MAPI profile.
  Const cstrKeyProfile  As String = "PROFILE"

  Dim strConnect  As String
  Dim strProfile  As String
  Dim varProfile  As Variant
  
  ' No special error handling.
  On Error Resume Next
  
  If Not IsNull(varConnect) Then
    strConnect = varConnect
    strProfile = GetConnectKey(strConnect, cstrKeyProfile)
    If Len(strProfile) = 0 Then
      ' Return Null.
    Else
      varProfile = strProfile
    End If
  End If
  
  GetMapiProfile = varProfile
  
End Function



Public Function GetConnectKey( _
  ByVal strConnect As String, _
  ByVal strKey) _
  As String

' Extracts the value of key strKey or of the type from a string
' containing a type and one or more sets of key/value separated
' by semicolon, like:
'
'   "TYPE;KEY1=VALUE1;KEY2=;;KEY3=VALUE3;
'
' as typically found in the Connect field of table MSysObjects for
' an attached non-ODBC table;
' or without a type value, like:
'
'   "KEY1=VALUE1;KEY2=;;KEY3=VALUE3;
'
' as typically found in the Connect field of table MSysObjects for
' an attached ODBC table.
'
' Returns value of type if key strKey has a length of zero.
' Returns empty string if key/value set is malformed.
'
' 2004-05-28. Cactus Data ApS. CPH.
  
  ' Separators.
  Const cstrSepConnect  As String = ";"
  Const cstrSepEntry    As String = "="
  
  Dim astrEntries() As String
  Dim astrEntry()   As String
  
  Dim strEntry      As String
  Dim strProfile    As String
  Dim lngElements   As Long
  Dim lngN          As Long
  
  ' No special error handling.
  On Error Resume Next
  
  ' Create array with entries.
  astrEntries = Split(strConnect, cstrSepConnect)
  ' Loop to locate entry with key.
  For lngN = LBound(astrEntries) To UBound(astrEntries)
    strEntry = Trim(astrEntries(lngN))
    If Len(strEntry) = 0 Then
      ' Empty entry.
    Else
      ' Create array holding Key and Value.
      astrEntry = Split(strEntry, cstrSepEntry)
      lngElements = UBound(astrEntry)
      ' A valid entry will have one or two elements.
      If lngElements < 0 Then
        ' Empty ("") entry.
      ElseIf lngElements > 1 Then
        ' Malformed ("..=..=..") multi-element entry.
      ElseIf Len(astrEntry(0)) = 0 Then
        ' Malformed ("=" or "=VALUE") entry.
      Else
        ' Key ("KEY=VALUE") or type ("TYPE") is present.
        If Len(strKey) = 0 Then
          ' We are looking for the type.
          If lngN = 0 And lngElements = 0 Then
            ' Type is located. Retrieve its value.
            strProfile = astrEntry(0)
          End If
        ElseIf StrComp(astrEntry(0), strKey, vbTextCompare) = 0 Then
          ' Key is located.
          If lngElements = 1 Then
            ' Key has a value. Retrieve this.
            strProfile = astrEntry(1)
          End If
        End If
      End If
    End If
    If Len(strProfile) > 0 Or Len(strKey) = 0 Then
      ' Either the key has been located or
      ' this is a lookup for the type.
      Exit For
    End If
  Next
  
  GetConnectKey = strProfile
  
End Function

Select allOpen in new window

Can you give a bit more info on how exactly you use the Public Folders concept of Exchange...i must tell i haven't ever heard of something similar and probably it will help to better assist you.

HI Ron
When you open on Outlook a MAPI Session thru Exchange and the user mailbox and try listing the folders there … the first one is
\\Public Folders

I need to know exactly what you are tryng to achieve ?

You want to change the user's path to the Outlook.ost ? as in there reside the access to Public Folders.

Try please clarify.
Gowflow

WIth the help provided by Gustav Brock, I have developed something that seems to work. Not great because it is very slow.
I am sure there must be a better way. It only runs 1 time with the first application execution so for now I can live with it.

This is my working code:

Sub Run_RelinkPublicFolders()
    Dim strMsg As String
    strMsg = RelinkPublicFolders()
    If Len(strMsg & "") = 0 Then
        Debug.Print "All; Tables; were; successfully; relinked."
    Else
        MsgBox strMsg, vbCritical
    End If
End Sub

Function RelinkPublicFolders() As String
    On Error GoTo ErrHandle
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim strCon As String
    Dim strBackEnd As String
    Dim strMsg As String
    Dim intErrorCount As Integer
    Dim lngFirst As Long
    Dim strUser1 As String
    Dim strUser2 As String
    Dim MaxX As Long
    Dim lngRecCount As Long
    Dim lngTotalRec As Long
    Post_Working
    Form_Working_Form.Message = "Establishing Links to Public Folders."
    MaxX = 0
    Call Run_GetPublicParentInfo
    strUser1 = arrPFRootEmail(0) & "@"
    strUser2 = "\" & arrPFRootEmail(0) & "\"
    Set db = CurrentDb
    For Each tdf In db.TableDefs
        If tdf.Attributes = dbAttachedTable Then
            MaxX = MaxX + 1
        End If
    Next tdf
    If MaxX = 0 Then
        GoTo ExitHere
    End If
    lngTotalRec = MaxX
    lngRecCount = 0
    For Each tdf In db.TableDefs
        If tdf.Attributes = dbAttachedTable Then
            lngRecCount = lngRecCount + 1
            Call Set_Progress_Ind(lngTotalRec, lngRecCount)
                If Left$(tdf.Connect, 7) = "OUTLOOK" Then 'PUBLIC FOLDER
                    strCon = "" & tdf.Connect
                    Debug.Print strCon
                    If (InStr(1, strCon, "Ron@")) > 0 Then
                        strCon = Replace(strCon, "Ron@", strUser1)
                    End If
                    Debug.Print strCon
                    If (InStr(1, strCon, "\ron\")) > 0 Then
                        strCon = Replace(strCon, "\ron\", strUser2)
                    End If
                    Debug.Print strCon
                    tdf.Connect = strCon
                    tdf.RefreshLink
                End If
        End If
    Next tdf
    MaxX = Timer + 2
    Do While Timer <= MaxX
        Loop
ExitHere:
    Remove_Working
    swTimer_BE = True
    On Error Resume Next
    If intErrorCount > 0 Then
        strMsg = "There were errors refreshing the table links: " & _
            vbNewLine & strMsg & "In Procedure RefreshTableLinks"
        RelinkPublicFolders = strMsg
    End If
    Set tdf = Nothing
    Set db = Nothing
    Exit Function
ErrHandle:
    intErrorCount = intErrorCount + 1
    strMsg = strMsg & "Error " & Err.Number & " " & Err.Description
    strMsg = strMsg & vbNewLine & "Table Name: " & tdf.Name & vbNewLine
    strMsg = strMsg & "Connect = " & strCon & vbNewLine
    Resume ExitHere
End Function

Select allOpen in new window

@RON
I think you have wrongly closed this question by awarding yourself and yourself only the solution despite your ackgnowledgment to Gustav Brock who provided a code that you used and tweaked for the solution.

You mentioned first being new on this site let me explain:

By awarding yourself the solution You automatically disreagard all Expert's solutions (as being not correct or not adequate) hence no Experts are awarded any points for helping you.

I am almost sure this is not your intent and in the contrary you appreciate Gustav Brock input who helped you solve your issue hence you ought to recognise this and award him the solution and your comment and code would come to explain how at the end you were able to tweak it in a way to help you solve your problem.

Now if you agree with my comments and agree to bring corrective action to this question that was wrongly closed then you need to ask for Moderator's assistance by clicking on the More button just beneath your question and select Report Question. You will have a window to explain what happen and request the attention needed to close the question properly.

Regards
Gowflow

A special thanks to Gustav Brock for helping to come up with a resolution. With his assistance, I was able to get started in the proper direction. I have asked the moderator for assistance in awarding the proper points to Gustav Brock.

Please excuse the mistake. I will do better in the future.

That's very kind of you. And thanks to Gowflow for guidance.