Sponsor-Board.de - Outlook Addin

Hi,

ich suche jemand der mir bei einem kleinen Outlook Addin helfen kann.

Ich möchte, dass Outlook 2013 bei starten automatisch ein Addin ausführt das folgende Dinge tut:

-Löschen aller Kontakte
-importieren von Windows Kontakten in einem Netzwerk Ordner (CSV oder VCF)

Eigentlich sollte das Plugin ja mit VBA recht einfach zu erstellen sein.
Leider bekomme ich es selbst dennoch nicht hin.

Hier mein Versuch:

PHP-Code:

Public Class ThisAddIn

    Private Sub ThisAddIn_Startup() Handles Me.Startup

    End Sub

    Sub loesche()
        Set objOutlook = CreateObject("Outlook.Application")
        Set nms = objOutlook.GetNamespace("MAPI")
        Set fldContacts = nms.GetDefaultFolder(olFolderContacts)
        Set itms = fldContacts.Items
        Do Until itms.Count = 0
            itms.Remove 1
        Loop
    End Sub

    Public Sub OpenSharedContact()

        Dim oNamespace As NameSpace 
        Dim oSharedItem As ContactItem
        Dim oFolder As Folder

        On Error GoTo ErrRoutine
 
        ' Get a reference to a NameSpace object. 
        Set oNamespace = Application.GetNamespace("MAPI") 
 
         ' Open the vCard (.vcf) file containing the shared item. 
        Set oSharedItem = oNamespace.OpenSharedItem( _ 
        "LINK.vcf") 
 
        ' Save the item to the Contacts default folder. 
        oSharedItem.Save
 
        ' Get a reference to and display the Contacts default folder. 
        Set oFolder = oNamespace.GetDefaultFolder( _ 
        olFolderContacts) 
        oFolder.Display

EndRoutine:
        On Error GoTo 0
        Set oSharedItem = Nothing 
        Set oFolder = Nothing 
        Set oNamespace = Nothing 
        Exit Sub

ErrRoutine:
        Select Case Err.Number
            Case 287 ' &H0000011F 
                ' This error occurs if the code is run by an 
                ' untrusted application, and the user chose not to 
                ' allow access. 
                MsgBox "Access to Outlook was denied by the user.",
         vbOKOnly,
        Err.Number & " - " & Err.Source 
        Case -2147024894 ' &H80070002 
                ' Occurs if the specified file or URL could not 
                ' be found, or the file or URL cannot be 
                ' processed by the OpenSharedItem method. 
                MsgBox Err.Description,
        vbOKOnly,
        Err.Number & " - " & Err.Source 
        Case -2147352567 ' &H80020009 
                ' Occurs if the specified file or URL is not valid, 
                ' or you attempt to use the Move method on 
                ' an Outlook item that represents a shared item. 
                MsgBox Err.Description,
        vbOKOnly,
        Err.Number & " - " & Err.Source 
        Case Else
                ' Any other error that may occur. 
                MsgBox Err.Description,
        vbOKOnly,
        Err.Number & " - " & Err.Source 
        End Select

        GoTo EndRoutine
    End Sub

    Private Sub ThisAddIn_Shutdown() Handles Me.Shutdown

    End Sub

End Class 

Leider erhalte ich hier bereits 21 Fehler und bekomme diese auch nicht gelöst.

Ich würde mich freuen, wenn sich jemand bereiterklären könnte mir hier zu helfen.

Lg eret12

pushmessage

Interresant wäre welche Gegenleistung du demjenigen entgegen bringst

Hi,

ich kann eine ehrliche Bewertung bieten und eventuell noch ein paar SB-Punkte.
Da der Umfang ja nicht all zu Unfangreich ist sollte das Add-In mit guten VBA-Kentnissen recht schnell zu erstellen sein.

Weitere Gegenleistungen können natürlich per PN besprochen werden.

Lg eret12

pushmessage

Hallo Eret12,
Ich habe das Thema verschoben, denn ein Sponsoring ist dies hier nicht.
Ich stelle Dir hier ein paar Vbs Schnippsel zur Verfügung, welche Dir helfen:

Ordner leeren:

PHP-Code:

Sub DeleteContacts()
 Dim myOutlook As Outlook.Application
 Dim myInformation As NameSpace
 Dim myContacts As Items
 Dim i As Long
 Dim lngCount As Long
 Set myOutlook = CreateObject("Outlook.Application")
 Set myInformation = myOutlook.GetNamespace("MAPI")
 Set myContacts = myInformation.GetDefaultFolder(olFolderContacts).Items
 lngCount = myContacts.Count
 For i = lngCount To 1 Step -1
 myContacts(i).Delete
 Next
 End Sub 

Import vcards:

PHP-Code:

Sub OpenSaveVCard()
     
Dim objWSHShell As IWshRuntimeLibrary.IWshShell
Dim objOL As Outlook.Application
Dim colInsp As Outlook.Inspectors
Dim strVCName As String
Dim fso As Scripting.FileSystemObject
Dim fsDir As Scripting.Folder
Dim fsFile As Scripting.File
Dim vCounter As Integer
    
Set fso = New Scripting.FileSystemObject
Set fsDir = fso.GetFolder("C:\vcards")
 
For Each fsFile In fsDir.Files
 
'original code
'strVCName = "C:\vcards\" & fsFile.Name
 
'Zeda's fix for spaces in filenames
strVCName = """C:\vcards\" & fsFile.Name & """"
 
 
    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
            Set colInsp = Nothing
            Set objOL = Nothing
            Set objWSHShell = Nothing
        End If
    End If
 
Next
 
End Sub 

Import aus Excel:

PHP-Code:

Sub Import_Contacts()

    'Outlook objects.
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olConItems As Outlook.Items
    Dim olItem As Object
    
    'Excel objects.
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    
    'Location in the imported contact list.
    Dim lnContactCount As Long
    
    Dim strDummy As String
    
    'Turn off screen updating.
    Application.ScreenUpdating = False
    
    'Initialize the Excel objects.
    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets(1)
    
    'Format the target worksheet.
    With wsSheet
        .Range("A1").CurrentRegion.Clear
        .Cells(1, 1).Value = "Company / Private Person"
        .Cells(1, 2).Value = "Street Address"
        .Cells(1, 3).Value = "Postal Code"
        .Cells(1, 4).Value = "City"
        .Cells(1, 5).Value = "Contact Person"
        .Cells(1, 6).Value = "E-mail"
        With .Range("A1:F1")
            .Font.Bold = True
            .Font.ColorIndex = 10
            .Font.Size = 11
        End With
    End With
    
    wsSheet.Activate
    
    'Initalize the Outlook variables with the MAPI namespace and the default Outlook folder of the current user.
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(10)
    Set olConItems = olFolder.Items
            
    'Row number to place the new information on; starts at 2 to avoid overwriting the header
    lnContactCount = 2
    
    'For each contact: if it is a business contact, write out the business info in the Excel worksheet;
    'otherwise, write out the personal info.
    For Each olItem In olConItems
        If TypeName(olItem) = "ContactItem" Then
            With olItem
                If InStr(olItem.CompanyName, strDummy) > 0 Then
                    Cells(lnContactCount, 1).Value = .CompanyName
                    Cells(lnContactCount, 2).Value = .BusinessAddressStreet
                    Cells(lnContactCount, 3).Value = .BusinessAddressPostalCode
                    Cells(lnContactCount, 4).Value = .BusinessAddressCity
                    Cells(lnContactCount, 5).Value = .FullName
                    Cells(lnContactCount, 6).Value = .Email1Address
                Else
                    Cells(lnContactCount, 1) = .FullName
                    Cells(lnContactCount, 2) = .HomeAddressStreet
                    Cells(lnContactCount, 3) = .HomeAddressPostalCode
                    Cells(lnContactCount, 4) = .HomeAddressCity
                    Cells(lnContactCount, 5) = .FullName
                    Cells(lnContactCount, 6) = .Email1Address
                End If
                wsSheet.Hyperlinks.Add Anchor:=Cells(lnContactCount, 6), _
                                       Address:="mailto:" & Cells(lnContactCount, 6).Value, _
                                       TextToDisplay:=Cells(lnContactCount, 6).Value
            End With
            lnContactCount = lnContactCount + 1
        End If
    Next olItem
    
    'Null out the variables.
    Set olItem = Nothing
    Set olConItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
    
    'Sort the rows alphabetically using the CompanyName or FullName as appropriate, and then autofit.
    With wsSheet
        .Range("A2", Cells(2, 6).End(xlDown)).Sort key1:=Range("A2"), order1:=xlAscending
        .Range("A:F").EntireColumn.AutoFit
    End With
            
    'Turn screen updating back on.
    Application.ScreenUpdating = True
    
    MsgBox "The list has successfully been created!", vbInformation
    
End Sub 

Ich weiss einfach nicht ob DU glücklich wirst, wenn Du wirklich den Orginal Kontakte Ordner leerst und wieder Sachen Importierst. Das heisst, wenn der User Änderungen macht, gehen diese jedesmal verloren.
Ich zumindest würd einen weiteren Kontakte Ordner anlegen mit dem Namen "Firmenkontakte" zum Beispiel und den User die Rechte nehmen das Sie nichts editieren können. Oder wenn Du ein Exchange hast ein neues Adressbuch anlegen.

Viele Wege führen nach Rom, aber ich weiss natürlich auch nicht genau was das Ziel ist. In diesem Sinne wünsche ich Dir viel Erfolg.

LG Alex

PS: Bewertung kannst DU nicht bieten, da es KEIN Marktplatzthema ist und Fakebewertungen auf andere Threads sind nicht erlaubt.