Option Explicit
Sub GenerateCalendarRabbit()
Dim pptPres As Presentation
Dim slideTemplateFirstHalfW As Slide, slideTemplateSecondHalfW As Slide
Dim currentSlide As Slide
Dim eventFile As String, weekFile As String
Dim eventData As Variant, weekData As Variant
Dim m As Integer, d As Integer
Dim row As Integer, col As Integer
Dim solarDay As Integer, lunarDay As Integer, gregDay As Integer
Dim solarMonth As Integer, lunarMonth As Integer, gregMonth As Integer
' Array declarations for month day limits
Dim shamsiDays(1 To 12) As Integer
shamsiDays(1) = 31: shamsiDays(2) = 31: shamsiDays(3) = 31
shamsiDays(4) = 31: shamsiDays(5) = 31: shamsiDays(6) = 31
shamsiDays(7) = 30: shamsiDays(8) = 30: shamsiDays(9) = 30
shamsiDays(10) = 30: shamsiDays(11) = 30: shamsiDays(12) = 29
Dim miladiDays(1 To 12) As Integer
miladiDays(1) = 31: miladiDays(2) = 28: miladiDays(3) = 31
miladiDays(4) = 30: miladiDays(5) = 31: miladiDays(6) = 30
miladiDays(7) = 31: miladiDays(8) = 31: miladiDays(9) = 30
miladiDays(10) = 31: miladiDays(11) = 30: miladiDays(12) = 31
Dim ghamariDays(1 To 12) As Integer
ghamariDays(1) = 30: ghamariDays(2) = 29: ghamariDays(3) = 30
ghamariDays(4) = 29: ghamariDays(5) = 30: ghamariDays(6) = 30
ghamariDays(7) = 30: ghamariDays(8) = 29: ghamariDays(9) = 30
ghamariDays(10) = 29: ghamariDays(11) = 29: ghamariDays(12) = 29
Dim gregMonthName(1 To 12) As String
gregMonthName(1) = "Jan"
gregMonthName(2) = "Feb"
gregMonthName(3) = "Mar"
gregMonthName(4) = "Apr"
gregMonthName(5) = "May"
gregMonthName(6) = "Jun"
gregMonthName(7) = "Jul"
gregMonthName(8) = "Aug"
gregMonthName(9) = "Sep"
gregMonthName(10) = "Oct"
gregMonthName(11) = "Nov"
gregMonthName(12) = "Dec"
Dim WeekNames(1 To 12) As String
WeekNames(1) = ""
WeekNames(2) = ""
WeekNames(3) = ""
WeekNames(4) = ""
WeekNames(5) = ""
WeekNames(6) = ""
WeekNames(7) = ""
Set pptPres = ActivePresentation
eventFile = "/Users/apple/events_output_toolani.txt"
'monthFile = "/Users/apple/monthnames_output.txt" ' ???? ???? ??? ??????
weekFile = "/Users/apple/nameofweekdays.txt"
' Read event and month data into arrays
eventData = ReadTextFile(eventFile)
weekData = ReadTextFile(weekFile)
Dim x As Integer
For x = LBound(weekData) To UBound(weekData)
WeekNames(x + 1) = weekData(x)
Next x
Dim slideTemplateFirstHalfW1 As Slide, slideTemplateSecondHalfW1 As Slide
Dim slideTemplateFirstHalfW2 As Slide, slideTemplateSecondHalfW2 As Slide
Set slideTemplateFirstHalfW1 = pptPres.Slides(1)
Set slideTemplateSecondHalfW1 = pptPres.Slides(2)
Set slideTemplateFirstHalfW2 = pptPres.Slides(3)
Set slideTemplateSecondHalfW2 = pptPres.Slides(4)
' Set slideTemplateFirstHalfW = pptPres.Slides(1)
' Set slideTemplateSecondHalfW = pptPres.Slides(2)
' Initial Date & Position (1 Farvardin 1404 = Friday)
solarDay = 1: solarMonth = 1
lunarDay = 1: lunarMonth = 10 ' SHAval 1446
gregDay = 21: gregMonth = 3 ' March 2025
'col = 1 ' Starts on shanbe
Dim weeknumber As Integer
Dim activeHalf As Integer
activeHalf = 1
For weeknumber = 1 To 53
If weeknumber Mod 2 = 1 Then
Set slideTemplateFirstHalfW = slideTemplateFirstHalfW1
Set slideTemplateSecondHalfW = slideTemplateSecondHalfW1
Else
Set slideTemplateFirstHalfW = slideTemplateFirstHalfW2
Set slideTemplateSecondHalfW = slideTemplateSecondHalfW2
End If
'' If (activeHalf = 1) Then
Set currentSlide = slideTemplateFirstHalfW.Duplicate(1)
currentSlide.MoveTo pptPres.Slides.count
' Loop through days of the current month
For d = 1 To 7
If solarMonth = 0 Then
weeknumber = 100
Exit For
End If
If d = 5 Then
'' If (activeHalf = 2) Then
Set currentSlide = slideTemplateSecondHalfW.Duplicate(1)
currentSlide.MoveTo pptPres.Slides.count
End If
' --- SEARCH LOGIC FOR EVENTS ---
Dim eventText As String: eventText = ""
Dim holidayCode As Integer: holidayCode = 1 ' 1 = Normal day by default
Dim lengthCode As Integer: lengthCode = 0
Dim i As Long
Dim prefix As String
prefix = solarDay & "," & solarMonth & ","
For i = LBound(eventData) To UBound(eventData)
If Left(eventData(i), Len(prefix)) = prefix Then
Dim parts() As String: parts = Split(eventData(i), ",")
Dim uBoundParts As Integer: uBoundParts = UBound(parts)
lengthCode = CInt(parts(uBoundParts))
holidayCode = CInt(parts(uBoundParts - 1))
Dim k As Integer
For k = 2 To uBoundParts - 2
eventText = eventText & ChrW(CInt(parts(k)))
Next k
Exit For
End If
Next i
Dim RowIndex As Integer
RowIndex = d
If activeHalf = 2 Then
RowIndex = d - 4
End If
'-------------------------------
' Table Days
'-------------------------------
' --- Fill Table shamsi) ---
With currentSlide.Shapes("Table Days").Table.Cell(RowIndex, 1).Shape.TextFrame.TextRange
'.Font.Name = "X "
'.Font.Size = 16
'.Font.Color.RGB = RGB(1, 187, 130)
.ParagraphFormat.Alignment = ppAlignRight
.Text = vbNullString
.InsertAfter ConvertUnicodeCsvToText(WeekNames(d)) & " " & ConvertToPersian(solarDay)
End With
' --- Fill Table (Gregorian
With currentSlide.Shapes("Table Days").Table.Cell(RowIndex, 2).Shape.TextFrame.TextRange
'.Font.Name = "X "
'.Font.Size = 16
'.Font.Color.RGB = RGB(1, 187, 130)
.ParagraphFormat.Alignment = ppAlignLeft
.Text = vbNullString
.InsertAfter gregDay & " " & gregMonthName(gregMonth)
End With
'-------------------------------
' Table Events
'-------------------------------
' --- Fill Table (Events) ---
With currentSlide.Shapes("Table event").Table.Cell(RowIndex, 3).Shape.TextFrame.TextRange
'.Font.Name = "X Yekan"
If lengthCode = 5 Then .Font.Size = 8 Else .Font.Size = 9
If holidayCode = 0 Then
.Font.Color.RGB = RGB(255, 0, 0)
End If
If eventText <> "" Then
.Text = vbNullString
.InsertAfter eventText
End If
End With
' --- Move Rabbit to next cell ---
If d = 4 Then
activeHalf = 2
End If
If d = 7 Then
activeHalf = 1
End If
' Advance calendar counters
solarDay = solarDay + 1
lunarDay = lunarDay + 1
gregDay = gregDay + 1
' Check Gregorian limits
If gregDay > miladiDays(gregMonth) Then
gregDay = 1
gregMonth = gregMonth + 1
If gregMonth > 12 Then gregMonth = 1
End If
' Check solar limits
If solarDay > shamsiDays(solarMonth) Then
solarDay = 1
solarMonth = solarMonth + 1
If solarMonth > 12 Then solarMonth = 0
End If
Next d
Next weeknumber
MsgBox "Done!", vbInformation
End Sub
' ???? ???? ???? ???? ????? ????? ?????? ????-?????? ?? ??? ?????
Function ConvertUnicodeCsvToText(csvStr As String) As String
Dim cleanStr As String
cleanStr = csvStr
If cleanStr = "" Then
ConvertUnicodeCsvToText = ""
Exit Function
End If
Dim codes() As String
codes = Split(cleanStr, ",")
Dim res As String: res = ""
Dim i As Integer
For i = LBound(codes) To UBound(codes)
If Trim(codes(i)) <> "" Then
res = res & ChrW(CInt(Trim(codes(i))))
End If
Next i
ConvertUnicodeCsvToText = res
End Function
Function ReadTextFile(filePath As String) As Variant
Dim fileNo As Integer
Dim lineData As String
Dim allLines() As String
Dim count As Long
fileNo = FreeFile
count = 0
Open filePath For Input As #fileNo
Do While Not EOF(fileNo)
Line Input #fileNo, lineData
lineData = Trim(lineData)
If lineData <> "" Then
ReDim Preserve allLines(count)
allLines(count) = lineData
count = count + 1
End If
Loop
Close #fileNo
ReadTextFile = allLines
End Function
Function ConvertToPersian(m As Integer) As String
Dim res As String
Dim digit As Integer
Dim n As Integer
n = m
res = ""
If n = 0 Then
ConvertToPersian = ChrW(1776)
Exit Function
End If
While n > 0
digit = n Mod 10
res = ChrW(1776 + digit) & res
n = n \ 10
Wend
ConvertToPersian = res
End Function
Function CleanComma(txt As String) As String
CleanComma = Mid(Trim(txt), 2, Len(txt) - 2)
End Function
Option Explicit
Sub GenerateCalendarRabbit()
Dim pptPres As Presentation
Dim slideTemplateFirstHalfW As Slide, slideTemplateSecondHalfW As Slide
Dim currentSlide As Slide
Dim eventFile As String, weekFile As String
Dim eventData As Variant, weekData As Variant
Dim m As Integer, d As Integer
Dim row As Integer, col As Integer
Dim solarDay As Integer, lunarDay As Integer, gregDay As Integer
Dim solarMonth As Integer, lunarMonth As Integer, gregMonth As Integer
' Array declarations for month day limits
Dim shamsiDays(1 To 12) As Integer
shamsiDays(1) = 31: shamsiDays(2) = 31: shamsiDays(3) = 31
shamsiDays(4) = 31: shamsiDays(5) = 31: shamsiDays(6) = 31
shamsiDays(7) = 30: shamsiDays(8) = 30: shamsiDays(9) = 30
shamsiDays(10) = 30: shamsiDays(11) = 30: shamsiDays(12) = 29
Dim miladiDays(1 To 12) As Integer
miladiDays(1) = 31: miladiDays(2) = 28: miladiDays(3) = 31
miladiDays(4) = 30: miladiDays(5) = 31: miladiDays(6) = 30
miladiDays(7) = 31: miladiDays(8) = 31: miladiDays(9) = 30
miladiDays(10) = 31: miladiDays(11) = 30: miladiDays(12) = 31
Dim ghamariDays(1 To 12) As Integer
ghamariDays(1) = 30: ghamariDays(2) = 29: ghamariDays(3) = 30
ghamariDays(4) = 29: ghamariDays(5) = 30: ghamariDays(6) = 30
ghamariDays(7) = 30: ghamariDays(8) = 29: ghamariDays(9) = 30
ghamariDays(10) = 29: ghamariDays(11) = 29: ghamariDays(12) = 29
Dim gregMonthName(1 To 12) As String
gregMonthName(1) = "Jan"
gregMonthName(2) = "Feb"
gregMonthName(3) = "Mar"
gregMonthName(4) = "Apr"
gregMonthName(5) = "May"
gregMonthName(6) = "Jun"
gregMonthName(7) = "Jul"
gregMonthName(8) = "Aug"
gregMonthName(9) = "Sep"
gregMonthName(10) = "Oct"
gregMonthName(11) = "Nov"
gregMonthName(12) = "Dec"
Dim WeekNames(1 To 12) As String
WeekNames(1) = ""
WeekNames(2) = ""
WeekNames(3) = ""
WeekNames(4) = ""
WeekNames(5) = ""
WeekNames(6) = ""
WeekNames(7) = ""
Set pptPres = ActivePresentation
eventFile = "/Users/apple/events_output_toolani.txt"
'monthFile = "/Users/apple/monthnames_output.txt" ' ???? ???? ??? ??????
weekFile = "/Users/apple/nameofweekdays.txt"
' Read event and month data into arrays
eventData = ReadTextFile(eventFile)
weekData = ReadTextFile(weekFile)
Dim x As Integer
For x = LBound(weekData) To UBound(weekData)
WeekNames(x + 1) = weekData(x)
Next x
Set slideTemplateFirstHalfW = pptPres.Slides(1)
Set slideTemplateSecondHalfW = pptPres.Slides(2)
' Initial Date & Position (1 Farvardin 1404 = Friday)
solarDay = 1: solarMonth = 1
lunarDay = 1: lunarMonth = 10 ' SHAval 1446
gregDay = 21: gregMonth = 3 ' March 2025
'col = 1 ' Starts on shanbe
Dim weeknumber As Integer
Dim activeHalf As Integer
activeHalf = 1
For weeknumber = 1 To 5
'' If (activeHalf = 1) Then
Set currentSlide = slideTemplateFirstHalfW.Duplicate(1)
currentSlide.MoveTo pptPres.Slides.count
' Loop through days of the current month
For d = 1 To 7
If solarMonth = 0 Then
weeknumber = 100
Exit For
End If
If d = 5 Then
'' If (activeHalf = 2) Then
Set currentSlide = slideTemplateSecondHalfW.Duplicate(1)
currentSlide.MoveTo pptPres.Slides.count
End If
' --- SEARCH LOGIC FOR EVENTS ---
Dim eventText As String: eventText = ""
Dim holidayCode As Integer: holidayCode = 1 ' 1 = Normal day by default
Dim lengthCode As Integer: lengthCode = 0
Dim i As Long
Dim prefix As String
prefix = solarDay & "," & solarMonth & ","
For i = LBound(eventData) To UBound(eventData)
If Left(eventData(i), Len(prefix)) = prefix Then
Dim parts() As String: parts = Split(eventData(i), ",")
Dim uBoundParts As Integer: uBoundParts = UBound(parts)
lengthCode = CInt(parts(uBoundParts))
holidayCode = CInt(parts(uBoundParts - 1))
Dim k As Integer
For k = 2 To uBoundParts - 2
eventText = eventText & ChrW(CInt(parts(k)))
Next k
Exit For
End If
Next i
Dim RowIndex As Integer
RowIndex = d
If activeHalf = 2 Then
RowIndex = d - 4
End If
'-------------------------------
' Table Days
'-------------------------------
' --- Fill Table shamsi) ---
With currentSlide.Shapes("Table Days").Table.Cell(RowIndex, 1).Shape.TextFrame.TextRange
'.Font.Name = "X "
'.Font.Size = 16
'.Font.Color.RGB = RGB(1, 187, 130)
.ParagraphFormat.Alignment = ppAlignRight
.Text = vbNullString
.InsertAfter ConvertUnicodeCsvToText(WeekNames(d)) & " " & ConvertToPersian(solarDay)
End With
' --- Fill Table (Gregorian
With currentSlide.Shapes("Table Days").Table.Cell(RowIndex, 2).Shape.TextFrame.TextRange
'.Font.Name = "X "
'.Font.Size = 16
'.Font.Color.RGB = RGB(1, 187, 130)
.ParagraphFormat.Alignment = ppAlignLeft
.Text = vbNullString
.InsertAfter gregDay & " " & gregMonthName(gregMonth)
End With
'-------------------------------
' Table Events
'-------------------------------
' --- Fill Table (Events) ---
With currentSlide.Shapes("Table event").Table.Cell(RowIndex, 3).Shape.TextFrame.TextRange
'.Font.Name = "X Yekan"
If lengthCode = 5 Then .Font.Size = 8 Else .Font.Size = 9
If holidayCode = 0 Then
.Font.Color.RGB = RGB(255, 0, 0)
End If
If eventText <> "" Then
.Text = vbNullString
.InsertAfter eventText
End If
End With
' --- Move Rabbit to next cell ---
If d = 4 Then
activeHalf = 2
End If
If d = 7 Then
activeHalf = 1
End If
' Advance calendar counters
solarDay = solarDay + 1
lunarDay = lunarDay + 1
gregDay = gregDay + 1
' Check Gregorian limits
If gregDay > miladiDays(gregMonth) Then
gregDay = 1
gregMonth = gregMonth + 1
If gregMonth > 12 Then gregMonth = 1
End If
' Check solar limits
If solarDay > shamsiDays(solarMonth) Then
solarDay = 1
solarMonth = solarMonth + 1
If solarMonth > 12 Then solarMonth = 0
End If
Next d
Next weeknumber
MsgBox "Done!", vbInformation
End Sub
' ???? ???? ???? ???? ????? ????? ?????? ????-?????? ?? ??? ?????
Function ConvertUnicodeCsvToText(csvStr As String) As String
Dim cleanStr As String
cleanStr = csvStr
If cleanStr = "" Then
ConvertUnicodeCsvToText = ""
Exit Function
End If
Dim codes() As String
codes = Split(cleanStr, ",")
Dim res As String: res = ""
Dim i As Integer
For i = LBound(codes) To UBound(codes)
If Trim(codes(i)) <> "" Then
res = res & ChrW(CInt(Trim(codes(i))))
End If
Next i
ConvertUnicodeCsvToText = res
End Function
Function ReadTextFile(filePath As String) As Variant
Dim fileNo As Integer
Dim lineData As String
Dim allLines() As String
Dim count As Long
fileNo = FreeFile
count = 0
Open filePath For Input As #fileNo
Do While Not EOF(fileNo)
Line Input #fileNo, lineData
lineData = Trim(lineData)
If lineData <> "" Then
ReDim Preserve allLines(count)
allLines(count) = lineData
count = count + 1
End If
Loop
Close #fileNo
ReadTextFile = allLines
End Function
Function ConvertToPersian(m As Integer) As String
Dim res As String
Dim digit As Integer
Dim n As Integer
n = m
res = ""
If n = 0 Then
ConvertToPersian = ChrW(1776)
Exit Function
End If
While n > 0
digit = n Mod 10
res = ChrW(1776 + digit) & res
n = n \ 10
Wend
ConvertToPersian = res
End Function
Function CleanComma(txt As String) As String
CleanComma = Mid(Trim(txt), 2, Len(txt) - 2)
End Function
Option Explicit
Sub GenerateCalendarRabbit()
Dim pptPres As Presentation
Dim slideTemplate5W As Slide, slideTemplate6W As Slide
Dim currentSlide As Slide
Dim eventFile As String, monthFile As String
Dim eventData As Variant, monthData As Variant
Dim m As Integer, d As Integer
Dim row As Integer, col As Integer
Dim solarDay As Integer, lunarDay As Integer, gregDay As Integer
Dim solarMonth As Integer, lunarMonth As Integer, gregMonth As Integer
' Array declarations for month day limits
Dim shamsiDays(1 To 12) As Integer
shamsiDays(1) = 31: shamsiDays(2) = 31: shamsiDays(3) = 31
shamsiDays(4) = 31: shamsiDays(5) = 31: shamsiDays(6) = 31
shamsiDays(7) = 30: shamsiDays(8) = 30: shamsiDays(9) = 30
shamsiDays(10) = 30: shamsiDays(11) = 30: shamsiDays(12) = 29
Dim miladiDays(1 To 12) As Integer
miladiDays(1) = 31: miladiDays(2) = 28: miladiDays(3) = 31
miladiDays(4) = 30: miladiDays(5) = 31: miladiDays(6) = 30
miladiDays(7) = 31: miladiDays(8) = 31: miladiDays(9) = 30
miladiDays(10) = 31: miladiDays(11) = 30: miladiDays(12) = 31
Dim ghamariDays(1 To 12) As Integer
ghamariDays(1) = 30: ghamariDays(2) = 29: ghamariDays(3) = 30
ghamariDays(4) = 29: ghamariDays(5) = 30: ghamariDays(6) = 30
ghamariDays(7) = 30: ghamariDays(8) = 29: ghamariDays(9) = 30
ghamariDays(10) = 29: ghamariDays(11) = 29: ghamariDays(12) = 29
Set pptPres = ActivePresentation
eventFile = "/Users/apple/events_output_toolani.txt"
monthFile = "/Users/apple/monthnames_output.txt" ' ???? ???? ??? ??????
' Read event and month data into arrays
eventData = ReadTextFile(eventFile)
monthData = ReadTextFile(monthFile)
Set slideTemplate5W = pptPres.Slides(1)
Set slideTemplate6W = pptPres.Slides(2)
' Initial Date & Position (1 Farvardin 1404 = Friday)
solarDay = 1: solarMonth = 1
lunarDay = 1: lunarMonth = 10 ' SHAval 1446
gregDay = 21: gregMonth = 3 ' March 2025
col = 1 ' Starts on shanbe
' Loop through 12 Shamsi months
For m = 1 To 12
Dim monthLen As Integer
monthLen = shamsiDays(m)
' FIX: Pure mathematical check for 5-week or 6-week slide template.
Dim activeStartCol As Integer
If col >= 6 Then activeStartCol = col - 1 Else activeStartCol = col
If (activeStartCol + monthLen - 1) > 35 Then
Set currentSlide = slideTemplate6W.Duplicate(1)
Else
Set currentSlide = slideTemplate5W.Duplicate(1)
End If
currentSlide.MoveTo pptPres.Slides.count
' CRITICAL FIX: Always enforce row 2 at the exact start of every new slide
row = 2
' --- ??????? ? ????? ??? ?????? ???? ?????? ???? ---
If m - 1 <= UBound(monthData) Then
Dim mainParts() As String
mainParts = Split(monthData(m - 1), "|||")
' 1. ??? ??? ???? (??? ??? - ???? 79? ???? 1 ? 1)
Dim shamsiMonthName As String
shamsiMonthName = ConvertUnicodeCsvToText(mainParts(0))
With currentSlide.Shapes("Table 79").Table.Cell(1, 1).Shape.TextFrame.TextRange
.Text = shamsiMonthName
.Font.Name = "XB Morvarid"
.Font.Size = 24
.Font.Bold = True
End With
' 2. ??? ??????? ?????? (??? ??? ? ??? - ???? 1? ??? 1 ???? 2)
' ????? ?? ??? ?????? ?? ???? "March - April"
Dim miladiMonthName As String
miladiMonthName = Trim(CleanComma(mainParts(1))) & " - " & Trim(CleanComma(mainParts(2)))
With currentSlide.Shapes("Table 1").Table.Cell(1, 2).Shape.TextFrame.TextRange
.Text = miladiMonthName
'.Font.Name = "Arial"
.Font.Size = 14
.Font.Bold = True
End With
' 3. ??? ??????? ???? (??? ????? ? ???? - ???? 1? ??? 1 ???? 1)
Dim lunarMonthName As String
Dim lunarPart1 As String, lunarPart2 As String
lunarPart1 = ConvertUnicodeCsvToText(mainParts(3))
' ????? ????? ??? ??? ???? ??? ???? ???? ?? ??? (??????? ?? ??? ?? ??????? ??????)
If UBound(mainParts) >= 4 Then
lunarPart2 = ConvertUnicodeCsvToText(mainParts(4))
Else
lunarPart2 = ""
End If
If Trim(lunarPart2) <> "" Then
lunarMonthName = lunarPart1 & " -" & lunarPart2
Else
lunarMonthName = lunarPart1
End If
With currentSlide.Shapes("Table 1").Table.Cell(1, 1).Shape.TextFrame.TextRange
.Text = lunarMonthName
.Font.Name = "X Vahid"
.Font.Size = 14
.Font.Bold = True
End With
End If
' ------------------------------------------------
' Loop through days of the current month
For d = 1 To monthLen
' --- SEARCH LOGIC FOR EVENTS ---
Dim eventText As String: eventText = ""
Dim holidayCode As Integer: holidayCode = 1 ' 1 = Normal day by default
Dim lengthCode As Integer: lengthCode = 0
Dim i As Long
Dim prefix As String
prefix = solarDay & "," & m & ","
For i = LBound(eventData) To UBound(eventData)
If Left(eventData(i), Len(prefix)) = prefix Then
Dim parts() As String: parts = Split(eventData(i), ",")
Dim uBoundParts As Integer: uBoundParts = UBound(parts)
lengthCode = CInt(parts(uBoundParts))
holidayCode = CInt(parts(uBoundParts - 1))
Dim k As Integer
For k = 2 To uBoundParts - 2
eventText = eventText & ChrW(CInt(parts(k)))
Next k
Exit For
End If
Next i
' --- Fill Table 4 (Shamsi) ---
With currentSlide.Shapes("Table 4").Table.Cell(row, col).Shape.TextFrame
' ????? ????????? ?? ????? ?? TextFrame ?????
.MarginTop = 2
.MarginRight = 4
' ??? ?? ??? ? ???? ?? TextRange
With .TextRange
.Text = vbNullString ' ????? ??? ?? ???? ???????
.InsertAfter ConvertToPersian(solarDay) ' ??? ???? ?? ????? ???????
' ???? ????????? ??? ?? ????? ???????
.Font.Name = "XB Morvarid"
.Font.Size = 16
.ParagraphFormat.Alignment = ppAlignRight
' ????? ??? ????
If holidayCode = 0 And col <> 8 Then
.Font.Color.RGB = RGB(255, 0, 0)
Else
' ???? ??? ??? ??????? (????? ????) ?? ?? ??????? ?? ??? ??? ?????? ????? ??? ???? ???? ?????
.Font.Color.RGB = RGB(0, 0, 0)
End If
End With
End With
' --- Fill Table 5 (Gregorian & Lunar) ---
With currentSlide.Shapes("Table 5").Table.Cell(row - 1, col).Shape.TextFrame.TextRange
.Font.Name = "X Vahid"
.Font.Size = 16
.Font.Color.RGB = RGB(1, 187, 130)
.ParagraphFormat.Alignment = ppAlignLeft
.Text = vbNullString
.InsertAfter gregDay & " | " & ConvertToPersian(lunarDay)
End With
' --- Fill Table 2 (Events) ---
With currentSlide.Shapes("Table 2").Table.Cell(row - 1, col).Shape.TextFrame.TextRange
.Font.Name = "X Yekan"
If lengthCode = 5 Then .Font.Size = 8 Else .Font.Size = 9
If holidayCode = 0 Then
.Font.Color.RGB = RGB(255, 0, 0)
End If
If eventText <> "" Then
.Text = vbNullString
.InsertAfter eventText
End If
End With
' --- Move Rabbit to next cell ---
If col = 8 Then
col = 1
row = row + 1
Else
col = col + 1
If col = 5 Then col = 6 ' Skip empty column
End If
' Advance calendar counters
solarDay = solarDay + 1
lunarDay = lunarDay + 1
gregDay = gregDay + 1
' Check Gregorian limits
If gregDay > miladiDays(gregMonth) Then
gregDay = 1
gregMonth = gregMonth + 1
If gregMonth > 12 Then gregMonth = 1
End If
' Check Lunar limits
If lunarDay > ghamariDays(lunarMonth) Then
lunarDay = 1
lunarMonth = lunarMonth + 1
If lunarMonth > 12 Then lunarMonth = 1
End If
Next d
' Advance Shamsi Month
solarDay = 1
solarMonth = solarMonth + 1
Next m
MsgBox "Done!", vbInformation
End Sub
' ???? ???? ???? ???? ????? ????? ?????? ????-?????? ?? ??? ?????
Function ConvertUnicodeCsvToText(csvStr As String) As String
Dim cleanStr As String
cleanStr = Trim(csvStr)
If cleanStr = "" Then
ConvertUnicodeCsvToText = ""
Exit Function
End If
Dim codes() As String
codes = Split(cleanStr, ",")
Dim res As String: res = ""
Dim i As Integer
For i = LBound(codes) To UBound(codes)
If Trim(codes(i)) <> "" Then
res = res & ChrW(CInt(Trim(codes(i))))
End If
Next i
ConvertUnicodeCsvToText = res
End Function
Function ReadTextFile(filePath As String) As Variant
Dim fileNo As Integer
Dim lineData As String
Dim allLines() As String
Dim count As Long
fileNo = FreeFile
count = 0
Open filePath For Input As #fileNo
Do While Not EOF(fileNo)
Line Input #fileNo, lineData
lineData = Trim(lineData)
If lineData <> "" Then
ReDim Preserve allLines(count)
allLines(count) = lineData
count = count + 1
End If
Loop
Close #fileNo
ReadTextFile = allLines
End Function
Function ConvertToPersian(m As Integer) As String
Dim res As String
Dim digit As Integer
Dim n As Integer
n = m
res = ""
If n = 0 Then
ConvertToPersian = ChrW(1776)
Exit Function
End If
While n > 0
digit = n Mod 10
res = ChrW(1776 + digit) & res
n = n \ 10
Wend
ConvertToPersian = res
End Function
Function CleanComma(txt As String) As String
CleanComma = Mid(Trim(txt), 2, Len(txt) - 2)
End Function
Option Explicit
Sub GenerateCalendarRabbit()
Dim pptPres As Presentation
Dim slideTemplate5W As Slide, slideTemplate6W As Slide
Dim currentSlide As Slide
Dim eventFile As String
Dim eventData As Variant
Dim m As Integer, d As Integer
Dim row As Integer, col As Integer
Dim solarDay As Integer, lunarDay As Integer, gregDay As Integer
Dim solarMonth As Integer, lunarMonth As Integer, gregMonth As Integer
' Array declarations for month day limits
Dim shamsiDays(1 To 12) As Integer
shamsiDays(1) = 31: shamsiDays(2) = 31: shamsiDays(3) = 31
shamsiDays(4) = 31: shamsiDays(5) = 31: shamsiDays(6) = 31
shamsiDays(7) = 30: shamsiDays(8) = 30: shamsiDays(9) = 30
shamsiDays(10) = 30: shamsiDays(11) = 30: shamsiDays(12) = 29
Dim miladiDays(1 To 12) As Integer
miladiDays(1) = 31: miladiDays(2) = 28: miladiDays(3) = 31
miladiDays(4) = 30: miladiDays(5) = 31: miladiDays(6) = 30
miladiDays(7) = 31: miladiDays(8) = 31: miladiDays(9) = 30
miladiDays(10) = 31: miladiDays(11) = 30: miladiDays(12) = 31
Dim ghamariDays(1 To 12) As Integer
ghamariDays(1) = 29: ghamariDays(2) = 29: ghamariDays(3) = 29
ghamariDays(4) = 30: ghamariDays(5) = 29: ghamariDays(6) = 30
ghamariDays(7) = 30: ghamariDays(8) = 29: ghamariDays(9) = 30
ghamariDays(10) = 30: ghamariDays(11) = 30: ghamariDays(12) = 29
Set pptPres = ActivePresentation
eventFile = "/Users/apple/events_output_toolani.txt"
' Read event data into an array
eventData = ReadTextFile(eventFile)
Set slideTemplate5W = pptPres.Slides(1)
Set slideTemplate6W = pptPres.Slides(2)
' Initial Date & Position (1 Farvardin 1404 = Friday)
solarDay = 1: solarMonth = 1
lunarDay = 20: lunarMonth = 1 ' Ramadan 1446
gregDay = 21: gregMonth = 3 ' March 2025
col = 8 ' Starts on Friday
' Loop through 12 Shamsi months
For m = 1 To 12
Dim monthLen As Integer
monthLen = shamsiDays(m)
' FIX: Pure mathematical check for 5-week or 6-week slide template.
' Column 5 is skipped, so we adjust the calculation to mimic 7 active columns.
Dim activeStartCol As Integer
If col >= 6 Then activeStartCol = col - 1 Else activeStartCol = col
If (activeStartCol + monthLen - 1) > 35 Then
Set currentSlide = slideTemplate6W.Duplicate(1)
Else
Set currentSlide = slideTemplate5W.Duplicate(1)
End If
' CRITICAL FIX: Always enforce row 2 at the exact start of every new slide
row = 2
' Loop through days of the current month
For d = 1 To monthLen
' --- SEARCH LOGIC FOR EVENTS ---
Dim eventText As String: eventText = ""
Dim holidayCode As Integer: holidayCode = 1 ' 1 = Normal day by default
Dim lengthCode As Integer: lengthCode = 0
Dim i As Long
Dim prefix As String
prefix = solarDay & "," & m & ","
For i = LBound(eventData) To UBound(eventData)
If Left(eventData(i), Len(prefix)) = prefix Then
Dim parts() As String: parts = Split(eventData(i), ",")
Dim uBoundParts As Integer: uBoundParts = UBound(parts)
lengthCode = CInt(parts(uBoundParts))
holidayCode = CInt(parts(uBoundParts - 1))
Dim k As Integer
For k = 2 To uBoundParts - 2
eventText = eventText & ChrW(CInt(parts(k)))
Next k
Exit For
End If
Next i
' --- Fill Table 4 (Shamsi) ---
With currentSlide.Shapes("Table 4").Table.Cell(row, col).Shape.TextFrame.TextRange
.Text = ConvertToPersian(solarDay)
.Font.Name = "XB Morvarid"
.Font.Size = 16
If holidayCode = 0 And col <> 8 Then
.Font.Color.RGB = RGB(255, 0, 0)
Else
.Font.Color.RGB = RGB(0, 0, 0)
End If
End With
' --- Fill Table 5 (Gregorian & Lunar) ---
With currentSlide.Shapes("Table 5").Table.Cell(row - 1, col).Shape.TextFrame.TextRange
.Text = gregDay & " | " & ConvertToPersian(lunarDay)
.Font.Name = "X Vahid"
.Font.Size = 16
.Font.Color.RGB = RGB(1, 187, 130)
End With
' --- Fill Table 2 (Events) ---
With currentSlide.Shapes("Table 2").Table.Cell(row - 1, col).Shape.TextFrame.TextRange
.Text = eventText
.Font.Name = "X Yekan"
If lengthCode = 5 Then .Font.Size = 8 Else .Font.Size = 9
If holidayCode = 0 Then
.Font.Color.RGB = RGB(255, 0, 0)
Else
.Font.Color.RGB = RGB(0, 0, 0)
End If
End With
' --- Move Rabbit to next cell ---
If col = 8 Then
col = 1
row = row + 1
Else
col = col + 1
If col = 5 Then col = 6 ' Skip empty column
End If
' Advance calendar counters
solarDay = solarDay + 1
lunarDay = lunarDay + 1
gregDay = gregDay + 1
' Check Gregorian limits
If gregDay > miladiDays(gregMonth) Then
gregDay = 1
gregMonth = gregMonth + 1
If gregMonth > 12 Then gregMonth = 1
End If
' Check Lunar limits
If lunarDay > ghamariDays(lunarMonth) Then
lunarDay = 1
lunarMonth = lunarMonth + 1
If lunarMonth > 12 Then lunarMonth = 1
End If
Next d
' Advance Shamsi Month
solarDay = 1
solarMonth = solarMonth + 1
Next m
MsgBox "Done!", vbInformation
End Sub
Function ReadTextFile(filePath As String) As Variant
Dim fileNo As Integer
Dim lineData As String
Dim allLines() As String
Dim count As Long
fileNo = FreeFile
count = 0
Open filePath For Input As #fileNo
Do While Not EOF(fileNo)
Line Input #fileNo, lineData
lineData = Trim(lineData)
If lineData <> "" Then
ReDim Preserve allLines(count)
allLines(count) = lineData
count = count + 1
End If
Loop
Close #fileNo
ReadTextFile = allLines
End Function
Function ConvertToPersian(m As Integer) As String
Dim res As String
Dim digit As Integer
Dim n As Integer
n = m
res = ""
If n = 0 Then
ConvertToPersian = ChrW(1776)
Exit Function
End If
While n > 0
digit = n Mod 10
res = ChrW(1776 + digit) & res
n = n \ 10
Wend
ConvertToPersian = res
End Function