برنامه تقویم فارسی

براي ايجاد تقويم در برنامه تون از كد سورس زير استفاده كن..

Imports System.IO
Imports System.Text
Module Module1

Public Function fdate() As Long
On Error Resume Next
Dim yearEqual(2, 2) As Integer
Dim AddOneDay As Boolean
Dim AddFarDay As Boolean
Dim AddToDays As Byte, FarDay As Byte
Dim ThisDay As Byte
Dim ThisMonth As Byte
Dim Thisyear As Integer
Dim YearDif1 As Integer, YearDif2 As Integer
Dim TestRange1 As Integer, TestRange2 As Integer
Dim FarsiRange1 As Integer, FarsiRange2 As Integer
Dim p As Integer
Dim CurM As String, CurD As String
Dim sYear As Object, sMonth As Object, sDay As Object
Dim Currentyear As String
Dim Currentday As Byte
Dim Currentmonth As Byte
Dim a As Object
REM
yearEqual(1, 1) = 1997
yearEqual(1, 2) = 1998
yearEqual(2, 1) = 1376
yearEqual(2, 2) = 1377
ThisDay = Today.Day




ThisMonth = Month(Now)
Thisyear = Year(Now)
YearDif1 = Thisyear - 1997
YearDif2 = Thisyear - 1998
TestRange1 = 1996 - (100 * 4)
TestRange2 = 1996 + (100 * 4)
FarsiRange1 = 1375 - (100 * 4)
FarsiRange2 = 1375 + (100 * 4)
AddOneDay = False
REM
For p = TestRange1 To TestRange2 Step 4
If Thisyear = p Then
AddOneDay = True
Exit For
End If
Next
If AddOneDay Then
AddToDays = 1
Else
AddToDays = 0
End If

REM
If ((ThisMonth = 3 And ThisDay < 20 + AddToDays) Or (ThisMonth < 3)) Then
YearDif1 = YearDif1 - 1
End If
REM
If (Thisyear Mod 2 <> 0 And ((ThisMonth = 3 And ThisDay > (20 - AddToDays)) Or (ThisMonth > 4))) Then
Currentyear = yearEqual(2, 1) + YearDif1
Else
Currentyear = yearEqual(2, 1) + YearDif2

For p = FarsiRange1 To FarsiRange2 Step 4
If Currentyear = p Then AddFarDay = True
Exit For
Next p

If AddFarDay Then
FarDay = 1
Else
FarDay = 0
End If

If ((ThisMonth = 3 And ThisDay > 20 - (AddToDays) + FarDay) Or ThisMonth > 3) Then Currentyear = Currentyear + 1
End If

If AddToDays = 1 Then
FarDay = 0
End If
REM
Select Case ThisMonth
Case 1
If ThisDay < (21 - FarDay) Then
Currentmonth = 10
Currentday = (ThisDay + 10) + FarDay
Else
Currentmonth = 11
Currentday = (ThisDay - 20) + FarDay
End If
Case 2
If ThisDay < (20 - FarDay) Then
Currentmonth = 11
Currentday = (ThisDay + 11) + FarDay
Else
Currentmonth = 12
Currentday = (ThisDay - 19) + FarDay
End If
Case 3
If ThisDay < (21 - AddToDays) Then
Currentmonth = 12
Currentday = (ThisDay + 9) + AddToDays + FarDay
Else
Currentmonth = 1
Currentday = (ThisDay - 20) + AddToDays
End If
Case 4
If ThisDay < (21 - AddToDays) Then
Currentmonth = 1
Currentday = (ThisDay + 11) + AddToDays
Else
Currentmonth = 2
Currentday = (ThisDay - 20) + AddToDays
End If
Case 5
If ThisDay < (22 - AddToDays) Then
Currentmonth = 2
Currentday = (ThisDay + 10) + AddToDays
Else
Currentmonth = 3
Currentday = (ThisDay - 21) + AddToDays
End If
Case 6
If ThisDay < (22 - AddToDays) Then
Currentmonth = 3
Currentday = (ThisDay + 10) + AddToDays
Else
Currentmonth = 4
Currentday = (ThisDay - 21) + AddToDays
End If
Case 7
If ThisDay < (23 - AddToDays) Then
Currentmonth = 4
Currentday = (ThisDay + 9) + AddToDays
Else
Currentmonth = 5
Currentday = (ThisDay - 22) + AddToDays
End If
Case 8
If ThisDay < (23 - AddToDays) Then
Currentmonth = 5
Currentday = (ThisDay + 9) + AddToDays
Else
Currentmonth = 6
Currentday = (ThisDay - 22) + AddToDays
End If
Case 9
If ThisDay < (23 - AddToDays) Then
Currentmonth = 6
Currentday = (ThisDay + 9) + AddToDays
Else
Currentmonth = 7
Currentday = (ThisDay - 22) + AddToDays
End If
Case 10
If ThisDay < (23 - AddToDays) Then
Currentmonth = 7
Currentday = (ThisDay + 8) + AddToDays
Else
Currentmonth = 8
Currentday = (ThisDay - 22) + AddToDays
End If
Case 11
If ThisDay < (22 - AddToDays) Then
Currentmonth = 8
Currentday = (ThisDay + 9) + AddToDays
Else
Currentmonth = 9
Currentday = (ThisDay - 21) + AddToDays
End If
Case 12
If ThisDay < (22 - AddToDays) Then
Currentmonth = 9
Currentday = (ThisDay + 9) + AddToDays
Else
Currentmonth = 10
Currentday = (ThisDay - 21) + AddToDays
End If
End Select
REM
CurM = Trim(Str(Currentmonth))
CurD = Trim(Str(Currentday))
REM
If Currentmonth < 10 Then CurM = "0" & Trim(Str(Currentmonth))
'End If
If Currentday < 10 Then CurD = "0" & Trim(Str(Currentday))
fdate = Val(Trim(Str(Currentyear)) & CurM & CurD)
'End If
End Function

Public Function _Fdate()
_Fdate = Left(fdate(), 4) & "/" & Mid(fdate(), 5, 2) & "/" & Right(fdate(), 2)

End Function ​

​