Outlook Addin - eret12 - 13.01.2016 18:02
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:
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
pushsubject - push - 15.03.2016 11:41
pushmessage
RE: Outlook Addin - Union - 15.03.2016 13:16
Interresant wäre welche Gegenleistung du demjenigen entgegen bringst
RE: Outlook Addin - eret12 - 15.03.2016 14:25
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
pushsubject - push - 03.04.2016 10:05
pushmessage
pushsubject - push - 20.04.2016 06:37
pushmessage
RE: Outlook Addin - Alex - 20.04.2016 07:11
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:
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:
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:
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.
|