'----------------------------------------------------------------------------
' convert : Shamsi-date <-> Miladi-date 
' Freeware : (C) Mehdi NikAmalFard 1999
' please distribute this listing , it is free to use for privat & commercial
' use
'----------------------------------------------------------------------------

DECLARE FUNCTION mil2shams$ (da$)
DECLARE FUNCTION shams2mil$ (da$)

CLS
LOCATE 5, 1
da$ = mil2shams$(DATE$)
PRINT "Today is " + DATE$ + " = " + da$
PRINT
PRINT "Emrouz is " + da$ + " = " + shams2mil$(da$)

FUNCTION mil2shams$ (da$)

DIM iran(12), CHRIS(12)
CHRIS(1) = 31: CHRIS(2) = 28: CHRIS(3) = 31: CHRIS(4) = 30: CHRIS(5) = 31: CHRIS(6) = 30
CHRIS(7) = 31: CHRIS(8) = 31: CHRIS(9) = 30: CHRIS(10) = 31: CHRIS(11) = 30: CHRIS(12) = 31
FOR i = 1 TO 12: iran(i) = 31 - (i \ 7) - (i \ 12): NEXT
mo = VAL(LEFT$(da$, 2))
day = VAL(MID$(da$, 4, 2))
year = VAL(MID$(da$, 7, 4))
leap1 = INT((year - 1) / 400)
leap2 = year - 1 - 400 * leap1
leap3 = leap2 \ 100
leap4 = leap2 MOD 100
leap5 = leap4 \ 4
CHRIS(2) = 28
IF ((year MOD 4) = 0 AND (year MOD 100) <> 0) OR (year MOD 400) = 0 THEN CHRIS(2) = 29
day1 = day
FOR i = 1 TO mo - 1: day1 = day1 + CHRIS(i): NEXT i
daynum = 365 * (year - 1) + day1 + 97 * leap1 + 24 * leap3 + leap5
daynum = daynum - 221056!
iry1 = INT(daynum / 12053)
iry2 = daynum - 12053 * iry1
iry = 33 * iry1 - 16
IF iry2 > 365 THEN iry = iry + 1: iry2 = iry2 - 365
iry3 = iry2 \ 1461
iry4 = iry2 MOD 1461
iry5 = iry4 \ 365
iry6 = iry4 MOD 365
iry = iry + 1 + 4 * iry3 + iry5
iran(12) = 29
esfand = (8 * iry + 22) / 33 - .001
esfand = esfand - INT(esfand)
IF esfand > .77 THEN iran(12) = 30
FOR i = 1 TO 12
IF iry6 > iran(i) THEN iry6 = iry6 - iran(i) ELSE irm = i: day1 = iry6: EXIT FOR
NEXT i
day1 = day1 + 5
IF day1 > iran(irm) THEN
 day1 = day1 - iran(irm)
 irm = irm + 1
 IF irm > 12 THEN irm = 1: iry = iry + 1
END IF
eirdae = 3 * irm - 3
IF irm > 7 THEN eirdae = eirdae - irm + 7
girdae = (8 * iry + 22) / 33 - .001
cirdae = INT(girdae) + iry + eirdae - day1 + 3
cirdae = cirdae MOD 7
IF irm < 10 THEN mo$ = "0" + LTRIM$(STR$(irm)) ELSE mo$ = LTRIM$(STR$(irm))
IF day1 < 10 THEN d$ = "0" + LTRIM$(STR$(day1)) ELSE d$ = LTRIM$(STR$(day1))
mil2shams$ = LTRIM$(STR$(iry)) + "/" + mo$ + "/" + d$

END FUNCTION

FUNCTION shams2mil$ (da$)          'yyyy/mm/dd  in latin-number

y = VAL(LEFT$(da$, 4)): m = VAL(MID$(da$, 6, 2)): d = VAL(RIGHT$(da$, 2))
IF m < 10 OR (m = 10 AND d < 11) THEN y = y + 621 ELSE y = y + 622
 SELECT CASE m
  CASE 1: IF d < 12 THEN m = 3: d = d + 20 ELSE m = 4: d = d - 11
  CASE 2: IF d < 11 THEN m = 4: d = d + 20 ELSE m = 5: d = d - 10
  CASE 3: IF d < 11 THEN m = 5: d = d + 21 ELSE m = 6: d = d - 10
  CASE 4: IF d < 10 THEN m = 6: d = d + 21 ELSE m = 7: d = d - 9
  CASE 5, 6, 8: IF d < 10 THEN m = m + 2: d = d + 22 ELSE m = m + 3: d = d - 9
  CASE 7: IF d < 9 THEN m = 9: d = d + 22 ELSE m = 10: d = d - 8
  CASE 9: IF d < 10 THEN m = 11: d = d + 21 ELSE m = 12: d = d - 9
  CASE 10: IF d < 11 THEN m = 12: d = d + 21 ELSE m = 1: d = d - 10
  CASE 11: IF d < 12 THEN m = 1: d = d + 20 ELSE m = 2: d = d - 11
  CASE 12: IF d < 10 THEN m = 2: d = d + 19 ELSE m = 3: d = d - 9
 END SELECT
shams2mil$ = RIGHT$("00" + MID$(STR$(m), 2), 2) + "-" + RIGHT$("00" + MID$(STR$(d), 2), 2) + "-" + RIGHT$(STR$(y), 4)

END FUNCTION