RE: Outlook Addin
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.
Wenn "Server" eine Religion ist, haben wir die passende Kathedrale dazu!
[Link: Registrierung erforderlich]
[Link: Registrierung erforderlich] - [Link: Registrierung erforderlich] - [Link: Registrierung erforderlich] - [Link: Registrierung erforderlich] - [Link: Registrierung erforderlich]
Mehr infos unter [Link: Registrierung erforderlich] oder [Link: Registrierung erforderlich]
Dieser Beitrag wurde zuletzt bearbeitet: 20.04.2016 07:12 von Alex.
|
