File "iCalendar Generator.bas"
Path: /iCalendar Generator/iCalendar Generator.bas
File size: 16.31 KB
MIME-type:
Charset: utf-8
#COMPILE EXE "iCalendar Generator.exe"
#DIM ALL
$VER = "0.1"
'------------------------------------------------------------------------------
' ** Includes **
'------------------------------------------------------------------------------
#INCLUDE ONCE "Win32Api.inc"
#INCLUDE ONCE "inc\RTF.inc"
#INCLUDE ONCE "inc\Julian.inc"
'------------------------------------------------------------------------------
#RESOURCE "res\iCalendar Generator.pbr"
'-------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' ** Constants **
'------------------------------------------------------------------------------
%IDC_LABEL1 = 1001
%IDC_LABEL2 = 1002
%IDC_LABEL3 = 1003
%IDC_L_YSTA = 1004 ' Label for Year-Start
%IDC_L_YCNT = 1005 ' Label for Year-Count
%IDC_UD_YSTA = 1006 ' Up-Down control for Year-Start
%IDC_UD_YCNT = 1007 ' Up-Down control for Year-Count
%IDC_T_YSTA = 1008 ' Textbox control for Year-Start
%IDC_T_YCNT = 1009 ' Textbox control for Year-Count
%IDC_BUTTON1 = 1010
%IDC_BUTTON2 = 1011
%IDC_TEXTBOX = 1012
'------------------------------------------------------------------------------
' ** Globals **
'------------------------------------------------------------------------------
GLOBAL evok AS LONG
GLOBAL evko AS LONG
GLOBAL icsf AS STRING
GLOBAL erli AS STRING
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' ** Main Application Entry Point **
'------------------------------------------------------------------------------
FUNCTION PBMAIN()
LoadLibrary("RICHED32.DLL")
ShowMain %HWND_DESKTOP
END FUNCTION
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' ** Functions / Subs **
'------------------------------------------------------------------------------
MACRO CFGFILE = EXE.PATH$ + EXE.NAME$ + ".cfg"
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
FUNCTION NowUTCstamp() AS STRING
LOCAL e, r AS STRING
e = DATE$
r = RIGHT$(e,4) + LEFT$(e,2) + MID$(e,4,2) + "T"
e = TIME$
r += LEFT$(e,2) + MID$(e,4,2) + RIGHT$(e,2) + "Z"
FUNCTION = r
END FUNCTION
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
FUNCTION UID() AS STRING
LOCAL e, r AS STRING
LOCAL i AS LONG
e = GUID$
FOR i = 1 TO LEN(e)
r += HEX$(ASC(e,i), 2)
IF LEN(r) = 23 OR LEN(r) = 18 OR LEN(r) = 13 OR LEN(r) = 8 THEN r += "-"
NEXT
FUNCTION = LCASE$(r)
END FUNCTION
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
FUNCTION IcsDate(BYVAL y AS LONG, BYVAL m AS LONG, BYVAL d AS LONG) AS STRING
LOCAL e, r AS STRING
e = TRIM$(STR$(y)) : WHILE LEN(e) < 4 : e = "0" + e : WEND
r = e
e = TRIM$(STR$(m)) : IF LEN(e) < 2 THEN e = "0" + e
r += e
e = TRIM$(STR$(d)) : IF LEN(e) < 2 THEN e = "0" + e
r += e
FUNCTION = r
END FUNCTION
'------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------
FUNCTION Exist(BYVAL fileOrFolder AS STRING) AS LONG
LOCAL Dummy&
Dummy& = GETATTR(fileOrFolder)
FUNCTION = (ERRCLEAR = 0)
END FUNCTION
'-------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------
FUNCTION Get_Resource(BYVAL rid AS LONG) AS STRING
LOCAL L1, L2 AS LONG
LOCAL D1, D2 AS DWORD
L1 = FindResource (GetModuleHandle(""), "#"+FORMAT$(rid), BYVAL %RT_RCDATA)
D2 = SizeofResource(GetModuleHandle(""), L1)
L2 = LoadResource (GetModuleHandle(""), L1)
D1 = LockResource (L2)
FUNCTION = PEEK$(D1,D2)
END FUNCTION
'-------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------
SUB DumpStandardCfgFile()
LOCAL ff AS LONG
KILL CFGFILE
ff = FREEFILE
OPEN CFGFILE FOR BINARY AS #ff
PUT$ #ff, Get_Resource(10) ' iCalendar Generator.cfg
CLOSE #ff
END SUB
'-------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------
SUB GenerateIcs(BYVAL ysta AS LONG, BYVAL ycnt AS LONG)
LOCAL ffi AS LONG
LOCAL ffo AS LONG
LOCAL lin AS LONG
LOCAL y,m,d AS LONG
LOCAL i,j,k AS LONG
LOCAL em,ed AS LONG ' Easter month/day
LOCAL e,s AS STRING
erli = "" ' Reset lines in error
evok = 0
evko = 0
ffo = FREEFILE
KILL icsf
OPEN icsf FOR OUTPUT ACCESS WRITE LOCK READ WRITE AS #ffo
PRINT #ffo, "BEGIN:VCALENDAR"
PRINT #ffo, "PRODID:"+EXE.NAME$+" - http://mougino.free.fr"
PRINT #ffo, "VERSION:2.0"
PRINT #ffo, ""
FOR y = ysta TO ysta + ycnt - 1
' Calculate Easter Date
em = 3 : ed = EasterDate(y)
IF ed > 31 THEN ' Easter in April
em = 4 : ed -= 31
END IF
' Open Script File for Input
ffi = FREEFILE
OPEN CFGFILE FOR INPUT ACCESS READ LOCK SHARED AS #ffi
lin = 0
DO
LINE INPUT #ffi, e : e = TRIM$(e) : INCR lin
IF e = "" OR LEFT$(e, 1) = "#" THEN ITERATE LOOP ' ignore comments & empty lines
i = INSTR(e,"#")
IF i > 0 THEN e = TRIM$(LEFT$(e,i-1)) ' remove inline comments
i = INSTR(e,"=")
IF i = 0 THEN GOSUB LineInError : ITERATE LOOP ' line must contain an '='
s = UCASE$(TRIM$(LEFT$(e,i-1)))
e = TRIM$(MID$(e,i+1))
IF INSTR(s,"/") > 0 THEN ' fixed date "dd/mm"
i = INSTR(s,"/")
d = VAL(LEFT$(s,i-1))
m = VAL( MID$(s,i+1))
IF d=0 OR m=0 THEN
GOSUB LineInError
ELSE
GOSUB WriteIcsEvent
END IF
ELSEIF INSTR(s,"E+") = 1 THEN ' date based on Easter (after)
i = VAL(MID$(s,3))
j = Julian(y, em, ed) + i
s = Julian2Date(j)
y = VAL(LEFT$(s,4))
m = VAL(MID$(s,5,2))
d = VAL(RIGHT$(s,2))
GOSUB WriteIcsEvent
ELSEIF INSTR(s,"E-") = 1 THEN ' date based on Easter (before)
i = VAL(MID$(s,3))
j = Julian(y, em, ed) - i
s = Julian2Date(j)
y = VAL(LEFT$(s,4))
m = VAL(MID$(s,5,2))
d = VAL(RIGHT$(s,2))
GOSUB WriteIcsEvent
ELSE ' date neither fixed,
GOSUB LineInError ' nor based on Easter
END IF
LOOP UNTIL EOF(#ffi)
CLOSE #ffi
NEXT
PRINT #ffo, "END:VCALENDAR"
CLOSE #ffo
erli = RTRIM$(erli, ";")
EXIT SUB
LineInError:
'-----------
erli += TRIM$(STR$(lin))+";"
INCR evko
RETURN
WriteIcsEvent:
'-------------
PRINT #ffo, "BEGIN:VEVENT"
PRINT #ffo, "DTSTAMP:" + NowUTCstamp()
PRINT #ffo, "DTSTART;VALUE=DATE:" + IcsDate(y,m,d)
PRINT #ffo, "SUMMARY:" + e
PRINT #ffo, "TRANSP:OPAQUE"
PRINT #ffo, "X-MICROSOFT-CDO-BUSYSTATUS:OOF"
PRINT #ffo, "UID:" + UID() + "@mougino.free.fr"
PRINT #ffo, "END:VEVENT"
PRINT #ffo, ""
INCR evok
RETURN
END SUB
'-------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------
SUB Fill_RichEdit (hD AS DWORD, CtlId AS LONG)
LOCAL richtext AS STRING
richtext = "[black][c]"
richtext += "[h:lime][font:a,11][b]Outlook instructions[/b][/h][eol][l]"
richtext += "[font:a,9][black][l][eol]"
richtext += "In Outlook, while in the Calendar view, click [blue]File [black]> [blue]Open & Export "
richtext += "[black]then [blue]Import/Export [black] and finally choose ""[blue]Import an iCalendar "
richtext += "(.ics) or vCalendar file (.vcs)[black]"" then click Next.[eol]"
richtext += "[eol]"
richtext += "Locate the iCalendar file (.ics) that you generated with this program, and when asked "
richtext += "if you want to open this calendar as a new calendar or import its items into your "
richtext += "calendar, choose ""[blue]Import[black]""."
richtext += "[eop]"
richtext += "[eol]"
richtext += "[c][b][maroon]C[red]r[fuschia]e[purple]a[blue]t[teal]e[green]d [lime]b[grey]y [maroon]m[red]o[fuschia]u[purple]g[blue]i[teal]n[green]o[lime]"
richtext += " - http://mougino.free.fr[/b]"
richtext += "[eol]"
richtext += "[eop]"
RTF_SET hD, CtlId, richtext
END SUB
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' ** CallBacks **
'------------------------------------------------------------------------------
MACRO Y_LAST = IIF$(ycnt>1, "-"+TRIM$(STR$(ysta+ycnt-1)), "")
'------------------------------------------------------------------------------
CALLBACK FUNCTION ProcMain()
LOCAL t AS STRING
SELECT CASE AS LONG CB.MSG
CASE %WM_INITDIALOG
' Initialization handler
SendMessage GetDlgItem(CB.HNDL,%IDC_TEXTBOX), %EM_setBkgndColor, _
%False, GetSysColor(%COLOR_MENU)
IF NOT EXIST(CFGFILE) THEN
DumpStandardCfgFile()
END IF
CASE %WM_NOTIFY
' Special RichEdit notifications
IF CB.NMID = %IDC_TEXTBOX AND CB.NMCODE = %EN_LINK THEN
RTF_hyperlink (CB.HNDL, %IDC_TEXTBOX, CB.LPARAM)
END IF
CASE %WM_COMMAND
' Process control messages
SELECT CASE AS LONG CB.CTL
CASE %IDC_T_YSTA ' Year Start UpDown/TxtBox
IF CB.CTLMSG = %EN_CHANGE THEN
CONTROL GET TEXT CB.HNDL, %IDC_T_YSTA TO t
t = REMOVE$(t, CHR$(160))
CONTROL SET TEXT CB.HNDL, %IDC_L_YSTA, t
END IF
CASE %IDC_T_YCNT ' Year Count UpDown/TxtBox
IF CB.CTLMSG = %EN_CHANGE THEN
CONTROL GET TEXT CB.HNDL, %IDC_T_YCNT TO t
t = REMOVE$(t, CHR$(160))
CONTROL SET TEXT CB.HNDL, %IDC_L_YCNT, t
END IF
CASE %IDC_BUTTON1 ' View/change holiday script
IF CB.CTLMSG = %BN_CLICKED OR CB.CTLMSG = 1 THEN
ShellExecute 0, "open", CFGFILE, "", "", %SW_SHOW
END IF
CASE %IDC_BUTTON2 ' GENERATE ICS
LOCAL ysta, ycnt AS LONG
IF CB.CTLMSG = %BN_CLICKED OR CB.CTLMSG = 1 THEN
CONTROL GET TEXT CB.HNDL, %IDC_L_YSTA TO t : ysta = VAL(t)
CONTROL GET TEXT CB.HNDL, %IDC_L_YCNT TO t : ycnt = VAL(t)
DISPLAY SAVEFILE CB.HNDL, -50, -50, EXE.NAME$, EXE.PATH$, _
"iCalendar" + CHR$(0) + "*.ics" + CHR$(0), _
"Public Holidays "+TRIM$(STR$(ysta))+Y_LAST+".ics", _
"ics", %OFN_PATHMUSTEXIST OR %OFN_OVERWRITEPROMPT TO t
IF t = "" THEN EXIT FUNCTION ' Cancelled by user
icsf = t ' Global string 'ICS file'
GenerateIcs ysta, ycnt
t = "iCalendar successfully generated for the year" + IIF$(ycnt>1,"s","")
t += " " + TRIM$(STR$(ysta)) + Y_LAST + " :" + $CR + $CR
t += "- " + TRIM$(STR$(evok)) + " event(s) generated" + $CR + $CR
t += "- " + TRIM$(STR$(evko)) + " error(s)"
IF erli <> "" THEN
t += " at script line"+IIF$(INSTR(erli,";")>0,"s "," ")+erli
END IF
MessageBox CB.HNDL, (t), EXE.NAME$, %MB_ICONINFORMATION
END IF
END SELECT
END SELECT
END FUNCTION
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' ** Dialogs **
'------------------------------------------------------------------------------
%UDS_WRAP = &H0001
%UDS_SETBUDDYINT = &H0002
%UDS_ARROWKEYS = &H0020
%UDM_SETRANGE = %WM_USER + 101
%UDM_SETBUDDY = %WM_USER + 105
'------------------------------------------------------------------------------
FUNCTION ShowMain(BYVAL hParent AS DWORD) AS LONG
LOCAL hDlg AS DWORD
LOCAL hIco AS DWORD
LOCAL lRes AS LONG
LOCAL year AS STRING
year = DATE$ : year = RIGHT$(year, 4)
DIALOG NEW PIXELS, hParent, EXE.NAME$+$SPC+$VER, 514, 250, 355, 328, _
%WS_POPUP OR %WS_BORDER OR %WS_DLGFRAME OR %WS_CAPTION OR _
%WS_SYSMENU OR %WS_MINIMIZEBOX OR %WS_CLIPSIBLINGS OR %WS_VISIBLE OR _
%DS_MODALFRAME OR %DS_3DLOOK OR %DS_NOFAILCREATE OR %DS_SETFONT, _
%WS_EX_CONTROLPARENT OR %WS_EX_LEFT OR %WS_EX_LTRREADING OR _
%WS_EX_RIGHTSCROLLBAR, TO hDlg
hIco = ExtractIcon(GetModuleHandle(""), "imageres.dll", 272)
SetClassLong(hDlg, %GCL_HICONSM, hIco)
SetClassLong(hDlg, %GCL_HICON, hIco)
CONTROL ADD LABEL, hDlg, %IDC_LABEL1, "Start at year :", 16, 16, 72, 16
CONTROL ADD LABEL, hDlg, %IDC_L_YSTA, year, 88, 14, 40, 20, %WS_CHILD _
OR %WS_VISIBLE OR %WS_BORDER OR %SS_CENTER OR %SS_CENTERIMAGE, _
%WS_EX_LEFT OR %WS_EX_LTRREADING
CONTROL SET COLOR hDlg, %IDC_L_YSTA, -1, %WHITE
CONTROL ADD "msctls_updown32", hDlg, %IDC_UD_YSTA, "", 88+40+2, 12, 34, 24, _
%WS_CHILD OR %WS_VISIBLE OR %UDS_WRAP OR %UDS_SETBUDDYINT OR %UDS_ARROWKEYS
CONTROL ADD TEXTBOX, hDlg, %IDC_T_YSTA, year, -10, -10, 1, 1
CONTROL SEND hDlg, %IDC_UD_YSTA, %UDM_SETBUDDY, GetDlgItem(hDlg, %IDC_T_YSTA), 0&
CONTROL SEND hDlg, %IDC_UD_YSTA, %UDM_SETRANGE, 0&, MAKLNG (9999,0)
CONTROL ADD LABEL, hDlg, %IDC_LABEL2, "and generate for", 152, 16, 88, 16, %SS_CENTER
CONTROL ADD LABEL, hDlg, %IDC_L_YCNT, "1", 240, 14, 32, 20, %WS_CHILD _
OR %WS_VISIBLE OR %WS_BORDER OR %SS_CENTER OR %SS_CENTERIMAGE, _
%WS_EX_LEFT OR %WS_EX_LTRREADING
CONTROL SET COLOR hDlg, %IDC_L_YCNT, -1, %WHITE
CONTROL ADD "msctls_updown32", hDlg, %IDC_UD_YCNT, "", 240+32+2, 12, 34, 24, _
%WS_CHILD OR %WS_VISIBLE OR %UDS_WRAP OR %UDS_SETBUDDYINT OR %UDS_ARROWKEYS
CONTROL ADD TEXTBOX, hDlg, %IDC_T_YCNT, "1", -10, -10, 1, 1
CONTROL SEND hDlg, %IDC_UD_YCNT, %UDM_SETBUDDY, GetDlgItem(hDlg, %IDC_T_YCNT), 0&
CONTROL SEND hDlg, %IDC_UD_YCNT, %UDM_SETRANGE, 0&, MAKLNG (99,1)
CONTROL ADD LABEL, hDlg, %IDC_LABEL3, "year(s).", 304, 16, 48, 16
CONTROL ADD BUTTON, hDlg, %IDC_BUTTON1, "View/change script", 8, 48, 140, 24
CONTROL ADD BUTTON, hDlg, %IDC_BUTTON2, "GENERATE ICS", 192, 46, 152, 28
CONTROL ADD "RichEdit", hDlg, %IDC_TEXTBOX, "", 8, 88, 336, 230, _
%WS_CHILD OR %WS_VISIBLE OR %ES_MULTILINE OR %ES_READONLY _
OR %WS_VSCROLL
Fill_RichEdit (hDlg, %IDC_TEXTBOX)
DIALOG SHOW MODAL hDlg, CALL ProcMain TO lRes
FUNCTION = lRes
END FUNCTION
'------------------------------------------------------------------------------