Hier ist mein Code, wenn jemand daran Interesse hat und helfen würde, vielen Dank
Option Public
Option Declare
'Use "libSort"
Const COLUMN_COUNT = 9 ' <<< EDIT this value to match the number of columns in the output table
' Error trapping constants
Const ERR_EXITNOMSG = 1000
Const MSG_EXITNOMSG = ""
Const ERR_NODOCSELECTED = 1001
Const MSG_NODOCSELECTED = "Please select the document(s) on which you wish to report."
Dim session As NotesSession
Dim db As NotesDatabase
Dim srv As String
Dim doc As NotesDocument
Dim docAll As NotesDocument
Dim MailDoc As NotesDocument
Dim body As NotesRichTextItem
Dim rtStyle As NotesRichTextStyle
Dim rtHelvPlain8 As NotesRichTextStyle
Dim rtHelv8_Black_Bold As NotesRichTextStyle
Dim rtTable As NotesRichTextTable
Dim rtNav As NotesRichTextNavigator
Dim totalRows As Integer
Dim i As Integer
Dim col As Integer
Dim item As NotesItem
Dim strRptLine As String
Dim isFirstLine As Integer
Dim view As NotesView
Dim viewAll As NotesView
Dim vecAll As NotesViewEntryCollection
Dim vec As NotesViewEntryCollection
Dim ve As NotesViewEntry
Dim key As String
Dim GrVB As Variant
Dim an As String
Dim Betreff As String
Dim Message1 As String
Dim Message2 As String
Dim strErrMsg As String
Dim Woche As Integer
Dim Jahr As Integer
Dim Monat As Integer
Sub Initialize
On Error Goto errHandler
Set session = New NotesSession
Set db = session.CurrentDatabase
Set view=db.getview("Termine")
'Set viewAll=db.getview("TermineAll")
srv = db.Server
Woche = CalculateWeekNo (Today)
Jahr = Year(Today)
Set vecAll = view.AllEntries
'****************************************************************
If Not(vecAll.Count = 0) Then
'****************************************************************************************
Betreff = "PYM -> Terminplanung für " &_
" / " & Jahr & " Kalenderwochen " & Woche_1 & " und " & Woche
an = "UserName"
Set MailDoc = New NotesDocument(db)
MailDoc.Form = "Memo"
MailDoc.Subject = Betreff
MailDoc.SendTo = an
MailDoc.BlindCopyTo = "Sofia Jaschin"
Set body = New NotesRichTextItem( MailDoc , "Body" )
'****************************************************************************************
GrVB = Evaluate({@Name([CN];@DbLookup( "":"NoCache"; "} + srv +_
{" : "names.nsf" ; "($VIMGroups)" ; "VB" ; 3 ))})
Forall Key In GrVB
Set vec = view.GetAllEntriesByKey(key, True)
If Not(vec.Count = 0) Then
Message1 = "Auflistung der Termine für vorherige Kalenderwoche " & Woche_1 &_
" und aktuelle Kalenderwoche " & Woche & " für " & key & Chr(13) & Chr(13)
Message2 = "-> " & key & " / " & Jahr & " / KW" & tmpWoche
Call body.AppendText( Message1)
Call body.AppendText( Message2)
totalRows = vec.Count + 1
Call setRichTextStyles
If Not createReport Then Error ERR_EXITNOMSG, MSG_EXITNOMSG
Call populateTable
End If
End Forall
'****************************************************************************************
MailDoc.Send(False)
'****************************************************************************************
End If
'****************************************************************
finally:
Exit Sub
errHandler:
Select Case Err
Case ERR_EXITNOMSG
' Any needed message was displayed elsewhere, so just exit
Case ERR_NODOCSELECTED
Msgbox MSG_NODOCSELECTED, 64, db.Title
Case Else
strErrMsg = "Error #" & Err & Chr$(10) & Error$ & Chr$(10) & "Line #" & Erl & | in sub/function: "| & Lsi_info(2) & |"|
Msgbox strErrMsg, 16, "Unexpected error"
End Select
Resume finally
End Sub
Sub setRichTextStyles
On Error Goto errHandler
Set rtHelvPlain8 = session.CreateRichTextStyle
rtHelvPlain8.NotesFont = FONT_HELV
rtHelvPlain8.FontSize = 8
rtHelvPlain8.NotesColor = COLOR_BLACK
rtHelvPlain8.Bold = False
rtHelvPlain8.Italic = False
rtHelvPlain8.Underline = False
Set rtHelv8_Black_Bold = session.CreateRichTextStyle
rtHelv8_Black_Bold.NotesFont = FONT_HELV
rtHelv8_Black_Bold.FontSize = 8
rtHelv8_Black_Bold.NotesColor = COLOR_BLACK
rtHelv8_Black_Bold.Bold = True
rtHelv8_Black_Bold.Italic = False
rtHelv8_Black_Bold.Underline = False
finally:
Exit Sub
errHandler:
Dim strMsg As String
strMsg = "Error #" & Err & Chr$(10) & Error$ & Chr$(10) & "Line #" & Erl & | in sub/function: "| & Lsi_info(2) & |"|
Msgbox strMsg, 16, db.Title & ": Unexpected error"
Resume finally
End Sub
Function createReport() As Integer
On Error Goto errHandler
createReport = True
Dim color As NotesColorObject
Dim columnHeader(9) As String
Dim tableColStyles(1 To 9) As NotesRichTextParagraphStyle
columnHeader(1) = "Link" ' Initialize column header values
columnHeader(2) = "Datum"
columnHeader(3) = "Von - Bis"
columnHeader(4) = " Kundenname"
columnHeader(5) = "Kontakt Typ"
columnHeader(6) = " Projektname"
columnHeader(7) = "Produkt"
columnHeader(
= "Zielsetzung"
columnHeader(9) = "Ergebnis"
' Populate the array of NotesRichTextParagraphStyle - one array element (one NotesRichTextParagraphStyle) for each column.
For i = 1 To COLUMN_COUNT Step 1
Set tableColStyles(i) = session.CreateRichTextParagraphStyle ' Create the rt paragraph style for this column
tableColStyles(i).FirstLineLeftMargin = 0 ' Set left margin for the first line of each cell in column
tableColStyles(i).LeftMargin = 0 ' Set left margin for all but the first line of each cell in column
Select Case i
Case 1
tableColStyles(i).RightMargin = RULER_ONE_CENTIMETER * 0.7
tableColStyles(i).Alignment = ALIGN_CENTER
Case 2
'tableColStyles(i).LeftMargin = RULER_ONE_CENTIMETER * 0.1
tableColStyles(i).RightMargin = RULER_ONE_CENTIMETER * 2
Case 3
tableColStyles(i).RightMargin = RULER_ONE_CENTIMETER * 3
Case 4
tableColStyles(i).RightMargin = RULER_ONE_CENTIMETER * 4
Case 5
tableColStyles(i).RightMargin = RULER_ONE_CENTIMETER * 2
Case 6
tableColStyles(i).RightMargin = RULER_ONE_CENTIMETER * 2
tableColStyles(i).Alignment = ALIGN_CENTER
Case 7
tableColStyles(i).RightMargin = RULER_ONE_CENTIMETER * 2
tableColStyles(i).Alignment = ALIGN_CENTER
Case 8
tableColStyles(i).RightMargin = RULER_ONE_CENTIMETER * 2
tableColStyles(i).Alignment = ALIGN_CENTER
Case 9
tableColStyles(i).RightMargin = RULER_ONE_CENTIMETER * 2
tableColStyles(i).Alignment = ALIGN_CENTER
End Select
Next
Call body.AppendTable( totalRows, COLUMN_COUNT,,, tableColStyles)
Set rtNav = body.CreateNavigator
Call rtNav.GetFirstElement(RTELEM_TYPE_TABLE)
Set rtTable= rtNav.GetElement
rtTable.Style = TABLESTYLE_TOP
Set color = session.CreateColorObject ' Create color object for use in setting cell colors
color.NotesColor = COLOR_LIGHT_GRAY
Call rtTable.SetColor( color ) ' Set the top row color to light gray background
color.NotesColor = COLOR_WHITE
Call rtTable.SetAlternateColor( color ) ' Set all rows after the top row to white background
Call rtNav.FindFirstElement( RTELEM_TYPE_TABLECELL ) ' Move to the first cell - row 1, col 1
Call body.AppendStyle( rtHelv8_Black_Bold ) ' Set the font to Helvetica, 8-point, bold black
For col = 1 To COLUMN_COUNT Step 1
Call body.BeginInsert( rtNav )
Call body.AppendText( columnHeader(col) ) ' Write the text for this column's header
Call body.EndInsert ' Move insertion point to the end of this cell
Call rtNav.FindNextElement( RTELEM_TYPE_TABLECELL ) ' Move to the next cell
Next
finally:
Exit Function
errHandler:
createReport = False
Dim strErrMsg As String
Select Case Err
Case Else
strErrMsg = "Error #" & Err & Chr$(10) & Error$ & Chr$(10) & "Line #" & Erl & | in sub/function: "| & Lsi_info(2) & |"|
Msgbox strErrMsg, 16, "Unexpected error"
End Select
Resume finally
End Function
Function populateTable() As Integer
On Error Goto errHandler
populateTable = True ' Function returns TRUE unless we hit an error
Call body.AppendStyle( rtHelvPlain8 ) ' Set font to Helvetica, 8 point, black
If Not(vec.Count = 0) Then
Set ve = vec.GetFirstEntry()
Do Until ve Is Nothing
Set doc= ve.Document
For col = 1 To COLUMN_COUNT Step 1
Call body.BeginInsert( rtNav )
Select Case col ' Populate the detail cells of the table
Case 1
Call body.AppendDocLink( doc, doc.KundenProjektTitel(0))
Case 2
Call body.AppendText( doc.StartDate(0) )
Case 3
Call body.AppendText( doc.TimeRange(0))
Case 4
Call body.AppendText( doc.KundenName(0) )
Case 5
Call body.AppendText( doc.Termin_Kontakt_Typ(0) )
Case 6
Call body.AppendText( doc.KundenProjektTitel(0) )
Case 7
Call body.AppendText( doc.Termin_cIT_Produkt(0) )
Case 8
Call body.AppendText( doc.Termin_Zielsetzung(0) )
Case 9
Call body.AppendText( doc.Termin_Ergebnis(0) )
End Select
Call body.EndInsert
Call rtNav.FindNextElement( RTELEM_TYPE_TABLECELL ) ' Move to the next table cell
Next
Set ve = vec.getNextEntry(ve)
Loop
End If
finally:
Exit Function
errHandler:
populateTable = False
Dim strErrMsg As String
Select Case Err
Case Else
strErrMsg = "Error #" & Err & Chr$(10) & Error$ & Chr$(10) & "Line #" & Erl & | in sub/function: "| & Lsi_info(2) & |"|
Msgbox strErrMsg, 16, "Unexpected error"
End Select
Resume finally
End Function
Gruesse
Sofia
Thema: Mail mit mehrere dynamischen Tabellen (Gelesen 2562 mal)