وبلاگ

تبدیل تاریخ بین تقویم‌های مختلف یکی از نیازهای رایج در برنامه‌نویسی است، به‌ویژه برای توسعه‌دهندگانی که با سیستم‌های ایرانی سروکار دارند. در این پست آموزشی، یک ماژول کامل و حرفه‌ای برای تبدیل تاریخ‌های شمسی (جلالی) به میلادی (گرگوری) و بالعکس را بررسی می‌کنیم.

مقدمه و معرفی ماژول

این ماژول با نام DateConvertor برای استفاده در محیط VBA Access طراحی شده و امکان تبدیل دقیق تاریخ بین دو تقویم شمسی و میلادی را فراهم می‌کند. این ماژول برای محاسبه تاریخ شمسی، از یک سال پایه میلادی (21-03-1921) استفاده می‌کند. به این صورت که تاریخ سال پایه به‌صورت شمسی و میلادی در نظر گرفته می‌شود و فاصله زمانی بین سال پایه میلادی و تاریخ ورودی میلادی به‌صورت تعداد روز محاسبه می‌گردد. سپس با کمک یک حلقه و بر اساس الگوریتم گاهشماری حسابی رایانه‌ای که توسط موسی اکرمی طراحی شده است، کبیسه بودن یا نبودن سال شمسی مشخص شده و تعداد روزها دوباره به سال، ماه و روز شمسی تبدیل می‌شود.

Option Explicit 
'==============================================================' 
'هدف ماژول: تبدیل تاریخ شمسی به میلادی و بالعکس' 
'تاریخ ایجاد: 18-05-1397 (08-09-2018)' 
'مبدا تاریخ شمسی: 01-01-1300' 
'مبدا تاریخ میلادی: 21-03-1921' 
'=============================================================='

ساختار کلی و تعاریف اولیه

ماژول با تعریف متغیرهای سراسری و Enum برای نوع خروجی شروع می‌شود:

Dim calcYear As Variant 
Dim JCDaysCount As Long 
Dim JCMonth As Integer 
Dim JCYear As Integer 
Dim JCRemainDays As Integer 
'... و سایر متغیرها 
Enum jCalendar_returnValueType 
    jcSplitArray = 1 'خروجی به صورت آرایه' 
    jcNumber = 2 'خروجی به صورت عدد' 
    jcString = 3 'خروجی به صورت رشته' 
End Enum

تابع تشخیص سال کبیسه شمسی

اولین تابع مهم، تابع تشخیص سال کبیسه است که بر اساس محاسبات نجومی کار می‌کند:

Public Function JalaliKabise(Yr As Integer) As Boolean 
    calcYear = (Yr + 2346) * (0.24219858156) 
    calcYear = calcYear - Int(calcYear) 
    If calcYear < 0.24219858156 Then 
        JalaliKabise = True 
    Else 
        JalaliKabise = False 
    End If 
End Function    

این تابع با استفاده از یک الگوریتم ریاضی دقیق، تشخیص می‌دهد که آیا سال شمسی ورودی کبیسه است یا خیر.

تابع تبدیل میلادی به شمسی (JalaliCalendar)

تابع اصلی تبدیل تاریخ میلادی به شمسی تابع JalaliCalendar می‌باشد. این تابع دو آرگومان ورودی به نام‌های InputDate و returnValueType می‌باشد. آرگومان InputDate تاریخ میلادی ورودی و نوع داده آن باید Date باشد. آرگومان returnValueType از نوع داده سفارشی jCalendar_returnValueType می‌باشد که یک Enum است و می‌تواند سه مقدار jcSplitArray، jcNumber و jcString داشته باشد. دارای سه مرحله اصلی برای تبدیل تاریخ میلادی به شمسی است:

مرحله 1: محاسبه روزهای گذشته از مبدا

JCDaysCount = DateDiff("d", #3/21/1921#, InputDate) + 1 
JCYear = 1300    

مرحله 2: تبدیل روزها به سال شمسی

Do Until JCDaysCount < 365 
    If JalaliKabise(JCYear) = True 
        Then D = 366 
    Else 
        D = 365 
    End If 
    If JCDaysCount - D > 0 Then 
        JCDaysCount = JCDaysCount - D 
        JCYear = JCYear + 1 
    Else 
        Exit Do 
    End If 
Loop    

مرحله 3: تبدیل به ماه و روز شمسی

' برای 6 ماه اول سال (31 روزه) 
If (JCRemainDays > 31 And JCRemainDays <= 186) Then 
    JCMonth = 1 
    Do Until JCRemainDays <= 31 
        JCRemainDays = JCRemainDays - 31 
        JCMonth = JCMonth + 1 
    Loop 
End If    

تابع تبدیل شمسی به میلادی

این تابع نیز دارای مراحل مشابه اما معکوس است:

مرحله 1: استخراج اجزای تاریخ

GCJalaliDay = Right(inJalaliDate, 2) 
GCJalaliMonth = Mid(inJalaliDate, 5, 2) 
GCJalaliYear = Left(inJalaliDate, 4)    

مرحله 2: اعتبارسنجی تاریخ ورودی

' کنترل محدوده روز و ماه 
If GCJalaliDay > 31 Or GCJalaliMonth > 12 Then 
    GregorianCalendar = "False" 
    Exit Function 
End If 
' کنترل روزهای ماه اسفند 
If GCJalaliMonth = 12 Then 
    If JalaliKabise(GCJalaliYear) = False Then 
        If GCJalaliDay > 29 Then 
            GregorianCalendar = "False" 
            Exit Function 
        End If 
    End If 
End If    

نحوه استفاده از توابع

فرمت تاریخ ورودی برای توابع باید به صورت YYYYMMDD باشد. مثال: 14030615 برای تاریخ 15 شهریور 1403

انواع خروجی‌های ممکن

' 1. خروجی رشته‌ای 
Dim strDate As String 
strDate = JalaliCalendar(Date, jcString) ' نتیجه: "شنبه 15 شهریور 1403" ' 2. خروجی عددی 
Dim numDate As Long 
numDate = JalaliCalendar(Date, jcNumber) ' نتیجه: 14030615 ' 3. خروجی آرایه‌ای 
Dim arrDate() As String 
arrDate = Split(JalaliCalendar(Date, jcSplitArray), "!") ' نتیجه: آرایه شامل "15", "6", "1403"]    

مثال‌های کاربردی

مثال 1: نمایش تاریخ امروز به شمسی

Sub ShowTodayJalali() 
    Dim todayJalali As String 
    todayJalali = JalaliCalendar(Date, jcString) 
    MsgBox "امروز: " & todayJalali 
End Sub    

مثال 2: تبدیل تاریخ شمسی به میلادی

Sub ConvertToGregorian() 
    Dim jalaliDate As Long 
    Dim gregorianDate As Date 
    jalaliDate = 14030615 ' 15 شهریور 1403 
    gregorianDate = GregorianCalendar(jalaliDate, True) 
    MsgBox "تاریخ میلادی: " & Format(gregorianDate, "dd/mm/yyyy") 
End Sub    

مثال 3: محاسبه سن

Function CalculateAge(birthDate As Long) As Integer 
    Dim todayJalali As Long 
    todayJalali = JalaliCalendar(Date, jcNumber) 
    Dim age As Integer 
    age = (todayJalali - birthDate) \ 10000 
    CalculateAge = age 
End Function    

کد کامل ماژول

Option Explicit
'=============================================================='
'module target: convert Jalali date to Gregorian and vice versa'
'module created by Sadegh Abshenas''''''''''''''''''''''''''''''
'Jalali base date: 01-01-1300'''''''''''''''''''''''''''''''''''
'Gregorian base date: 21-03-1921''''''''''''''''''''''''''''''''
'=============================================================='
Dim calcYear As Variant
Dim j As Integer
Dim bytDay As Byte
Dim bytMonth As Byte
Dim intYear As Integer
Dim D As Integer
Dim JCDaysCount As Long
Dim JCMonth As Integer
Dim JCYear As Integer
Dim JCRemainDays As Integer
Dim bytDayOfWeek As Byte
Dim strFaMonth As String
Dim strFaDay As String
Dim GCYear As Integer
Dim GCDaysCount As Long
Dim GCMonth As Integer
Dim GCYearNow As Integer
Dim GCDayNow As Integer
Dim GCMonthNow As Integer
Dim GCJalaliNow As String
Dim arrGCJalaliNow() As String
Dim GCcalculateDate As Date
Dim GCJalaliDay As Integer
Dim GCJalaliMonth As Integer
Dim GCJalaliYear As Integer
Dim strJCMonth As String
Dim strJCRemainDays As String
Enum jCalendar_returnValueType
    jcSplitArray = 1
    jcNumber = 2
    jcString = 3
End Enum


Public Function JalaliKabise(Yr As Integer) As Boolean
    calcYear = (Yr + 2346) * (0.24219858156)
    calcYear = calcYear - Int(calcYear)
    
    If calcYear < 0.24219858156 Then
        'MsgBox "اين سال کبيسه مي باشد"
        JalaliKabise = True
    Else
        'MsgBox "اين سال کبيسه نمي باشد"
        JalaliKabise = False
    End If
    
End Function
    
    '----------------------------------------------------------------------
    'important note for JalaliCalendar Function: inputArgs help
    'there is two method to work with this function
    'method 1: input date must seprate into day, month and year
    'on this method first 3 Args must fill and bolDateFormat set to false
    'returnValueType just change return value format, if set to true return
    'value seprate into string variable with ! as Separator
    'method 2: a date variable set as input value (last args)
    'on this method last 2 args must fill and bolDateFormat must set to true
    '----------------------------------------------------------------------

Public Function JalaliCalendar(InputDate As Date, Optional returnValueType As jCalendar_returnValueType = jcString) As Variant
    
    ' محاسبه اختلاف روزهاي تاريخ مبدا محسابه و تاريخ ورودي تابع
    JCDaysCount = DateDiff("d", #3/21/1921#, InputDate) + 1
    'JCDaysCount = DateDiff("d", #3/21/2010#, Now) + 1 'note محاسبه اختلاف تاريخ مبدا تا امروز به ماخذ ميلادي
    
    JCYear = 1300 'note سال مبدا شمسي
    
    'note در مرحله اول بايد که روزهاي گذشته شده از مبدا ميلادي تبديل به سال، روز و ماه شمسي گردد
    Do Until JCDaysCount < 365 'note حلقه تا زماني که روزهاي محاسبه شده از مبدا محاسبه کمتر از 365 گردد
        If JalaliKabise(JCYear) = True Then 'note به ازاي هر سال کبيسه بودن سال بررسي مي گردد
            D = 366 'note روزهاي سال کبيسه
        Else
            D = 365 'note روزهاي سال غير کبيسه
        End If
        If JCDaysCount - D > 0 Then 'note اگر اختلاف بين روزها برابر يک سال شود از حلقه بايد خارج شويم
            JCDaysCount = JCDaysCount - D 'note روزهاي سال از کل روزهاي گذشته شده از مبدا کم مي شود و يکسال به عدد سال اضافه مي گردد
            JCYear = JCYear + 1
        Else
            Exit Do
        End If
    Loop
                            
    JCRemainDays = JCDaysCount
    
    If (JCRemainDays <= 31) Then
        JCMonth = 1
    End If
    
    If (JCRemainDays > 31 And JCRemainDays <= 186) Then
        JCMonth = 1
        Do Until JCRemainDays <= 31
            JCRemainDays = JCRemainDays - 31
            JCMonth = JCMonth + 1
        Loop
    End If
    
    If (JCRemainDays > 186 And JCRemainDays <= 336) Then
        JCMonth = 7
        JCRemainDays = JCRemainDays - 186
        Do Until JCRemainDays <= 30
            JCRemainDays = JCRemainDays - 30
            JCMonth = JCMonth + 1
        Loop
    End If
    
    If (JCRemainDays > 336 And JCRemainDays < 365) Then
        JCMonth = 12
        JCRemainDays = JCRemainDays - 336
    End If
    
    If JCRemainDays = 365 Then
        JCMonth = 12
        JCRemainDays = 29
    End If
    
    If JCRemainDays = 366 Then
        If JalaliKabise(JCYear) = True Then
            JCMonth = 12
            JCRemainDays = 30
        Else
            JCMonth = 1
            JCRemainDays = 1
            JCYear = JCYear + 1
        End If
    End If
        
    bytDayOfWeek = Format(InputDate, "w", vbSaturday)
    
    If returnValueType = jcSplitArray Then
        JalaliCalendar = JCRemainDays & "!" & JCMonth & "!" & JCYear
        Exit Function
    End If
    
    If returnValueType = jcNumber Then
        If JCMonth < 10 Then
            strJCMonth = 0 & JCMonth
        Else
            strJCMonth = JCMonth
        End If
        
        If JCRemainDays < 10 Then
            strJCRemainDays = 0 & JCRemainDays
        Else
            strJCRemainDays = JCRemainDays
        End If
        
        JalaliCalendar = JCYear & strJCMonth & strJCRemainDays
        Exit Function
    End If
    
    Select Case JCMonth
        Case 1
            strFaMonth = "فروردين"
        Case 2
            strFaMonth = "ارديبهشت"
        Case 3
            strFaMonth = "خرداد"
        Case 4
            strFaMonth = "تير"
        Case 5
            strFaMonth = "مرداد"
        Case 6
            strFaMonth = "شهريور"
        Case 7
            strFaMonth = "مهر"
        Case 8
            strFaMonth = "آبان"
        Case 9
            strFaMonth = "آذر"
        Case 10
            strFaMonth = "دي"
        Case 11
            strFaMonth = "بهمن"
        Case 12
            strFaMonth = "اسفند"
    End Select
    
    Select Case bytDayOfWeek
        Case 1
            strFaDay = "شنبه"
        Case 2
            strFaDay = "يکشنبه"
        Case 3
            strFaDay = "دوشنبه"
        Case 4
            strFaDay = "سه شنبه"
        Case 5
            strFaDay = "چهارشنبه"
        Case 6
            strFaDay = "پنجشنبه"
        Case 7
            strFaDay = "جمعه"
    End Select
    
    If returnValueType = jcString Then
        JalaliCalendar = strFaDay & " " & JCRemainDays & " " & strFaMonth & " " & JCYear
    End If
    
End Function
Public Function GregorianCalendar(inJalaliDate As Long, jalaliDateToGregorian As Boolean) As Variant
    
    GCJalaliDay = Right(inJalaliDate, 2)
    GCJalaliMonth = Mid(inJalaliDate, 5, 2)
    GCJalaliYear = Left(inJalaliDate, 4)
    
    'note کنترل هاي اوليه براي ماه و روز
    '--------------------------------------------------------------------------
    If GCJalaliDay > 31 Or GCJalaliMonth > 12 Then
        GregorianCalendar = "False"
        MsgBox "تاريخ ورودي اشتباه مي باشد", vbCritical
        Exit Function
    End If
    
    If GCJalaliDay = 0 Or GCJalaliMonth = 0 Or GCJalaliYear < 1300 Then 'note کنترل هاي اوليه براي ماه و روز
        GregorianCalendar = "False"
        MsgBox "تاريخ ورودي اشتباه مي باشد", vbCritical
        Exit Function
    End If
    
    If GCJalaliMonth > 6 Then 'note کنترل روزهاي ورودي تابع با توجه به ماه ورودي تابع
        If GCJalaliDay > 30 Then
            GregorianCalendar = "False"
            MsgBox "تاريخ ورودي اشتباه مي باشد", vbCritical
            Exit Function
        End If
    End If
    If GCJalaliMonth = 12 Then 'note کنترل روزهاي ماه اسفند براي سال هاي غيرکبيسه تا بيشتر از 29 روز نباشد
        If JalaliKabise(GCJalaliYear) = False Then
            If GCJalaliDay > 29 Then
                GregorianCalendar = "False"
                MsgBox "تعداد روزهاي اسفند ماه بدرستي وارد نشده است", vbCritical
                Exit Function
            End If
        End If
    End If
    '--------------------------------------------------------------------------
    'note پايان کنترل هاي اوليه
    'note شروع تبديل تاريخ به روز
    'note در مرحله اول مي بايست روزهاي گذشته از مبدا تاريخ شمسي محاسبه گردد
    'note مبدا تاريخ شمسي در نظر گرفته شده ابتداي سال 1300 مي باشد
    GCDaysCount = 0
    GCYear = 1300
    Do Until GCYear = GCJalaliYear
        If JalaliKabise(GCYear) = True Then 'note به ازاي هر سال کبيسه بودن سال بررسي مي گردد
            D = 366 'note روزهاي سال کبيسه
        Else
            D = 365 'note روزهاي سال غير کبيسه
        End If
        GCDaysCount = GCDaysCount + D
        GCYear = GCYear + 1
    Loop
    'note نتيجه حلقه بالا جمع روزهاي سپري شده از مبدا شمسي تا تاريخ موردنظر در آرگومان تابع مي باشد
    'note در خطوط بعدي بايد ماه تبديل به روز شود
    GCMonth = GCJalaliMonth - 1
    If GCMonth <> 0 Then 'note در اين جا تعداد روزهاي ماه موردنظر در آرگومان تابع به شرطي که 1 (يعني فروردين) نباشد محاسبه مي شود
        Select Case GCMonth
                    Case 1 'note اگر ماه فروردين باشد 31 روز به روزها اضافه مي شود
                        GCDaysCount = GCDaysCount + 31
                    Case 2
                        GCDaysCount = GCDaysCount + 62
                    Case 3
                        GCDaysCount = GCDaysCount + 93
                    Case 4
                        GCDaysCount = GCDaysCount + 124
                    Case 5
                        GCDaysCount = GCDaysCount + 155
                    Case 6
                        GCDaysCount = GCDaysCount + 186
                    Case 7
                        GCDaysCount = GCDaysCount + 216
                    Case 8
                        GCDaysCount = GCDaysCount + 246
                    Case 9
                        GCDaysCount = GCDaysCount + 276
                    Case 10
                        GCDaysCount = GCDaysCount + 306
                    Case 11
                        GCDaysCount = GCDaysCount + 336
        End Select
    End If
    'note افزودن روزهاي آرگومان تابع به کل روزها اضافه مي شود
    GCDaysCount = GCDaysCount + GCJalaliDay
    'note تبديل تاريخ شمسي وارد شده به تاريخ ميلادي با اضافه کردن روزهاي محاسبه شده به مبدا ميلادي
    GCcalculateDate = DateAdd("d", GCDaysCount - 1, #3/21/1921#)
    
    If jalaliDateToGregorian = True Then
        GregorianCalendar = GCcalculateDate 'note تاريخ ميلادي بعنوان خروجي تابع
        Exit Function
    End If
    
    'note تبديل تاريخ ميلادي روز جاري به شمسي براي تشخيص اينکه تاريخ ورودي تابع بعد از تاريخ امروز نباشد
        GCJalaliNow = JalaliCalendar(Now, jcSplitArray)
        arrGCJalaliNow = Split(GCJalaliNow, "!")
        GCDayNow = arrGCJalaliNow(0)
        GCMonthNow = arrGCJalaliNow(1)
        GCYearNow = arrGCJalaliNow(2)
    'note مقايسه تاريخ امروز و تاريخ ورودي تابع و تشخيص ورودي درست کاربر
    '----------------------------------------------------------------------------
    If GCYearNow < GCJalaliYear Then
        MsgBox "تاريخ آتي نمي تواند وارد گردد", vbCritical
        GregorianCalendar = "False"
        Exit Function
    End If
    If GCYearNow = GCJalaliYear Then
        If GCMonthNow < GCJalaliMonth Then
            MsgBox "تاريخ آتي نمي تواند وارد گردد", vbCritical
            GregorianCalendar = "False"
            Exit Function
        End If
    End If
    If GCYearNow = GCJalaliYear Then
        If GCMonthNow = GCJalaliMonth Then
            If GCDayNow < GCJalaliDay Then
                MsgBox "تاريخ آتي نمي تواند وارد گردد", vbCritical
                GregorianCalendar = "False"
                Exit Function
            End If
        End If
    End If
    'note پايان مقايسه
    '----------------------------------------------------------------------------
    'note مقداردهي به تابع
    GregorianCalendar = JalaliCalendar(GCcalculateDate, jcString)
    
End Function

Public Function JCDateDiff(firstDate As Long, secoundDate As Long)
    JCDateDiff = DateDiff("d", _
        GregorianCalendar(firstDate, True), _
        GregorianCalendar(secoundDate, True), _
        vbSaturday)
End Function

ویدیوی آموزشی نحوه انتقال و استفاده از توابع ماژول برای تبدیل تاریخ شمسی به میلادی در اکسل

جمع‌بندی

این ماژول ابزار کاملی برای کار با تاریخ‌های شمسی و میلادی در محیط VBA فراهم می‌کند. با استفاده از این کد می‌توانید:

• تاریخ میلادی را به شمسی تبدیل کنید
• تاریخ شمسی را به میلادی تبدیل کنید
• سال کبیسه شمسی را تشخیص دهید
• اختلاف بین دو تاریخ شمسی را محاسبه کنید
• تاریخ‌های شمسی را اعتبارسنجی کنید

این ماژول می‌تواند در پروژه‌های مختلفی مانند سیستم‌های حسابداری، برنامه‌های مدیریتی، و هر برنامه‌ای که نیاز به کار با تاریخ‌های شمسی دارد، مورد استفاده قرار گیرد.