Attribute VB_Name = "Copy2Address" Option Explicit '========================================================================== 'Description : Kopiert Adressdaten eines ausgewählten Kontaktes in das Clipboard ' Dazu muss Markierung auf Kontakteintrag stehen ' Makro kann für beliebige Anforderungen abgewandelt werden, bei denen es ' um die gezielte Bereitstellung von Daten über die Zwischenablage geht ' 'Calls : Several API calls 'Comments : Source: Peter Strong, Smart Access, January 1999, pp14-15. 'Comments : restructured from MS KB article Q138909 ' Hardy Krause Krause@netcomplett.de: Anpassung, so dass ' direct aus jeder Liste ein oder mehrere Adressen kopiert ' werden können '========================================================================== 'Begin Module Code Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _ As Long Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _ As Long Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _ ByVal dwBytes As Long) As Long Declare Function CloseClipboard Lib "User32" () As Long Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _ As Long Declare Function EmptyClipboard Lib "User32" () As Long Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _ ByVal lpString2 As Any) As Long Declare Function SetClipboardData Lib "User32" (ByVal wFormat _ As Long, ByVal hMem As Long) As Long Public Const GHND = &H42 Public Const CF_TEXT = 1 Public Const MAXSIZE = 4096 Public Const language = "de" ' "en" '========================================================================== 'Description : Sets the clipboard contents 'Calls : Several API calls 'Comments : Source: Peter Strong, Smart Access, January 1999, pp14-15. 'Comments : restructured from MS KB article Q138909 '========================================================================== Public Sub CopyAdress2Clipboard() On Error GoTo ProcError Dim objOutlook As Outlook.Application Dim objInspector As Inspector Dim objExplorer As Explorer Dim objItem As ContactItem Dim strData As String Dim company, title, vorname, nachname Dim anzahl Dim i Set objOutlook = CreateObject("Outlook.Application") Set objInspector = objOutlook.ActiveInspector Set objExplorer = objOutlook.ActiveExplorer ' Sind wir im Kontakte - Ordner If objExplorer.CurrentFolder.DefaultItemType <> olContactItem Then MsgBox "Kontakte-Ordner ist nicht geöffnet. Abbruch des Makros" GoTo ProcExit End If ' Anzahl der ausgewählten Elemente ermitteln anzahl = objExplorer.Selection.count ' Mindestens ein Element sollte ausgewählt sein If anzahl > 0 Then For i = 1 To anzahl Set objItem = objExplorer.Selection.Item(i) ' objInspector.CurrentItem 'Here is where we concatenate all fields 'use the Object Browser to identify 'all the ContactItem fields you would like to have in your address ' Nachfolgend wird die Adresse zusammengebastelt ' START ******************* anpassbar ' dieser Teil kann nach eigenen Bedürfnissen angepasst werden ' ' vbCrLf erzeugt einen Zeilenumbruch ' ' nur dann ein Leerzeichen anfügen, wenn die Daten vorhanden sind title = CheckData(objItem.title) vorname = CheckData(objItem.FirstName) strData = strData & title & vorname & objItem.LastName & vbCrLf company = objItem.CompanyName If Trim(company) <> "" Then strData = strData & company & vbCrLf End If strData = strData & objItem.MailingAddressStreet & vbCrLf & vbCrLf strData = strData & objItem.MailingAddressPostalCode & " " & _ objItem.MailingAddressCity & vbCrLf & vbCrLf 'Street, City, State,Zip ' ENDE ******************* anpassbar Next 'Call the SetClipboard routine ClipBoard_SetData (strData) Else MsgBox "Bitte mindestens einen Kontakt auswählen" End If ProcExit: Set objOutlook = Nothing Set objInspector = Nothing Set objExplorer = Nothing Set objItem = Nothing Exit Sub ProcError: MsgBox "Unerwarteter Fehler in CopyAdress2Clipboard. Error code: " & _ Err & ", " & Err.Description, vbCritical Resume ProcExit End Sub '*********************************************************** ' ' Kopiert Name und E-Mailadresse in Clipboard ' '*********************************************************** Public Sub CopyNameEmail2Clipboard() On Error GoTo ProcError Dim objOutlook As Outlook.Application Dim objInspector As Inspector Dim objExplorer As Explorer Dim objItem As ContactItem Dim strData As String Dim company, title, vorname, nachname Dim anzahl Dim i Set objOutlook = CreateObject("Outlook.Application") Set objInspector = objOutlook.ActiveInspector Set objExplorer = objOutlook.ActiveExplorer ' Sind wir im Kontakte - Ordner If objExplorer.CurrentFolder.DefaultItemType <> olContactItem Then MsgBox "Kontakte-Ordner ist nicht geöffnet. Abbruch des Makros" GoTo ProcExit End If ' Anzahl der ausgewählten Elemente ermitteln anzahl = objExplorer.Selection.count ' Mindestens ein Element sollte ausgewählt sein If anzahl > 0 Then For i = 1 To anzahl Set objItem = objExplorer.Selection.Item(i) ' objInspector.CurrentItem 'Here is where we concatenate all fields 'use the Object Browser to identify 'all the ContactItem fields you would like to have in your address ' Nachfolgend wird die Adresse zusammengebastelt ' START ******************* anpassbar ' dieser Teil kann nach eigenen Bedürfnissen angepasst werden ' ' vbCrLf erzeugt einen Zeilenumbruch ' ' nur dann ein Leerzeichen anfügen, wenn die Daten vorhanden sind title = CheckData(objItem.title) vorname = CheckData(objItem.FirstName) strData = strData & title & vorname & objItem.LastName & " " strData = strData & objItem.Email1Address & vbCrLf ' ENDE ******************* anpassbar Next 'Call the SetClipboard routine ClipBoard_SetData (strData) Else MsgBox "Bitte mindestens einen Kontakt auswählen" End If ProcExit: Set objOutlook = Nothing Set objInspector = Nothing Set objExplorer = Nothing Set objItem = Nothing Exit Sub ProcError: MsgBox "Unerwarteter Fehler in CopyAdress2Clipboard. Error code: " & _ Err & ", " & Err.Description, vbCritical Resume ProcExit End Sub ' fügt ein Leerzeichen an übergebenen String, wenn dieser nicht leer ist Private Function CheckData(ByVal Daten As String) If Daten <> "" Then CheckData = Daten & " " Else CheckData = Daten End If End Function Private Function ClipBoard_SetData(MyString As String) Dim hGlobalMemory As Long, lpGlobalMemory As Long Dim hClipMemory As Long, X As Long ' Allocate movable global memory. '------------------------------------------- hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) ' Lock the block to get a far pointer ' to this memory. lpGlobalMemory = GlobalLock(hGlobalMemory) ' Copy the string to this global memory. lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) ' Unlock the memory. If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Could not unlock memory location. Copy aborted." GoTo OutOfHere2 End If ' Open the Clipboard to copy data to. If OpenClipboard(0&) = 0 Then MsgBox "Could not open the Clipboard. Copy aborted." Exit Function End If ' Clear the Clipboard. X = EmptyClipboard() ' Copy the data to the Clipboard. hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Could not close Clipboard." End If End Function 'End Module Code