如何使用 VBA 将多个 vCard VCF 联系人文件导入 Outlook 2007
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/2646465/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
How to import multiple vCard VCF contact files into Outlook 2007 using VBA
提问by user202448
How to import multiple vCard VCF contact files into Outlook 2007 using VBA
如何使用 VBA 将多个 vCard VCF 联系人文件导入 Outlook 2007
回答by Hamed
Sub OpenSaveVCard()
Dim objWSHShell As Object
Dim objOL As Outlook.Application
Dim colInsp As Outlook.Inspectors
Dim strVCName As String
Dim vCounter As Integer
Dim ff As String
ff = Dir("d:\contacts\*.vcf")
Do While Len(ff)
strVCName = "d:\contacts\" & ff
Set objOL = CreateObject("Outlook.Application")
Set colInsp = objOL.Inspectors
If colInsp.Count = 0 Then
Set objWSHShell = CreateObject("WScript.Shell")
objWSHShell.Run Chr(34) & strVCName & Chr(34)
Set colInsp = objOL.Inspectors
If Err = 0 Then
Do Until colInsp.Count = 1
DoEvents
Loop
colInsp.Item(1).CurrentItem.Save
colInsp.Item(1).Close olDiscard
Set colInsp = Nothing
Set objOL = Nothing
Set objWSHShell = Nothing
End If
End If
ff = Dir
Loop
End Sub
回答by upender
I have faced few errors, below is the the one which worked for me. Just change the path of the directory, it will work. Directory should contain ".vcf" files(any number above hundreds / thounsands) .
我遇到了一些错误，下面是对我有用的错误。只需更改目录的路径，它就会起作用。目录应包含“.vcf”文件（数百/千以上的任意数字）。
Sub OpenSaveVCard()
Dim objWSHShell As Object
'Dim objOL As Outlook.Application
'Dim colInsp As Outlook.Inspectors
Dim strVCName As String
Dim vCounter As Integer
Dim ff As String
ff = Dir("D:\Contacts\*.vcf")
Do While Len(ff)
On Error Resume Next
strVCName = "D:\Upender\Contacts\" & ff
Set objOL = CreateObject("Outlook.Application")
Set colInsp = objOL.Inspectors
If colInsp.Count = 0 Then
Set objWSHShell = CreateObject("WScript.Shell")
objWSHShell.Run strVCName
Set colInsp = objOL.Inspectors
If Err = 0 Then
Do Until colInsp.Count = 1
DoEvents
Loop
colInsp.Item(1).CurrentItem.Save
colInsp.Item(1).Close olDiscard
End If
End If
ff = Dir()
Loop
Set colInsp = Nothing
Set objOL = Nothing
Set objWSHShell = Nothing
End Sub
回答by user202448
This is based off of http://www.outlookcode.com/codedetail.aspx?id=212. Make sure only the main Outlook window is open.
这是基于http://www.outlookcode.com/codedetail.aspx?id=212。确保只打开主 Outlook 窗口。
Sub OpenSaveVCard()
Dim objWSHShell As Object
Dim objOL As Outlook.Application
Dim colInsp As Outlook.Inspectors
Dim strVCName As String
Dim vCounter As Integer
Dim ff As String
ff = Dir("C:\Contacts\*.vcf")
Do While Len(ff)
strVCName = "C:\Contacts\" & ff
Set objOL = CreateObject("Outlook.Application")
Set colInsp = objOL.Inspectors
If colInsp.Count = 0 Then
Set objWSHShell = CreateObject("WScript.Shell")
objWSHShell.Run Chr(34) & strVCName & Chr(34)
Set colInsp = objOL.Inspectors
If Err = 0 Then
Do Until colInsp.Count = 1
DoEvents
Loop
colInsp.Item(1).CurrentItem.Save
colInsp.Item(1).Close olDiscard
Set colInsp = Nothing
Set objOL = Nothing
Set objWSHShell = Nothing
End If
End If
ff = Dir
Loop
End Sub
