Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
REM ***** BASIC *****
Option Explicit
Dim gdteBirth As Date
Dim gdteNow As Date
Sub Main
Const WEEKS = 52
Const LIFESPAN = 90
Const COLUMN_OFFSET = 1
Const ROW_OFFSET = 5
Const BOX_SIZE = 450
Const SPACER_SIZE = 200
Dim objCalc As Object
Dim objSheet As Object
Dim objCell As Object
Dim intColCount As Integer
Dim intRowCount As Integer
Dim strSheetName As String
'Initialize dates for display
gdteBirth = DateSerial(1978,1,11)
gdteNow = Now() 'DateSerial(1978,2,13)
objCalc = ThisComponent
strSheetName = "Life Calendar"
'Initialize sheets
InitializeSheets(strSheetName)
objSheet = objCalc.Sheets(0)
'Set the column widths for 52 weeks * 2
For intColCount = COLUMN_OFFSET To WEEKS * 2 + (COLUMN_OFFSET - 1)
Select Case (intColCount Mod 2)
Case 0
objSheet.Columns(intColCount).Width = BOX_SIZE
Case 1
objSheet.Columns(intColCount).Width = SPACER_SIZE
End Select
Next
'Set the row height for 90 years 0 - 89
For intRowCount = ROW_OFFSET To LIFESPAN * 2 + (ROW_OFFSET - 1)
Select Case (intRowCount Mod 2)
Case 0
objSheet.Rows(intRowCount).Height = BOX_SIZE
Case 1
objSheet.Rows(intRowCount).Height = SPACER_SIZE
End Select
Next
'Populate column headings
For intColCount = 1 To WEEKS
objSheet.getCellByPosition(intColCount * 2 + (COLUMN_OFFSET - 1),0).Value = intColCount
Next
'Populate row headings
For intRowCount = 0 To LIFESPAN - 1
objSheet.getCellByPosition(0, intRowCount * 2 + (ROW_OFFSET + 1)).Value = intRowCount
Next
'Draw borders around cells
For intRowCount = 0 To LIFESPAN - 1
For intColCount = 1 To WEEKS
DrawBorder(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1))
'Colour in boxes to signify things
'This is where you can add/remove code to colour the life chart in according to life events
'Just change the colour, start and end date
'If dates overlap, the last event called will be the one that is shown on the spreadsheet
'ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1), <colour>, <start>, <end>)
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1), RGB(0,0,0), gdteBirth, gdteNow) 'Life lived
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(200,200,0), DateSerial(1982,9,1), DateSerial(1996,6,1)) 'School
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(1996,8,1), DateSerial(1997,4,25)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(1997,4,4), DateSerial(1997,8,15)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(160,160,0), DateSerial(1997,9,8), DateSerial(2001,5,26)) 'University
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(1998,6,15), DateSerial(1998,8,15)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(1999,7,1), DateSerial(2000,7,1)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(2001,8,1), DateSerial(2003,2,28)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(2003,5,1), DateSerial(2003,8,30)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(2004,4,1), DateSerial(2004,4,26)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(2004,4,1), DateSerial(2004,4,26)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(2004,4,26), DateSerial(2008,9,4)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(2008,10,1), DateSerial(2009,4,30)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(2009,10,28), DateSerial(2010,3,12)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(2010,4,23), DateSerial(2010,5,3)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(2010,4,23), DateSerial(2010,5,3)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(2011,1,1), DateSerial(2011,8,30)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(2012,7,4), DateSerial(2012,10,19)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(2014,4,29), DateSerial(2015,5,7)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(2014,6,16), DateSerial(2015,7,1)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(0,200,200), DateSerial(2015,5,15), DateSerial(2017,8,11)) 'Job
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(120,120,0), DateSerial(2010,7,5), DateSerial(2010,7,31)) 'TESOL course
ColourCell(strSheetName,intColCount * 2 + (COLUMN_OFFSET - 1),intRowCount * 2 + (ROW_OFFSET + 1),RGB(200,200,0), DateSerial(2011,9,5), DateSerial(2012,3,30)) 'Mandarin course
Next
Next
End Sub 'Main
sub ColourCell(strSheetName As String, intCol As Integer, intRow As Integer, lngRGB As Long,dteStart As Date, dteEnd As Date)
Dim intRowHead As Integer
Dim intColHead As Integer
Dim dteCell As Date
'Row heading for cell
intRowHead = ThisComponent.Sheets.getByName(strSheetName).getCellByPosition(0, intRow).Value
'Column heading for cell
intColHead = ThisComponent.Sheets.getByName(strSheetName).getCellByPosition(intCol, 0).Value
'Convert box co-ords to date
dteCell = DateAdd("yyyy", intRowHead, DateAdd("d", intColHead * 7, gdteBirth))
'If the Cell date is between the start and end date arguments, colour it the RGB value argument
If dteCell >= dteStart And dteCell < dteEnd Then
ThisComponent.Sheets.getByName(strSheetName).getCellByPosition(intCol, intRow).CellBackColor = lngRGB
End If
End Sub 'ColourCell
Sub DrawBorder(strSheetName As String, intCol As Integer, intRow As Integer)
Dim objBasicBorder as New com.sun.star.table.BorderLine
Dim objCell As Object
objBasicBorder.Color = RGB(0, 0, 0)
objBasicBorder.InnerLineWidth = 0
objBasicBorder.OuterLineWidth = 2
objBasicBorder.LineDistance = 0
objCell = ThisComponent.Sheets.getByName(strSheetName).getCellByPosition(intCol,intRow).TableBorder
objCell.LeftLine = objBasicBorder
objCell.TopLine = objBasicBorder
objCell.RightLine = objBasicBorder
objCell.BottomLine = objBasicBorder
ThisComponent.Sheets.getByName(strSheetName).getCellByPosition(intCol,intRow).TableBorder = objCell
End Sub 'DrawBorder
Sub InitializeSheets(strSheetName As String)
Dim objCalc As Object
Dim objSheet As Object
Dim strNewSheetName As String
objCalc = ThisComponent
'Create name for sheet that doesn't exist
strNewSheetName = RandomChar()
While objCalc.Sheets.hasByName(strNewSheetName)
strNewSheetName = strNewSheetName & RandomChar()
Wend
'Create new sheet with this name
objCalc.Sheets.insertNewByName(strNewSheetName,0)
'Now delete everything but this sheet
Dim intSheetCount As Integer
intSheetCount = objCalc.Sheets.Count
Dim arrSheets(1 To intSheetCount) As String
Dim intIndex As Integer
'Put all sheet names into an array
For intIndex = 1 To intSheetCount
arrSheets(intIndex) = objCalc.Sheets(intIndex - 1).Name
Next
'For each name in the array, delete the
'sheet with that name if it's not the new one
For intIndex = 1 To intSheetCount
If arrSheets(intIndex) <> strNewSheetName Then
objCalc.Sheets.removeByName(arrSheets(intIndex))
End If
Next
'Now rename the new sheet
objSheet = objCalc.Sheets.getByName(strNewSheetName)
objSheet.Name = strSheetName
End Sub 'InitializeSheets
Function RandomChar() As String
Dim strAllowedChars As String
strAllowedChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" '52 characters long
RandomChar = Mid(strAllowedChars,Int(52*Rnd)+1,1)
End Function 'RandomChar
Owner

nickhubbard commented Aug 11, 2017

This text can be copied in to a LibreOffice Macro module. When run it will create a calendar showing a block for each week for a lifetime of 90 years. You can change the code to colour different life events.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment