AW: Datei von Notes in Excel einfügen?
03.03.2004 23:25:19
Martin M.
Hallo D.H.
Da Lotus Script zum größten Teil aus VB besteht ist es für einen VBA-Profi kein Problem die Daten in eine Exceldatei zu schreiben. Den folgenden Code verwende ich in einer Lotus Notes Datenbank und erstelle damit einen Kalender in Excel. Du wirst darin sicher etwas finden, was du brauchen kannst.
Grüße
Martin M.
Sub KalenderInExcel
'On Error Goto Errorhandler
Dim ws As New NotesUIWorkspace
Dim session As New NotesSession
Dim db As NotesDatabase
Dim docMG As NotesDocument 'Medienplan
Dim dateTime As New NotesDateTime( "01/01/95" )
Dim collectionMG As NotesDocumentCollection
Dim y As Integer
Dim i As Integer
Dim RecTemp
Dim AD As Long
Dim Kriterium As String
Dim DatumVon As NotesDateTime
Dim DatumBis As NotesDateTime
Dim acl As NotesACL
Dim entry As NotesACLEntry
Dim PreiseAnzeigen As Variant
Const FarbeFeiertage = 36
Const FarbeUeberschriftFelder = 35
Const FarbeUeberschriftMonat = 35
Const AzSpalten = 9 'Spalten in der Exceltabelle
Const TitelMsgbox = "Kalender in Excel"
Set db = session.CurrentDatabase
Dim userName As New NotesName(session.UserName)
Set acl = db.ACL
Set entry = acl.GetEntry( userName.Abbreviated )
'Kontrollieren ob Preise angezeigt werden sollen
PreiseAnzeigen = False
If entry.IsRoleEnabled( "[PREISE]" ) Then
PreiseAnzeigen = True
End If
'Dokumente suchen
Kriterium= "Form = ""frmMedienPlan"""
Set collectionMG = db.Search(Kriterium, datetime, 0 )
AD = collectionMG.count
If AD > 0 Then
'Excel sheet erstellen
Dim xlsheet
Dim xlwb
Dim xlApp
Dim Zeile As Long
Dim Spalte As Integer
Stop
'Excel aktivieren
On Error Resume Next
Set xlApp = getobject(,"Excel.Application")
If Err > 0 Then
On Error Goto 0
Set xlApp = createobject("Excel.Application")
'xlapp.visible = True
Set xlwb = xlapp.workbooks.add
xlwb.SaveAs("c:\xltemp.xls")
xlwb.close
Set xlApp = Nothing
Set xlwb = Nothing
Set xlwb = getobject("c:\xltemp.xls")
Set xlApp = getobject(,"Excel.Application")
xlwb.close
Kill "c:\xltemp.xls"
End If
On Error Goto 0
'Neues Workbook erstellen
Set xlwb = xlapp.workbooks.add
'Actives Sheet zuweisen
Set xlsheet = xlwb.activesheet
' xlapp.visible = True
'Spalten formatieren
With xlsheet
.Columns("A:A").ColumnWidth = 12
.Columns("B:B").ColumnWidth = 11
.Columns("B:B").NumberFormat = "TTTT"
.Columns("B:B").HorizontalAlignment = -4131
.Columns("C:C").ColumnWidth = 13
.Columns("D:D").ColumnWidth = 16
.Columns("E:E").ColumnWidth = 22
.Columns("F:F").ColumnWidth = 24
.Columns("G:G").NumberFormat = "#.##0,00"
.Columns("G:G").ColumnWidth = 16
.Columns("H:H").NumberFormat = "@"
.Columns("H:H").HorizontalAlignment = -4108
.Columns("H:H").ColumnWidth = 8
.Columns("I:I").NumberFormat = "#.##0,00"
.Columns("I:I").ColumnWidth = 16
.Columns("A:I").WrapText = True 'Zeilenumbruch
End With
'Geht alle Dokumente in der Collection durch und schreibt sie in Excel
For i = 1 To AD
Print "Excelkalender wird erstellt. "
Set docMG = collectionMG.GetNthDocument( i )
Set DatumVon = New NotesDateTime(docMG.DatSchaltVon(0))
Set DatumBis = New NotesDateTime(docMG.DatSchaltBis(0))
'Wenn Datum bis > als Datum von ist, wird für jeden Tag ein Datensatz angelegt
Do
Zeile = Zeile + 1
xlsheet.cells(Zeile,1) = Cdat(DatumVon.DateOnly)
xlsheet.cells(Zeile,2) = Cdat(DatumVon.DateOnly)
xlsheet.cells(Zeile,3) = docMG.Auftraggeber(0)
xlsheet.cells(Zeile,4) = docMG.Lieferant(0)
xlsheet.cells(Zeile,5) = docMG.NameKampagne(0)
xlsheet.cells(Zeile,6) = docMG.Platz(0)
If PreiseAnzeigen Then
xlsheet.cells(Zeile,7) = Cdbl(docMG.PreisPreisliste(0))
xlsheet.cells(Zeile,8) = Cstr(docMG.RabattProzent(0)) & "%"
xlsheet.cells(Zeile,9) = Cdbl(docMG.PreisNetto(0))
End If
DatumVon.AdjustDay(1)
Loop Until DatumBis.TimeDifference(DatumVon) < 0
Next i
'Werte in Excel sortieren
xlsheet.columns("A:I").sort xlsheet.cells(1,1),1
Print "Excelkalender: leere Tage einfügen..."
'Fehlende Tage zwischen den vorhandenen Daten einfügen
'Bei letzter Zeile anfangen und immer mit der vorhergehenden Zeile vergleichen.
Dim LetzteZeile As Long
LetzteZeile = Zeile
Do
If Zeile = 1 Then Exit Do
If Cdat(xlsheet.cells(Zeile,1).value - 1) > Cdat(xlsheet.cells(Zeile-1,1).value) Then
xlsheet.Rows(Zeile & ":" & Zeile).Insert
'Durch das Insert bleibt die Variable Zeile unverändert
xlsheet.cells(Zeile,1) = xlsheet.cells(Zeile+1,1).value - 1
xlsheet.cells(Zeile,2) = xlsheet.cells(Zeile+1,1).value - 1
LetzteZeile = LetzteZeile +1
Else
Zeile = Zeile - 1
End If
Loop Until Zeile = 1
Zeile = LetzteZeile
'Tage bis zum Jahresende erstellen
Dim Jahr As Integer
Jahr = Year(Cdat(xlsheet.cells(Zeile,1).value))
Do
Zeile = Zeile +1
xlsheet.cells(Zeile,1) = xlsheet.cells(Zeile-1,1).value + 1
xlsheet.cells(Zeile,2) = xlsheet.cells(Zeile-1,1).value + 1
Loop Until Cdat(xlsheet.cells(Zeile,1).value) = Cdat("31.12." & Jahr)
'Tage bis zum Jahresanfang erstellen
'(Die Variable Zeile wird weitergezählt, so daß am Ende die Gesamtanzahl an Zeilen bekannt ist)
Do
Zeile = Zeile + 1
xlsheet.Rows("1:1").Insert
xlsheet.cells(1,1) = xlsheet.cells(2,1).value - 1
xlsheet.cells(1,2) = xlsheet.cells(2,1).value - 1
Loop Until Cdat(xlsheet.cells(1,1).value) = Cdat("01.01." & Jahr)
Print "Excelkalender: Überschriften einfügen..."
'Tabelle formatieren
Dim Tag As Integer
Dim TagV As Integer
Dim WTag As Integer
Dim Monat As Integer
Dim MMMM(1 To 12) As String
MMMM(1) = "Januar"
MMMM(2) = "Februar"
MMMM(3) = "März"
MMMM(4) = "April"
MMMM(5) = "Mai"
MMMM(6) = "Juni"
MMMM(7) = "Juli"
MMMM(8) = "August"
MMMM(9) = "September"
MMMM(10) = "Oktober"
MMMM(11) = "November"
MMMM(12) = "Dezember"
LetzteZeile = Zeile
Do
'TagV ist der Tag in der Zeile -1 (braucht es für die Spaltenüberschriften)
TagV = 0
If Zeile > 1 Then TagV = Day(Cdat(xlsheet.cells(Zeile-1,1).value))
Tag = Day(Cdat(xlsheet.cells(Zeile,1).value))
WTag = Weekday(Cdat(xlsheet.cells(Zeile,1).value))
'Feiertage formatieren
If WTag = 1 Or WTag = 7 Then
xlsheet.Range(xlsheet.cells(Zeile,1),xlsheet.cells(Zeile,AzSpalten)).Interior.ColorIndex = FarbeFeiertage
End If
'Wenn mehrere Zeilen für das gleiche Datum vorhanden sind, soll nur das erste übrig bleiben. Die anderen Datumswerte werden gelöscht
If Zeile > 1 Then
If Cdat(xlsheet.cells(Zeile,1).value) = Cdat(xlsheet.cells(Zeile-1,1).value) Then
xlsheet.cells(Zeile,1).value = ""
xlsheet.cells(Zeile,2).value = ""
End If
End If
'Bei Monatsanfang wird eine Überschriftszeile mit den Feldbeschreibungen und eine Überschriftszeile mit dem Monat
'sowie 2 Leerzeilen eingefügt. Da pro Tag mehrere Einträge sein können und für jeden Eintrag eine Zeile gemacht wird,
'wird kontrolliert, ob der 1. zwei mal hintereinander vorkommt. Wenn ja, wird die Monatsanfangformatierung übersprungen, so lange bis der letzte 1. erreicht wird
If Tag = 1 And TagV <> 1 Then
xlsheet.Rows(Zeile & ":" & Zeile).Insert
LetzteZeile = LetzteZeile + 1
'Beim Insert bleibt die Variable Zeile gleich
'Überschriften in die neue Zeile schreiben und formatieren
xlsheet.cells(Zeile,1) = "Datum"
xlsheet.cells(Zeile,2) = "Tag"
xlsheet.cells(Zeile,3) = "Auftraggeber"
xlsheet.cells(Zeile,4) = "Lieferant"
xlsheet.cells(Zeile,5) = "Kampagne"
xlsheet.cells(Zeile,6) = "Platz"
xlsheet.cells(Zeile,7) = "Brutto-Preis"
xlsheet.cells(Zeile,8) = "Rabatt"
xlsheet.cells(Zeile,9) = "Netto-Preis"
xlsheet.Rows(Zeile & ":" & Zeile).Font.Bold = True
xlsheet.Range(xlsheet.cells(Zeile,1),xlsheet.cells(LetzteZeile,AzSpalten)).Borders.LineStyle = 1
With xlsheet.Range(xlsheet.cells(Zeile,1),xlsheet.cells(Zeile,AzSpalten))
.Interior.ColorIndex = FarbeUeberschriftFelder
.WrapText = False
.HorizontalAlignment = -4108
End With
'Noch eine Zeile einfügen, Monat hineinschreiben und formatieren
xlsheet.Rows(Zeile & ":" & Zeile).Insert
Monat = Month(xlsheet.cells(Zeile+2,1).value)
Jahr = Year(xlsheet.cells(Zeile+2,1).value)
With xlsheet.cells(Zeile,1)
.NumberFormat = "@"
.WrapText = False
.value = MMMM(Monat) & " " & Cstr(Jahr)
End With
With xlsheet.Range(xlsheet.cells(Zeile,1),xlsheet.cells(Zeile,AzSpalten))
.Font.Bold = True
' .Borders.LineStyle = 1
' .Borders(11).LineStyle = -4172
.Borders(8).LineStyle = 1 'oben
.Borders(9).LineStyle = 1 'unten
.Interior.ColorIndex = FarbeUeberschriftMonat
.HorizontalAlignment = -4131
End With
xlsheet.cells(Zeile,1).Borders(7).LineStyle = 1 'ganz links
xlsheet.cells(Zeile,AzSpalten).Borders(10).LineStyle = 1 'ganz rechts
'2 Leerzeilen einfügen
xlsheet.Rows(Zeile & ":" & Zeile).Insert
xlsheet.Rows(Zeile & ":" & Zeile).Insert
If Zeile = 1 Then Exit Do
'Seitenumbruch einfügen
'ActiveWindow.SelectedSheets.HPageBreaks.Add (ActiveCell)
xlsheet.HPageBreaks.Add (xlsheet.Rows(Zeile & ":" & Zeile))
LetzteZeile = Zeile -1
End If
Zeile = Zeile - 1
Loop
'Überschrift im Excelblatt
With xlsheet.Range("A1")
.Font.Name = "Arial"
.Font.Size = 14
.Font.Bold = True
.Font.ColorIndex = 0
.HorizontalAlignment = -4131
.WrapText = False
.value = "Raiffeisen Medienplanung - " & Jahr
End With
Print "Excelkalender: Seiteneinstellungen..."
'Druckereinstellungen
With xlsheet.PageSetup
.LeftMargin = xlApp.InchesToPoints(0.19)
.RightMargin = xlApp.InchesToPoints(0.19)
.TopMargin = xlApp.InchesToPoints(0.30)
.BottomMargin = xlApp.InchesToPoints(0.30)
.HeaderMargin = xlApp.InchesToPoints(0.10)
.FooterMargin = xlApp.InchesToPoints(0.10)
.PrintHeadings = False
.PrintGridlines = False
.CenterHorizontally = True
'.CenterVertically = True
.Orientation = 2
.FitToPagesWide = 1
.FitToPagesTall = 12
.PrintTitleRows = "$1:$2"
End With
'Gitternetzlinien ausblenden und Anzeige auf n% verkleinern
xlapp.ActiveWindow.DisplayGridlines = False
xlapp.ActiveWindow.Zoom = 85
xlwb.saved = True
xlapp.visible = True
Set xlwb = Nothing
Set xlapp = Nothing
Appactivate ("Microsoft Excel")
'Seitenansicht anzeigen
Call xlsheet.PrintPreview
Else
Msgbox "Keine Medienplanungen vorhanden" , 0 , "Kalender in Excel"
End If 'AD > 0
Ende:
Exit Sub
ErrorHandler:
Msgbox "Unbekannter Fehler im Programm ""KalenderInExcel"". Verständigen Sie bitte die Anwenderbetreuung." , 48 , TitelMsgbox
Resume Ende
End Sub