아웃룩 표시이름 변경 스크립트(매크로)

아중제 1.2로 실행하는 방법은 표시이름이 한정적이고, 이메일 표시이름 변경이 되지 않아 2%부족한 부분이 있어서...

아중제 v1.2.exe

Google 검색 중 매크로를 통해서 모든 변경이 가능하다는게 확인되었습니다.

우선 아래 코드는 이름은 이름(회사명), 이메일표시이름은 이름(회사명/직급)으로 표기되는 내용입니다.

첨부의 객체 정의를 보시면 각 항목이 정의되어 있으니, 각자 입맛에 맞게 변경해서 사용하시면 될듯 합니다.



실행방법은 '매크로'실행 혹은 'ALT+F8'

새로 만들기 이후 아래 코드 붙여넣고 실행....


각자 특성에 맞게 수정해서 사용하시면 됩니다.
------------------------------------------------------------------------
Sub 주소록표시방법변경()

Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objContact As Outlook.ContactItem
Dim objItems As Outlook.Items
Dim objContactsFolder As Outlook.MAPIFolder
Dim obj As Object
Dim strFirstName As String
Dim strLastName As String
Dim strName As String

On Error Resume Next

Set objOL = CreateObject("Outlook.Application")
Set objNS = objOL.GetNamespace("MAPI")
Set objContactsFolder = objNS.GetDefaultFolder(olFolderContacts)
Set objItems = objContactsFolder.Items

For Each obj In objItems
'Test for contact and not distribution list
If obj.Class = olContact Then
Set objContact = obj

With objContact
strFirstName = .FirstName
strLastName = .LastName

'표시방법 = 이름 or 이름 (회사)
If (Asc(Left(strFirstName, 1)) >= 65 And Asc(Left(strFirstName, 1))) Then
    strName = strLastName + ", " + strFirstName
Else
    strName = strLastName + strFirstName
End If
.FileAs = strName + IIf(.CompanyName <> "", " (" + .CompanyName + ") ", "")

'전자메일 표시이름 = 이름 (회사/직급) or 이름 (회사) or 이름(EMail)
If (.Email1Address <> "" And strName <> "" And .JobTitle <> "") Then
    .Email1DisplayName = strName + " (" + .CompanyName + "/" + .JobTitle + ")"
Else
    .Email1DisplayName = strName + " (" + .CompanyName + ")"
End If

If (.Email2Address <> "" And strName <> "") Then
    .Email2DisplayName = strName + " (" + .Email2Address + ")"
End If

If (.Email3Address <> "" And strName <> "") Then
    .Email3DisplayName = strName + " (" + .Email3Address + ")"
End If

.Save
End With
End If

Err.Clear
Next

Set objOL = Nothing
Set objNS = Nothing
Set obj = Nothing
Set objContact = Nothing
Set objItems = Nothing
Set objContactsFolder = Nothing

End Sub

------------------------------------------------------------------------ 

ContactItem 개체 구성원 자료 참고....

글저장이 안되서 부득이 첨부파일로 대신합니다. ^^

ContactItem 개체 구성원.xlsx