ایجاد یک تقویم شمسی
استفاده از یک تقویم شمسی به جای تقویم میلادی
ابتدا یک پروژه ی جدید ایجاد کرده و در داخل آن نیز یک ماژول اضافه کنید
در داخل ماژول این کد را وارد نمایید:
Private Month_Name, Spring_Fall
Private Time_Difference, Time_Client
Private Base_Year
Private Sub Get_Date(ByVal Days, Sal, Mah, Rooz)
Dim Years, Year_Length
Do While Days >= 0
If Kabiseh(Years) Then
Year_Length = 366
Else
Year_Length = 365
End If
If Days - Year_Length >= 0 Then
Years = Years + 1
Days = Days - Year_Length
Else
Sal = Base_Year + Years
If Days <= 185 Then
Mah = 1 + (Days \ 31)
Rooz = 1 + (Days Mod 31)
Else
Days = Days - 186
Mah = 7 + (Days \ 30)
Rooz = 1 + (Days Mod 30)
End If
Exit Sub
End If
End Sub
Private Function Kabiseh(ByVal Years)
Dim Temp
Kabiseh = False
Temp = (Base_Year + Years) - 1309
If (((Temp Mod 32) - (Temp \ 32)) Mod 4) = 0 Then Kabiseh = True
End Function
Public Property Let SFhour(x)
Spring_Fall = x
End Property
Public Property Let Time_Diff(ByVal t)
Time_Difference = t
End Property
Public Property Let state(ByVal s)
Month_Name = s
End Property
Public Function To_Hejri(ByVal what_date, Optional Month_Name)
Dim Days, Day_Name, Day_Number, Temp_Days, Months
Spring_Fall = False
If IsMissing(Month_Name) Then Month_Name = 0
Time_Difference = #12:00:00 AM#
Base_Year = 1332
Months = Array(" فروردين", " ارديبهشت ", "خرداد", " تير ", " مرداد ", " شهريور ", " مهر ", " آبان ", " آذر ", " دي ", " بهمن ", " اسفند ")
Day_Name = Array("يکشنبه", " دوشنبه", "سه شنبه", "چهارشنبه", "پنجشنبه", "جمعه", "شنبه")
Days = DateDiff("d", #3/21/1953#, what_date)
Day_Number = Weekday(what_date)
Dim Year_Length, Sal, Mah, Rooz, temp_date
If FormatDateTime(what_date + Time_Difference, vbShortDate) <> FormatDateTime(what_date, vbShortDate) Then
Days = Days + 1
Day_Number = (Day_Number + 1)
If Day_Number = 8 Then Day_Number = 1
End If
Time_Client = FormatDateTime(what_date + Time_Difference, vbLongTime)
Call Get_Date(Days, Sal, Mah, Rooz)
If ((Mah >= 1 And Mah <= 6) And Not ((Mah = 1 And Rooz = 1) Or (Mah = 6 And Rooz = 31))) And Spring_Fall = True Then
If FormatDateTime(what_date + Time_Difference + #1:00:00 AM#, vbShortDate) <> FormatDateTime(what_date + Time_Difference, vbShortDate) Then
Temp_Days = Days + 1
Day_Number = (Day_Number + 1)
If Day_Number = 8 Then Day_Number = 1
Else
Temp_Days = Days
End If
Time_Client = FormatDateTime(what_date + Time_Difference + #1:00:00 AM#, vbLongTime)
If Temp_Days <> Days Then
Days = Temp_Days
If Rooz = 30 And Mah = 6 Then
If DateDiff("n", Time_Client, #1:00:00 AM#) <= 60 And DateDiff("n", Time_Client, #1:00:00 AM#) >= 0 Then
Time_Client = FormatDateTime(what_date + Time_Difference, vbLongTime)
Days = Days - 1
If Day_Number = 1 Then
Day_Number = 7
Else
Day_Number = Day_Number - 1
End If
End If
End If
Call Get_Date(Days, Sal, Mah, Rooz)
End If
End If
If Month_Name = 0 Then
If Rooz < 10 Then Rooz = "0" & Rooz
If Mah < 10 Then Mah = "0" & Mah
To_Hejri = Rooz & "/" & Mah & "/" & Sal
ElseIf Month_Name = 1 Then
To_Hejri = Rooz & " " & Months(Mah - 1) & " " & Sal
ElseIf Month_Name = 2 Then
To_Hejri = Day_Name(Day_Number - 1) & " " & Rooz & "/" & Mah & "/" & Sal
ElseIf Month_Name = 3 Then
To_Hejri = Day_Name(Day_Number - 1) & " " & Rooz & " " & Months(Mah - 1) & " " & Sal
End If
End Function
Public Function To_Time(what_date)
Call To_Hejri(what_date)
To_Time = Time_Client
End Function
Private Sub Class_Initialize()
Spring_Fall = False
Month_Name = 0
Time_Difference = #12:00:00 AM#
Base_Year = 1332
End Sub
بعد از وارد نمودن کد فوق در ماژول بر روی فرم خود یک Label و یک Timer ایجاد نمایید.
خاصیت اینتروال تایمر را برابر 1 قرار دهید و یکی از کدهای زیر را وارد نمایید:
Private Sub Timer1_Timer()
Label1 = To_Hejri(Date, 1)
End Sub
یا
Private Sub Timer1_Timer()
Label1 = To_Hejri(Date, 2)
End Sub
یا
Private Sub Timer1_Timer()
Label1 = To_Hejri(Date, 3)
End Sub
با این وجود شما صاحب یک تقویم شمسی می شوید
نظر یادتون نره
