|
我也是从别的地方找来的。 有空我改写一个导入的例子。 Sub Import_Contacts()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olColItems As Outlook.Items
Dim olItem As Object
Dim strDummy As String
Dim i As Long Application.ScreenUpdating = False With ActiveSheet
.Range("A1").CurrentRegion.Clear
.Cells(1, 1).Formula = "F?retag /Privatperson"
.Cells(1, 2).Formula = "Gatuadress"
.Cells(1, 3).Formula = "Postnummer"
.Cells(1, 4).Formula = "Ort"
.Cells(1, 5).Formula = "Kontaktperson"
.Cells(1, 6).Formula = "E-postadress"
With Range("A1:F1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.GetDefaultFolder(10)
Set olColItems = olFolder.Items i = 2
For Each olItem In olColItems
If TypeName(olItem) = "ContactItem" Then
If InStr(olItem.CompanyName, strDummy) = 0 Then
With olItem
Cells(i, 1).Value = .CompanyName
Cells(i, 2).Value = .BusinessAddressStreet
Cells(i, 3).Value = .BusinessAddressPostalCode
Cells(i, 4).Value = .BusinessAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
End With
Else
With olItem
Cells(i, 1).Value = .FullName
Cells(i, 2).Value = .HomeAddressStreet
Cells(i, 3).Value = .HomeAddressPostalCode
Cells(i, 4).Value = .HomeAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
End With
End If
i = i + 1
End If
Next olItem Set olItem = Nothing
Set olColItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing Range("A2", Cells(2, 6).End(xlDown)).Sort Key1:=Range("A2"), _
Order1:=xlAscending Range("A:F").EntireColumn.AutoFit Application.Application.ScreenUpdating = False MsgBox "The list has been successfully updated!", vbInformation
End Sub | 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2007-4-11 10:39
