(Jahres-) Kalender erstellen |
|
In VBA stehen verschiedene Funktionen zur Berechnung und Darstellung von Datumsangaben zur Verfügung. Als Beispiel für die Verwendung dieser Funktionen wird mit dem folgenden Makro ein Kalender erstellt, der für jeden Monat die Wochentage (mit Wochentagsnamen) auflistet und dabei Platz für kurze Einträge pro Tag besitzt (Siehe Beispiel). Für den Kalender lassen sich folgende Angaben festlegen:
Aus diesen Angaben wir das Anfangsdatum erzeugt und der Variablen data vom Typ Date zugewiesen. Mit Hilfe der Funktionen Weekday(data) und Format(data, "d") werden die verschiedenen benötigten Datumsformate (Monatsname, Tag, Wochentag) ermittelt und in die entsprechenden Tabellenzellen eingetragen. Zum Schluss werden aus den Kalenderangaben die Informationen für die Kopfzeile des Kalenders berechnet und eingetragen. Attribute VB_Name = "Kalender" Option Explicit Dim tblTable As Table Dim strMonat(12) As String Dim data As Date Dim strMonatstrActTag(12, 31) As Integer Dim strWochentag, strActMonat, strActTag As String Dim oDoc As Document Dim tblActCell As Cell Dim intStartMonat, intJahr, intStartJahr, intMaxMonate As Integer Dim intMonat, intSpalte As Integer Dim strmsg As String Const cTitle = "Kalender erstellen" System.Cursor = wdCursorWait ' Daten abfragen Do strmsg = "In welchem Jahr beginnt der Kalendar?" intStartJahr = InputBox(strmsg, cTitle, Year(Now)) If intStartJahr = "" Then End Loop While IsNumeric(intStartJahr) = False Do strmsg = "Mit welchem Monat soll der Kalender beginnen (1-12)?" intStartMonat = InputBox(strmsg, cTitle, Month("1/ 1/" & intStartJahr)) If intStartJahr = "" Then End Loop While (Not IsNumeric(intStartMonat)) Or 1> intStartMonat Or intStartMonat >12 Do strmsg = "Wie viele Monate sollen angezeigt werden (1-12)?" intMaxMonate = InputBox(strmsg, cTitle, "12") If intStartJahr = "" Then End Loop While IsNumeric(intMaxMonate) = False intJahr = intStartJahr ' Datum des ersten Kalendertages ermitteln data = "1/ " & Val(intStartMonat) & "/ " & intJahr strWochentag = Weekday(data) ' Neues Dokument anlegen und ausrichten Set oDoc = Documents.Add oDoc.PageSetup.PaperSize = wdPaperA4 oDoc.PageSetup.Orientation = wdOrientLandscape 'GoTo weiter: ' Tabelle anlegen Set tblTable = oDoc.Tables.Add(Selection.Range, 32, intMaxMonate) With tblTable intMonat = intStartMonat For intSpalte = 1 To intMaxMonate ' Jahreswechsel If intMonat = 13 Then intMonat = 1 intJahr = intJahr + 1 End If 'Monatsnamen ermitteln strMonat(intMonat) = Format("1/" & intMonat & "/ " & intJahr, "mmmm") DoEvents Set tblActCell = .Cell(1, intSpalte) ' Kopfzeile mit Monatsnamen formatieren With tblActCell .Range.InsertAfter strMonat(intMonat) .Range.Font.Bold = True .Range.Font.Size = 11 .Shading.BackgroundPatternColor = wdColorGray25 End With ' Jahreswechsel hervorheben If intMonat = 12 Then .Columns(intSpalte).Borders(wdBorderRight).LineStyle = wdLineStyleDoubleWavy End If strActMonat = Format(data, "mm") ' Alle Tage eines Monats bearbeiten Do While Val(strActMonat) = intMonat strActTag = Format(data, "dd") Set tblActCell = .Cell(strActTag + 1, intSpalte) With tblActCell .Range.InsertAfter Format(data, "d") .Range.Font.Bold = False .Range.Font.Size = 8 .Height = 12 .VerticalAlignment = wdCellAlignVerticalCenter ' Tageskürzel ermitteln und eintragen Select Case Weekday(data) Case vbSunday .Range.InsertAfter " So" ' Sonntage werden hervorgehoben .Range.Shading.BackgroundPatternColor = wdColorGray25 Case vbMonday .Range.InsertAfter " Mo" Case vbTuesday .Range.InsertAfter " Di" Case vbWednesday .Range.InsertAfter " Mi" Case vbThursday .Range.InsertAfter " Do" Case vbFriday .Range.InsertAfter " Fr" Case vbSaturday .Range.InsertAfter " Sa" End Select End With data = data + 1 strActMonat = Format(data, "mm") Loop ' nächster Monat intMonat = intMonat + 1 Next intSpalte End With weiter: ' Überschrift in Kopfzeile erstellen Dim oHeader As View Dim msg As String Dim intEndMonat, intEndJahr, int_berlauf As Integer ' Jahreswechsel berücksichtigen und korrekten Endmonat ermitteln If intStartMonat + intMaxMonate - 1 > 12 Then int_berlauf = Int((intStartMonat + intMaxMonate - 1) / 12) intEndMonat = intStartMonat + intMaxMonate - 1 - 12 * int_berlauf intEndJahr = intStartJahr + int_berlauf ElseIf intStartMonat + intMaxMonate - 1 = 12 Then intEndMonat = intStartMonat + intMaxMonate - 1 intEndJahr = intStartJahr Else intEndMonat = intStartMonat + intMaxMonate - 1 intEndJahr = intStartJahr + Int((intStartMonat + intMaxMonate - 1) / 12) End If ' Text für die Kopfzeile zusammensetzen msg = "Kalenderübersicht von " & intStartMonat & " / " & intStartJahr & " bis " _ & intEndMonat & " / " & intEndJahr ' _berschrift in Kopfzeile einfügen und formatieren Set oHeader = oDoc.ActiveWindow.View oHeader.SplitSpecial = wdPaneCurrentPageHeader With Selection .InsertAfter msg .Font.Size = 12 .Font.Bold = True .Paragraphs.Alignment = wdAlignParagraphCenter End With ' Ansicht zurücksetzen System.Cursor = wdCursorNormal oHeader.SplitSpecial = wdPaneNone End Sub Eine erweiterte Version als Dokumentvorlage findet Ihr hier.
|
Besucher: 0 online | 0 heute | 0 diesen Monat | 2214344 insgesamt | Seitenaufrufe: 72 | Letzte Änderung: 24.06.2006 | © 2001-18 Christian Freßdorf | ||||
Liebe ist das einzige, was wächst, indem wir es verschwenden. Ricarda Huch |
powered by phpCMS and PAX |