Excel로 Outlook의 글로벌 커뮤니케이션 내보내기

최근 하드디스크 파일을 정리한 결과 아웃룩의 전 세계 통신에 엑셀이 녹음된 코드를 발견했지만 이 파일이 언제 내려왔는지 원작자에게 경의를 표합니다.
주의: 1. 이 코드는 Excel 모듈에 쓰여 있습니다.2. 연락처에 연락처가 많으면 시간이 좀 걸릴 수 있다.
 

  
  
  
  

   
   
   
   
Const CdoAddressListGAL = 0 
   
   
   
   
Const CdoUser = 0 
   
   
   
   
Const CdoRemoteUser = 6 
   
   
   
   
#Const EarlyBind = True 
   
   
   
   
 
   
   
   
   
Sub Approach() 
   
   
   
   
'Requires Excel 2000 as it uses Array 
   
   
   
   
 
   
   
   
   
'A reference must be set to the CDO 1.21 Library for Early Binding 
   
   
   
   
'The file is cdo.dll 
   
   
   
   
 
   
   
   
   
    Dim X As Variant, CDOList As Variant, TitleList As Variant, CDOitem As Variant 
   
   
   
   
    Dim NumX As Long, ArrayDump As Long, i As Long, v As Long, u As Long 
   
   
   
   
 
   
   
   
   
    Range("a1:R1").Value2 = Array("Global Name", "Given Name", "Surname", "Email address", "Logon", "Title Field", "Telephone", "Mobile", "Fax", "CSG/Group", "Department", "Site", "Address", "Location", "State ", "Country Field", "Assistant Name", "Assistant Phone") 
   
   
   
   
 
   
   
   
   
    #If EarlyBind Then 
   
   
   
   
        Dim objSession As MAPI.Session, oFolder As MAPI.AddressList, oMessage As MAPI.AddressEntry 
   
   
   
   
        Set objSession = New MAPI.Session 
   
   
   
   
        CDOList = Array(CdoPR_DISPLAY_NAME, CdoPR_GIVEN_NAME, CdoPR_SURNAME, 972947486, CdoPR_ACCOUNT, _ 
   
   
   
   
                        CdoPR_TITLE, CdoPR_OFFICE_TELEPHONE_NUMBER, CdoPR_MOBILE_TELEPHONE_NUMBER, CdoPR_PRIMARY_FAX_NUMBER, _ 
   
   
   
   
                        CdoPR_COMPANY_NAME, CdoPR_DEPARTMENT_NAME, 974716958, CdoPR_STREET_ADDRESS, _ 
   
   
   
   
                        CdoPR_LOCALITY, CdoPR_STATE_OR_PROVINCE, CdoPR_COUNTRY, _ 
   
   
   
   
                        CdoPR_ASSISTANT, CdoPR_ASSISTANT_TELEPHONE_NUMBER) 
   
   
   
   
    #Else 
   
   
   
   
        Dim objSession As Object, oFolder As Object, oMessage As Object 
   
   
   
   
        Set objSession = CreateObject("MAPI.Session") 
   
   
   
   
        CDOList = Array(805371934, 973471774, 974192670, 972947486, 973078558, 974585886, _ 
   
   
   
   
                        973602846, 974913566, 975372318, 974520350, 974651422, 974716958, 975765534, _ 
   
   
   
   
                        975634462, 975699998, 975568926, 976224286, 976093214) 
   
   
   
   
    #End If 
   
   
   
   
 
   
   
   
   
    With objSession 
   
   
   
   
        .Logon , , False, False 
   
   
   
   
        Set oFolder = .GetAddressList(CdoAddressListGAL) 
   
   
   
   
    End With 
   
   
   
   
 
   
   
   
   
    TitleList = Array("GAL Name", "Given Name", "Surname", "Email address", "Logon", "Title Field", _ 
   
   
   
   
                      "Telephone", "Mobile", "Fax", "CSG/Group", "Department", "Site", "Address", "Location", "State ", _ 
   
   
   
   
                      "Country Field", "Assistant Name", "Assistant Phone") 
   
   
   
   
 
   
   
   
   
    'Grab 10 records in one hit before writing to sheet 
   
   
   
   
    '2000 would be better but Excel skips records 
   
   
   
   
 
   
   
   
   
    ArrayDump = 10 
   
   
   
   
    Cells.Clear 
   
   
   
   
 
   
   
   
   
    'Add Titles 
   
   
   
   
    With Range("A1").Resize(1, UBound(TitleList) + 1) 
   
   
   
   
        .Formula = TitleList 
   
   
   
   
        .HorizontalAlignment = xlCenter 
   
   
   
   
        .Interior.ColorIndex = 35 
   
   
   
   
        .Font.Bold = True 
   
   
   
   
        .Font.Size = 12 
   
   
   
   
    End With 
   
   
   
   
 
   
   
   
   
    UserForm1.Show vbModeless 
   
   
   
   
 
   
   
   
   
    ReDim X(1 To ArrayDump, 1 To UBound(CDOList) + 1) 
   
   
   
   
 
   
   
   
   
    On Error Resume Next 
   
   
   
   
    'Some fields may not exist 
   
   
   
   
    Application.ScreenUpdating = False 
   
   
   
   
    For Each oMessage In oFolder.AddressEntries 
   
   
   
   
 
   
   
   
   
        Select Case oMessage.DisplayType 
   
   
   
   
        Case CdoUser, CdoRemoteUser 
   
   
   
   
            i = i + 1 
   
   
   
   
            'Reset variant array every after each group of records 
   
   
   
   
            If i Mod (ArrayDump + 1) = 0 Then 
   
   
   
   
                If NumX * ArrayDump + i > 65535 Then 
   
   
   
   
                    MsgBox "GAL exceeds 65535 entries - extraction stopped ", vbCritical + vbOKOnly 
   
   
   
   
                    GoTo FastExit 
   
   
   
   
                End If 
   
   
   
   
                NumX = NumX + 1 
   
   
   
   
                Range("A2").Offset((NumX - 1) * ArrayDump, 0).Resize(ArrayDump, UBound(CDOList) + 1) = X 
   
   
   
   
                ReDim X(1 To ArrayDump, 1 To UBound(CDOList) + 1) 
   
   
   
   
                i = 1 
   
   
   
   
            End If 
   
   
   
   
            'Display status to user 
   
   
   
   
            If i Mod ArrayDump = 0 Then 
   
   
   
   
                UserForm1.LabelProgress.Width = (i + u + NumX * ArrayDump) / oFolder.AddressEntries.Count * UserForm1.FrameProgress.Width 
   
   
   
   
                UserForm1.LabelSheetNum = Format((i + u + NumX * ArrayDump) / oFolder.AddressEntries.Count, "percent") 
   
   
   
   
                DoEvents 
   
   
   
   
            End If 
   
   
   
   
 
   
   
   
   
            v = 0 
   
   
   
   
            ' Add detail to each address 
   
   
   
   
            For Each CDOitem In CDOList 
   
   
   
   
                v = v + 1 
   
   
   
   
                X(i, v) = oMessage.Fields(CDOitem) 
   
   
   
   
            Next 
   
   
   
   
        Case Else 
   
   
   
   
            u = u + 1 
   
   
   
   
        End Select 
   
   
   
   
    Next 
   
   
   
   
 
   
   
   
   
    'dump remaining entries 
   
   
   
   
    Range("A2").Offset(NumX * ArrayDump, 0).Resize(ArrayDump, UBound(CDOList) + 1) = X 
   
   
   
   
 
   
   
   
   
    'cleanup 
   
   
   
   
FastExit: 
   
   
   
   
    Unload UserForm1 
   
   
   
   
    ActiveSheet.UsedRange.EntireRow.WrapText = False 
   
   
   
   
    ActiveSheet.UsedRange.AutoFilter 
   
   
   
   
    Columns("A:R").AutoFit 
   
   
   
   
 
   
   
   
   
    Application.ScreenUpdating = True 
   
   
   
   
 
   
   
   
   
    Set oFolder = Nothing 
   
   
   
   
    Set objSession = Nothing 
   
   
   
   
 
   
   
   
   
End Sub 
  
  
  
  

 
 
 
 
저자: laoyebin(Paladin.lao) 출처:http://www.cnblogs.com/laoyebin/개인 사이트 영문 출처:http://mrvsto.com/개인 사이트 중국어 출처:http://cn.mrvsto.com/