Link per VBA in Lotus Notes message einfügen

Sub NotesMail() Dim strEmpfaenger, strBetreff, strText, strcc, strbcc As String Dim strFile As String Dim Link As String Link = ThisWorkbook.Worksheets(1).Cells(2, 5).Value strEmpfaenger = "Sven.Schmitt@xxxxxxxxx.com" strBetreff = "BetreffText" strText = "Test" strText = "Die neuen Pi's sind verfügbar im anhang deine Werke zum aktualisieren" & " " & Link strFile = "D:\logo.sys" 'ActiveDocument.FullName NotesMailSend strEmpfaenger, strBetreff, strText, strcc, _ strbcc, strFile End Sub

Function NotesMailSend(strEmpfaenger As Variant, strBetreff As Variant, _ strText As Variant, strcc As Variant, strbcc As Variant, strFilename As _ String) ' Dimensionierung der Objektvariablen Dim objNotes As Object, objNotesDB As Object, objNotesMailDoc As Object Dim SendItem, NCopyItem, BlindCopyToItem, i As Integer, rtitem Dim msg As String ' ' Zuweisung der Objektvariablen 'On Error GoTo ExitF Set objNotes = GetObject("", "Notes.Notessession") Set objNotesDB = objNotes.GETDATABASE("", "") ' Öffnen der Standard-Maildatenbank / Erstellen neues Maildokument Call objNotesDB.OPENMAIL Set objNotesMailDoc = objNotesDB.createdocument objNotesMailDoc.Form = "Memo" Call objNotesMailDoc.Save(True, False) Set SendItem = objNotesMailDoc.APPENDITEMVALUE("SendTo", "") Set NCopyItem = objNotesMailDoc.APPENDITEMVALUE("CopyTo", "") Set BlindCopyToItem = objNotesMailDoc.APPENDITEMVALUE("BlindCopyTo", "") objNotesMailDoc.SendTo = strEmpfaenger objNotesMailDoc.Subject = strBetreff Set rtitem = objNotesMailDoc.CREATERICHTEXTITEM("Body") objNotesMailDoc.Body = strText rtitem.ADDNEWLINE (1) Call rtitem.EMBEDOBJECT(1454, "", strFilename) ' Mail zustellen Call objNotesMailDoc.Save(True, False) Call objNotesMailDoc.SEND(False) objNotesMailDoc.RemoveItem ("DeliveredDate") Call objNotesMailDoc.Save(True, False) ' Nachricht an Benutzer msg = "Die E-Mail wurde erfolgreich versendet!" MsgBox msg, vbInformation, "Notesmail versenden..." ' Objektvariablen zurücksetzen Call objNotes.Close ' Leider funktioniert der Quit-Befehl aus irgend einem Grund nicht. 'objNotes.Quit Set objNotes = Nothing ExitF: End Function

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Const MAX_PATH As Long = 260 Private Const ERROR_SUCCESS As Long = 0 Private Declare Function UrlCreateFromPath Lib "Shlwapi" _ Alias "UrlCreateFromPathA" _ (ByVal pszPath As String, _ ByVal pszUrl As String, _ pcchUrl As Long, _ ByVal dwReserved As Long) As Long Private Function FilenameToURL(ByVal sPath As String) As String Dim sUrl As String Dim dwSize As Long If Len(sPath) > 0 Then sUrl = Space$(MAX_PATH) dwSize = Len(sUrl) If UrlCreateFromPath(sPath, _ sUrl, _ dwSize, _ 0&) = ERROR_SUCCESS Then FilenameToURL = Left$(sUrl, dwSize) End If 'If UrlCreateFromPath End If 'If Len(sUrl) > 0 End Function

Nee genau das ist mein Vorhaben ^^ Ich hab mal deinen Code hinzugefügt und die Variable ersetzt _ leider kommt in der lletzten Zeile der


Private Function FilenameToURL "End Function

" der Fehler Objekt erforderlich.
Weis gerade nicht was ich falsch gemacht habe?
Private Const MAX_PATH As Long = 260
Private Const ERROR_SUCCESS As Long = 0
Private Declare Function UrlCreateFromPath Lib "Shlwapi" _
Alias "UrlCreateFromPathA" _
(ByVal pszPath As String, _
ByVal pszUrl As String, _
pcchUrl As Long, _
ByVal dwReserved As Long) As Long
Sub NotesMail()
Dim strEmpfaenger, strBetreff, strText, strcc, strbcc As String
Dim strFile As String
Dim Link As String
Dim E_MailAdress As String
Dim Bearbeiter As String
'finish = 1
'x = 2
'
''MsgBox (Date)
'
'Do Until finish = Empty
'
'Bearbeiter = ThisWorkbook.Worksheets(1).Cells(x, 6).Value
'
'y = ThisWorkbook.Worksheets(2).Cells.Find(What:=Bearbeiter, LookIn:=xlFormulas, LookAt _
' :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
' False, SearchFormat:=False).Row
'
'E_MailAdress = ThisWorkbook.Worksheets(2).Cells(y, 2).Value
'
'If Bearbeiter = ThisWorkbook.Worksheets(1).Cells(x, 6).Value Then
'n x = ThisWorkbook.Worksheets(1).Cells(x, 6).Value
'End If
'
'
'
'
'finish = finish + 1
'
'Loop
strFilename = ThisWorkbook.Worksheets(1).Cells(2, 5).Value
rtitem.AppendText = FilenameToURL(strFilename)
'strEmpfaenger = E_MailAdress
strEmpfaenger = "Sven.2.xxxxxx.com"
strBetreff = "KPI" & Date
strText = "Test"
strText = "Hallo Barbara,die neuen Pi's sind verfügbar im anhang deine Werke zum aktualisieren" & " " & "URL LinK"
strFile = "D:\logo.sys" 'ActiveDocument.FullName
NotesMailSend strEmpfaenger, strBetreff, strText, strcc, _
strbcc, strFile
End Sub
Function NotesMailSend(strEmpfaenger As Variant, strBetreff As Variant, _
strText As Variant, strcc As Variant, strbcc As Variant, strFilename As _
String)
' Dimensionierung der Objektvariablen
Dim objNotes As Object, objNotesDB As Object, objNotesMailDoc As Object
Dim SendItem, NCopyItem, BlindCopyToItem, i As Integer, rtitem
Dim msg As String
'
' Zuweisung der Objektvariablen
'On Error GoTo ExitF
Set objNotes = GetObject("", "Notes.Notessession")
Set objNotesDB = objNotes.GETDATABASE("", "")
' Öffnen der Standard-Maildatenbank / Erstellen neues Maildokument
Call objNotesDB.OPENMAIL
Set objNotesMailDoc = objNotesDB.createdocument
objNotesMailDoc.Form = "Memo"
Call objNotesMailDoc.Save(True, False)
Set SendItem = objNotesMailDoc.APPENDITEMVALUE("SendTo", "")
Set NCopyItem = objNotesMailDoc.APPENDITEMVALUE("CopyTo", "")
Set BlindCopyToItem = objNotesMailDoc.APPENDITEMVALUE("BlindCopyTo", "")
objNotesMailDoc.SendTo = strEmpfaenger
objNotesMailDoc.Subject = strBetreff
Set rtitem = objNotesMailDoc.CREATERICHTEXTITEM("Body")
objNotesMailDoc.Body = strText
rtitem.ADDNEWLINE (1)
Call rtitem.EMBEDOBJECT(1454, "", strFilename)
' Mail zustellen
Call objNotesMailDoc.Save(True, False)
Call objNotesMailDoc.SEND(False)
objNotesMailDoc.RemoveItem ("DeliveredDate")
Call objNotesMailDoc.Save(True, False)
' Nachricht an Benutzer
msg = "Die E-Mail wurde erfolgreich versendet!"
MsgBox msg, vbInformation, "Notesmail versenden..."
' Objektvariablen zurücksetzen
Call objNotes.Close
' Leider funktioniert der Quit-Befehl aus irgend einem Grund nicht.
'objNotes.Quit
Set objNotes = Nothing
ExitF:
End Function

Private Function FilenameToURL(ByVal sPath As String) As String
Dim sUrl As String
Dim dwSize As Long
If Len(sPath) > 0 Then
sUrl = Space$(MAX_PATH)
dwSize = Len(sUrl)
If UrlCreateFromPath(sPath, _
sUrl, _
dwSize, _
0&) = ERROR_SUCCESS Then
FilenameToURL = Left$(sUrl, dwSize)
End If  'If UrlCreateFromPath
End If   'If Len(sUrl) > 0
End Function

Beliebteste Forumthreads (12 Monate)

Link per VBA in Lotus Notes message einfügen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

315 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Link per VBA in Lotus Notes message einfügen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

315 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread