VBAを使用して、複数のVCARDVCARD VCF連絡先ファイルをOutlook2007にインポートする方法
質問
VBAを使用して、複数のVCARDVCARD VCF連絡先ファイルをOutlook2007にインポートする方法
解決
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
他のヒント
私はいくつかのエラーに直面しています、以下は私のために働いたものです。ディレクトリのパスを変更するだけで、機能します。ディレクトリには「.vcf」ファイル(数百 / thounsandsを超える任意の数字)を含める必要があります。
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
これはに基づいています http://www.outlookcode.com/codedetail.aspx?id=212. 。メインの見通しウィンドウが開いていることを確認してください。
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
所属していません StackOverflow