2

VBA を使用して Outlook 2007 に複数の vCard VCF 連絡先ファイルをインポートする方法

4

3 に答える 3

3 
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
于 2011-03-12T00:24:08.013 に答える
1

私はいくつかのエラーに直面しました。以下は私のために働いたものです。ディレクトリのパスを変更するだけで機能します。ディレクトリには「.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
于 2011-12-24T21:44:57.667 に答える
0

これは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
于 2010-04-15T15:09:52.367 に答える