Export Outlook contacts to vcard format

'Option Explicit

Sub Export_PAB_to_vcfs()

Dim myOlApp As Outlook.Application
Dim objContact As ContactItem

Set myOlApp = New Outlook.Application

Set olns = myOlApp.GetNamespace("MAPI")

' Set MyFolder to the default contacts folder.
Set myFolder1 = olns.Folders("Sean O'Reilly")
Set myfolder = myFolder1.Folders("Contacts")

' Get the number of items in the folder.
NumItems = myfolder.Items.Count

' Loop through all of the items in the folder.
For i = 1 To NumItems
    Debug.Print myfolder.Items(i).Class
    If myfolder.Items(i).Class = 40 Then
        Set objContact = myfolder.Items(i)
        Debug.Print TypeName(objContact) + ":" + objContact.FullName
        If Not TypeName(objContact) = "Nothing" Then
            If Not objContact.FullName = "" Then
              strname = "H:\Personal\Contacts\" & TrimALL(objContact.FullName) & ".vcf"
             objContact.SaveAs strname, olVCard
            End If
        End If
    End If
Next

MsgBox "All Contacts Exported!"

End Sub

Public Function TrimALL(ByVal TextIN As String, Optional NonPrints As Boolean) As String

    TrimALL = Trim(TextIN)

        For x = 0 To 31
            While InStr(TrimALL, Chr(x)) > 0
                TrimALL = Replace(TrimALL, Chr(x), " ")
            Wend
        Next x
        
        For x = 33 To 43
            While InStr(TrimALL, Chr(x)) > 0
                TrimALL = Replace(TrimALL, Chr(x), " ")
            Wend
        Next x

        For x = 45 To 47
            While InStr(TrimALL, Chr(x)) > 0
                TrimALL = Replace(TrimALL, Chr(x), " ")
            Wend
        Next x

        For x = 58 To 64
            While InStr(TrimALL, Chr(x)) > 0
                TrimALL = Replace(TrimALL, Chr(x), " ")
            Wend
        Next x

        For x = 91 To 96
            While InStr(TrimALL, Chr(x)) > 0
                TrimALL = Replace(TrimALL, Chr(x), " ")
            Wend
        Next x

        For x = 123 To 255
            While InStr(TrimALL, Chr(x)) > 0
                TrimALL = Replace(TrimALL, Chr(x), " ")
            Wend
        Next x


    While InStr(TrimALL, String(2, " ")) > 0
        TrimALL = Replace(TrimALL, String(2, " "), " ")
    Wend

End Function

Sub ResavePABbyNameCompany()

Dim myOlApp As Outlook.Application

Dim objContact As ContactItem

Set myOlApp = New Outlook.Application

Set olns = myOlApp.GetNamespace("MAPI")

' Set MyFolder to the default contacts folder.
Set myFolder1 = olns.Folders("Mailbox - Dave Bour")
Set myfolder = myFolder1.Folders("Contacts")

' Get the number of items in the folder.
NumItems = myfolder.Items.Count

' Loop through all of the items in the folder.
For i = 1 To NumItems
    Debug.Print myfolder.Items(i).Class
    If myfolder.Items(i).Class = 40 Then
        Set objContact = myfolder.Items(i)
        Debug.Print TypeName(objContact) + ":" + objContact.FullNameAndCompany
        If Not TypeName(objContact) = "Nothing" Then
            If Not objContact.FullNameAndCompany = "" Then
              objContact.FileAs = objContact.LastNameAndFirstName
                  If objContact.CompanyName <> "" Then
                     If objContact.FileAs <> "" Then
                        objContact.FileAs = objContact.FileAs & " (" & _
                                        objContact.CompanyName & ")"
                     Else
                        objContact.FileAs = objContact.FileAs & _
                                  objContact.CompanyName
                     End If
                  End If

            End If
        End If
    End If
objContact.Save

Debug.Print objContact.FileAs

Next

MsgBox "All Contacts Exported!"

End Sub

Sub ShowAllFolders()

Dim myOlApp As Outlook.Application
Dim objContact As ContactItem

Set myOlApp = New Outlook.Application

'Set objAddressList = myOlApp.Session.AddressLists("pvt_Contacts")

Set olns = myOlApp.GetNamespace("MAPI")

For Each myFolder1 In olns.Folders
  Debug.Print myFolder1.Name
Next myFolder1

End Sub