Attribute VB_Name = "PersianDateword"
Private Function Ceil(Number As Single) As Long
    Ceil = -Sgn(Number) * Int(-Abs(Number))
End Function
' Determine Julian day from Persian date
Function persian_jdn(iYear, iMonth, iDay)
    Const PERSIAN_EPOCH = 1948321 ' The JDN of 1 Farvardin 1
    Dim epbase As Long
    Dim epyear As Long
    Dim mdays As Long
    If iYear >= 0 Then
        epbase = iYear - 474
    Else
        epbase = iYear - 473
    End If
    epyear = 474 + (epbase Mod 2820)
    If iMonth <= 7 Then
        mdays = (CLng(iMonth) - 1) * 31
    Else
        mdays = (CLng(iMonth) - 1) * 30 + 6
    End If
    persian_jdn = CLng(iDay) _
            + mdays _
            + Fix(((epyear * 682) - 110) / 2816) _
            + (epyear - 1) * 365 _
            + Fix(epbase / 2820) * 1029983 _
            + (PERSIAN_EPOCH - 1)
End Function
Sub jdn_persian(jdn, iYear, iMonth, iDay)
    Dim depoch
    Dim cycle
    Dim cyear
    Dim ycycle
    Dim aux1, aux2
    Dim yday
    depoch = jdn - persian_jdn(475, 1, 1)
    cycle = Fix(depoch / 1029983)
    cyear = depoch Mod 1029983
    If cyear = 1029982 Then
        ycycle = 2820
    Else
        aux1 = Fix(cyear / 366)
        aux2 = cyear Mod 366
        ycycle = Int(((2134 * aux1) + (2816 * aux2) + 2815) / 1028522) + aux1 + 1
    End If
    iYear = ycycle + (2820 * cycle) + 474
    If iYear <= 0 Then
        iYear = iYear - 1
    End If
    yday = (jdn - persian_jdn(iYear, 1, 1)) + 1
    If yday <= 186 Then
        iMonth = Ceil(yday / 31)
    Else
        iMonth = Ceil((yday - 6) / 30)
    End If
    iDay = (jdn - persian_jdn(iYear, iMonth, 1)) + 1
End Sub
Function civil_jdn(ByVal iYear, ByVal iMonth, ByVal iDay)
    Dim lYear
    Dim lMonth
    Dim lDay
    Dim calendatType
    calendarType = Gregorian
    If calendarType = Gregorian And ((iYear > 1582) _
        Or ((iYear = 1582) And (iMonth > 10)) _
        Or ((iYear = 1582) And (iMonth = 10) And (iDay > 14))) Then
        lYear = CLng(iYear)
        lMonth = CLng(iMonth)
        lDay = CLng(iDay)
        civil_jdn = ((1461 * (lYear + 4800 + ((lMonth - 14) \ 12))) \ 4) _
                + ((367 * (lMonth - 2 - 12 * (((lMonth - 14) \ 12)))) \ 12) _
                - ((3 * (((lYear + 4900 + ((lMonth - 14) \ 12)) \ 100))) \ 4) _
                + lDay - 32075
    Else
        civil_jdn = julian_jdn(iYear, iMonth, iDay)
    End If
End Function
Sub jdn_julian(jdn, iYear, iMonth, iDay)
    Dim L As Long
    Dim K As Long
    Dim n As Long
    Dim I As Long
    Dim j As Long
    j = jdn + 1402
    K = ((j - 1) \ 1461)
    L = j - 1461 * K
    n = ((L - 1) \ 365) - (L \ 1461)
    I = L - 365 * n + 30
    j = ((80 * I) \ 2447)
    iDay = I - ((2447 * j) \ 80)
    I = (j \ 11)
    iMonth = j + 2 - 12 * I
    iYear = 4 * K + n + I - 4716
End Sub
Function julian_jdn(iYear, iMonth, iDay) As Long
   
    julian_jdn = 367 * lYear - _
            ((7 * (lYear + 5001 + ((lMonth - 9) \ 7))) \ 4) _
            + ((275 * lMonth) \ 9) + lDay + 1729777
End Function
Sub jdn_civil(jdn, iYear, iMonth, iDay)
    Dim L
    Dim K
    Dim n
    Dim I
    Dim j
    If (jdn > 2299160) Then
        L = jdn + 68569
        n = ((4 * L) \ 146097)
        L = L - ((146097 * n + 3) \ 4)
        I = ((4000 * (L + 1)) \ 1461001)
        L = L - ((1461 * I) \ 4) + 31
        j = ((80 * L) \ 2447)
        iDay = L - ((2447 * j) \ 80)
        L = (j \ 11)
        iMonth = j + 2 - 12 * L
        iYear = 100 * (n - 49) + I + L
    Else
        Call jdn_julian(jdn, iYear, iMonth, iDay)
    End If
End Sub
'Function miladi(myDate)
'    iDay = Day(myDate)
'    iMonth = Month(myDate)
'    iYear = Year(myDate)
'    jdn = civil_jdn(iYear, iMonth, iDay)
'    Call jdn_persian(jdn, iYear, iMonth, iDay)
'    miladi = iYear & "/" & iMonth & "/" & iDay
'End Function
Function Miladi(mydate)
   Dim iYear, iMonth, iDay
    For I = 1 To Len(mydate)
        st = Mid(mydate, I, 1)
        
        If (st = "/" Or st = "-" Or st = "." Or st = "\") And x <> 1 Then
                x = 1
                If I = 3 Then s = "13" & s
        Else
                If (st = "/" Or st = "-" Or st = "." Or st = "\") And x = 1 Then
                    x = 2
                    If I = 5 Or I = 7 Then s = Left(s, Len(s) - 1) & "0" & Right(s, 1)
                Else
                    s = s & st
                End If
       End If
     Next
        If Len(s) = 7 Then s = Left(s, 6) & "0" & Right(s, 1)
    mydate = s
    iYear = Mid(mydate, 1, 4)
    iMonth = Mid(mydate, 5, 2)
    iDay = Mid(mydate, 7, 2)
    If (iDay > 30 And iMonth > 6) Or iDay > 31 Or iMonth > 12 Then Miladi = "Error": Exit Function
    
    If (iDay = 30 And iMonth = 12) Then
    iYear1 = iYear + 1
    iMonth1 = 1
    iDay1 = 1
    jdn1 = persian_jdn(iYear1, iMonth1, iDay1)
    jdn = persian_jdn(iYear, iMonth, iDay)
    If jdn1 = jdn Then Miladi = "Error": Exit Function
    End If
    
    jdn = persian_jdn(iYear, iMonth, iDay)
    Call jdn_civil(jdn, iYear, iMonth, iDay)
    Miladi = iYear & "/" & iMonth & "/" & iDay
End Function
Function Shamsi(mydate, Optional Format = 0)
    iDay = Day(mydate)
    iMonth = Month(mydate)
    iYear = Year(mydate)
    iWeekday = Weekday(mydate)
    jdn = civil_jdn(iYear, iMonth, iDay)
    Call jdn_persian(jdn, iYear, iMonth, iDay)
    
    Select Case iWeekday
    Case 1
        Rooz = ChrW(1740) & ChrW(1705) & ChrW(1588) & ChrW(1606) & ChrW(1576) & ChrW(1607)
    Case 2
        Rooz = ChrW(1583) & ChrW(1608) & ChrW(1588) & ChrW(1606) & ChrW(1576) & ChrW(1607)
    Case 3
        Rooz = ChrW(1587) & ChrW(1607) & ChrW(8204) & ChrW(1588) & ChrW(1606) & ChrW(1576) & ChrW(1607)
    Case 4
        Rooz = ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585) & ChrW(1588) & ChrW(1606) & ChrW(1576) & ChrW(1607)
    Case 5
        Rooz = ChrW(1662) & ChrW(1606) & ChrW(1580) & ChrW(8204) & ChrW(1588) & ChrW(1606) & ChrW(1576) & ChrW(1607)
    Case 6
        Rooz = ChrW(1580) & ChrW(1605) & ChrW(1593) & ChrW(1607)
    Case 7
        Rooz = ChrW(1588) & ChrW(1606) & ChrW(1576) & ChrW(1607)
    End Select
   Select Case iMonth
    Case 1
        mah = ChrW(1601) & ChrW(1585) & ChrW(1608) & ChrW(1585) & ChrW(1583) & ChrW(1740) & ChrW(1606)
    Case 2
        mah = ChrW(1575) & ChrW(1585) & ChrW(1583) & ChrW(1740) & ChrW(1576) & ChrW(1607) & ChrW(1588) & ChrW(1578)
    Case 3
        mah = ChrW(1582) & ChrW(1585) & ChrW(1583) & ChrW(1575) & ChrW(1583)
    Case 4
        mah = ChrW(1578) & ChrW(1740) & ChrW(1585)
    Case 5
        mah = ChrW(1605) & ChrW(1585) & ChrW(1583) & ChrW(1575) & ChrW(1583)
    Case 6
        mah = ChrW(1588) & ChrW(1607) & ChrW(1585) & ChrW(1740) & ChrW(1608) & ChrW(1585)
    Case 7
        mah = ChrW(1605) & ChrW(1607) & ChrW(1585)
    Case 8
        mah = ChrW(1570) & ChrW(1576) & ChrW(1575) & ChrW(1606)
    Case 9
        mah = ChrW(1570) & ChrW(1584) & ChrW(1585)
    Case 10
        mah = ChrW(1583) & ChrW(1740)
    Case 11
        mah = ChrW(1576) & ChrW(1607) & ChrW(1605) & ChrW(1606)
    Case 12
        mah = ChrW(1575) & ChrW(1587) & ChrW(1601) & ChrW(1606) & ChrW(1583)
    End Select
    Select Case Format
    Case 1
            Shamsi = Rooz & "," & iYear & "/" & iMonth & "/" & iDay
    Case 2
        Shamsi = Rooz & " " & horofi(iDay) & " " & mah & " " & ChrW(1605) & ChrW(1575) & ChrW(1607) & " " & horofi(iYear)
    Case 3
        Shamsi = iYear
    Case 4
        Shamsi = iMonth
    Case 5
        Shamsi = iDay
    Case 0
        Shamsi = iYear & "/" & iMonth & "/" & iDay
    Case Else
        Shamsi = "Only one of this number as format(0,1,2,3,4,5) for help visit http://sakhteman.wordpress.com"
    End Select
End Function
Function horofi(ByVal Number As Double) As String
    Number = Int(Number)
    If Number = 0 Then Adad = ChrW(1589) & ChrW(1601) & ChrW(1585): Exit Function
        Dim Flag As Boolean
        Dim s As String
        Dim I, L As Byte
        Dim K(1 To 5) As Double
        s = Trim(str(Number))
        L = Len(s)
        If L > 15 Then
            Adad = ChrW(1576) & ChrW(1587) & ChrW(1610) & ChrW(1575) & ChrW(1585) & ChrW(1576) & ChrW(1586) & ChrW(1585) & ChrW(1711) & " "
            Exit Function
        End If
    For I = 1 To 15 - L
        s = "0" & s
    Next I
    For I = 1 To Int((L / 3) + 0.99)
        K(5 - I + 1) = Val(Mid(s, 3 * (5 - I) + 1, 3))
    Next I
    Flag = False
    s = " "
    For I = 1 To 5
        If K(I) <> 0 Then
            Select Case I
                Case 1
                s = s & Three(K(I)) & " " & ChrW(1578) & ChrW(1585) & ChrW(1610) & ChrW(1604) & ChrW(1610) & ChrW(1608) & ChrW(1606) & " "
                Flag = True
                Case 2
                s = s & IIf(Flag = True, ChrW(1608), " ") & Three(K(I)) & " " & ChrW(1605) & ChrW(1610) & ChrW(1604) & ChrW(1610) & ChrW(1575) & ChrW(1585) & ChrW(1583) & " "
                Flag = True
                Case 3
                s = s & IIf(Flag = True, ChrW(1608), " ") & Three(K(I)) & " " & ChrW(1605) & ChrW(1610) & ChrW(1604) & ChrW(1610) & ChrW(1608) & ChrW(1606) & " "
                Flag = True
                Case 4
                s = s & IIf(Flag = True, ChrW(1608), " ") & Three(K(I)) & " " & ChrW(1607) & ChrW(1586) & ChrW(1575) & ChrW(1585) & " "
                Flag = True
                Case 5
                s = s & IIf(Flag = True, ChrW(1608), " ") & Three(K(I)) & " "
            End Select
        End If
    Next I
    horofi = Trim(s)
End Function
Function Three(ByVal Number As Integer) As String
Dim s As String
Dim I, L As Long
Dim h(1 To 3) As Byte
Dim Flag As Boolean
    L = Len(Trim(str(Number)))
    If Number = 0 Then
        Three = " "
        Exit Function
    End If
    If Number = 100 Then
        Three = ChrW(1610) & ChrW(1603) & ChrW(1589) & ChrW(1583) & " "
        Exit Function
    End If
    If L = 2 Then h(1) = 0
        If L = 1 Then
        h(1) = 0
        h(2) = 0
    End If
    For I = 1 To L
        h(3 - I + 1) = Mid(Trim(str(Number)), L - I + 1, 1)
    Next I
    Select Case h(1)
        Case 1
        s = " " & ChrW(1610) & ChrW(1603) & ChrW(1589) & ChrW(1583) & " "
        Case 2
        s = " " & ChrW(1583) & ChrW(1608) & ChrW(1610) & ChrW(1587) & ChrW(1578) & " "
        Case 3
        s = " " & ChrW(1587) & ChrW(1610) & ChrW(1589) & ChrW(1583) & " "
        Case 4
        s = " " & ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585) & ChrW(1589) & ChrW(1583) & " "
        Case 5
        s = " " & ChrW(1662) & ChrW(1575) & ChrW(1606) & ChrW(1589) & ChrW(1583) & " "
        Case 6
        s = " " & ChrW(1588) & ChrW(1588) & ChrW(1589) & ChrW(1583) & " "
        Case 7
        s = " " & ChrW(1607) & ChrW(1601) & ChrW(1578) & ChrW(1589) & ChrW(1583) & " "
        Case 8
        s = " " & ChrW(1607) & ChrW(1588) & ChrW(1578) & ChrW(1589) & ChrW(1583) & " "
        Case 9
        s = " " & ChrW(1606) & ChrW(1607) & ChrW(1589) & ChrW(1583) & " "
    End Select
    Select Case h(2)
        Case 1
        Select Case h(3)
            Case 0
            s = s & ChrW(1608) & " " & ChrW(1583) & ChrW(1607) & "  "
            Case 1
            s = s & ChrW(1608) & " " & ChrW(1610) & ChrW(1575) & ChrW(1586) & ChrW(1583) & ChrW(1607) & " "
            Case 2
            s = s & ChrW(1608) & " " & ChrW(1583) & ChrW(1608) & ChrW(1575) & ChrW(1586) & ChrW(1583) & ChrW(1607) & " "
            Case 3
            s = s & ChrW(1608) & " " & ChrW(1587) & ChrW(1610) & ChrW(1586) & ChrW(1583) & ChrW(1607) & " "
            Case 4
            s = s & ChrW(1608) & " " & ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585) & ChrW(1583) & ChrW(1607) & " "
            Case 5
            s = s & ChrW(1608) & " " & ChrW(1662) & ChrW(1575) & ChrW(1606) & ChrW(1586) & ChrW(1583) & ChrW(1607) & " "
            Case 6
            s = s & ChrW(1608) & " " & ChrW(1588) & ChrW(1575) & ChrW(1606) & ChrW(1586) & ChrW(1583) & ChrW(1607) & " "
            Case 7
            s = s & ChrW(1608) & " " & ChrW(1607) & ChrW(1601) & ChrW(1583) & ChrW(1607) & " "
            Case 8
            s = s & ChrW(1608) & " " & ChrW(1607) & ChrW(1580) & ChrW(1583) & ChrW(1607) & " "
            Case 9
            s = s & ChrW(1608) & " " & ChrW(1606) & ChrW(1608) & ChrW(1586) & ChrW(1583) & ChrW(1607) & " "
        End Select
    Case 2
        s = s & ChrW(1608) & " " & ChrW(1576) & ChrW(1610) & ChrW(1587) & ChrW(1578) & " "
        Case 3
        s = s & ChrW(1608) & " " & ChrW(1587) & ChrW(1610) & " "
        Case 4
        s = s & ChrW(1608) & " " & ChrW(1670) & ChrW(1607) & ChrW(1604) & " "
        Case 5
        s = s & ChrW(1608) & " " & ChrW(1662) & ChrW(1606) & ChrW(1580) & ChrW(1575) & ChrW(1607) & " "
        Case 6
        s = s & ChrW(1608) & " " & ChrW(1588) & ChrW(1589) & ChrW(1578) & " "
        Case 7
        s = s & ChrW(1608) & " " & ChrW(1607) & ChrW(1601) & ChrW(1578) & ChrW(1575) & ChrW(1583) & " "
        Case 8
        s = s & ChrW(1608) & " " & ChrW(1607) & ChrW(1588) & ChrW(1578) & ChrW(1575) & ChrW(1583) & " "
        Case 9
        s = s & ChrW(1608) & " " & ChrW(1606) & ChrW(1608) & ChrW(1583) & " "
    End Select
    If h(2) <> 1 Then
        Select Case h(3)
            Case 1
            s = s & ChrW(1608) & " " & ChrW(1610) & ChrW(1603)
            Case 2
            s = s & ChrW(1608) & " " & ChrW(1583) & ChrW(1608)
            Case 3
            s = s & ChrW(1608) & " " & ChrW(1587) & ChrW(1607)
            Case 4
            s = s & ChrW(1608) & " " & ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585)
            Case 5
            s = s & ChrW(1608) & " " & ChrW(1662) & ChrW(1606) & ChrW(1580)
            Case 6
            s = s & ChrW(1608) & " " & ChrW(1588) & ChrW(1588)
            Case 7
            s = s & ChrW(1608) & " " & ChrW(1607) & ChrW(1601) & ChrW(1578)
            Case 8
            s = s & ChrW(1608) & " " & ChrW(1607) & ChrW(1588) & ChrW(1578)
            Case 9
            s = s & ChrW(1608) & " " & ChrW(1606) & ChrW(1607)
        End Select
    End If
    s = IIf(L < 3, Right(s, Len(s) - 1), s)
    Three = s
End Function
Function CAL_DATE(your_yare As Double, your_Month As Double, your_day As Double, target_date As String)
    Dim date_convert As Double
    date_convert = your_yare * 365 + your_Month * 30 + your_day
    Dim pdate As String
    Dim mydate As Date
    mydate = Miladi(target_date)
    mydate = DateAdd("d", date_convert, mydate)
    pdate = Shamsi(mydate)
    CAL_DATE = pdate
End Function
Function CAL_Time(your_Hours As Double, your_Minutes As Double, target_time As String)
    Dim time_convert As Double
    time_convert = your_Hours * 60 + your_Minutes
    Dim mytime
    mytime = target_time
    Dim var_tim
    MsgBox InStr(target_time, ":")
    var_tim = Hour(mytime) * 60 + Minute(mytime) + time_convert
    CAL_Time = Int(var_tim / 60) & ":" & var_tim Mod 60
End Function
Function Clipboard(ByVal inText As String)
  Dim objClipboard As Object
  Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  objClipboard.SetText inText
  objClipboard.PutInClipboard
  Set objClipboard = Nothing
End Function
Function GetClipboard() As String
  Dim objClipboard As Object
  Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  objClipboard.GetFromClipboard
  GetTextFromClipboard = objClipboard.GetText
  Set objClipboard = Nothing
End Function
Sub Number_Char()
On Error GoTo ER
    txt = Selection.text
    txt = horofi(txt)
    Clipboard (txt)
    MsgBox ChrW(1593) & ChrW(1583) & ChrW(1583) & " " & ChrW(1576) & ChrW(1581) & ChrW(1585) & ChrW(1608) & ChrW(1601) & " " & ChrW(1578) & ChrW(1576) & ChrW(1583) & ChrW(1740) & ChrW(1604) & " " & ChrW(1608) & " " & ChrW(1583) & ChrW(1585) & " " & ChrW(1581) & ChrW(1575) & ChrW(1601) & ChrW(1592) & ChrW(1607) & " " & ChrW(1584) & ChrW(1582) & ChrW(1740) & ChrW(1585) & ChrW(1607) & " " & ChrW(1711) & ChrW(1585) & ChrW(1583) & ChrW(1740) & ChrW(1583) & ChrW(1607) & " " & ChrW(1575) & ChrW(1587) & ChrW(1578) & " . " & ChrW(1583) & ChrW(1585) & " " & ChrW(1605) & ChrW(1581) & ChrW(1604) & " " & ChrW(1605) & ChrW(1608) & ChrW(1585) & ChrW(1583) & " " & ChrW(1606) & ChrW(1592) & ChrW(1585) & " " & ChrW(1575) & ChrW(1604) & ChrW(1589) & ChrW(1575) & ChrW(1602) & " " & ChrW(1606) & ChrW(1605) & ChrW(1575) & ChrW(1740) & ChrW(1740) & ChrW(1583)
    Exit Sub
ER:
    MsgBox ChrW(1601) & ChrW(1585) & ChrW(1605) & ChrW(1578) & " " & ChrW(1606) & ChrW(1575) & "" & ChrW(1605) & ChrW(1593) & ChrW(1578) & ChrW(1576) & ChrW(1585) & ChrW(1575) & ChrW(1587) & ChrW(1578)
End Sub
Sub Number_format()
On Error GoTo ER
    txt = Selection.text
    txt = Format(txt, "#,##")
    Selection.TypeText text:=txt
    Exit Sub
ER:
    MsgBox ChrW(1601) & ChrW(1585) & ChrW(1605) & ChrW(1578) & " " & ChrW(1606) & ChrW(1575) & "" & ChrW(1605) & ChrW(1593) & ChrW(1578) & ChrW(1576) & ChrW(1585) & ChrW(1575) & ChrW(1587) & ChrW(1578)
End Sub
Sub InsertPersianDate()
    Dim rng As Range
    Set rng = Selection.Range ' Use the current selection as the insertion point
    rng.Collapse wdCollapseStart ' Collapse the range to the start of the selection

    ' Get the current date in Persian (Shamsi) format
    Dim persianDate As String
    persianDate = GetPersianDate(Date) ' Convert and format the current date to Persian (Shamsi) format

    ' Insert the Persian date at the insertion point
    rng.InsertAfter persianDate
    Debug.Print Len(persianDate)
    rng.MoveStart wdCharacter, -1
'    rng.MoveEnd wdCharacter, 1
    Debug.Print rng.MoveStart
    Debug.Print rng.MoveEnd
    rng.Select
End Sub
Sub DATE_Convertor()
    On Error GoTo ER
    txt = Selection.text
    txt = Format(Shamsi(txt), "dd/MM/YYYY")
    Selection.TypeText text:=txt
    Exit Sub
ER:
    MsgBox ChrW(1601) & ChrW(1585) & ChrW(1605) & ChrW(1578) & " " & ChrW(1606) & ChrW(1575) & "" & ChrW(1605) & ChrW(1593) & ChrW(1578) & ChrW(1576) & ChrW(1585) & ChrW(1575) & ChrW(1587) & ChrW(1578)
End Sub
Function GetPersianDate(gregorianDate As Date) As String
    Dim persianYear As String
    Dim persianMonth As String
    Dim persianDay As String

    ' Convert the Gregorian date to Persian (Shamsi) date
    persianYear = Format(gregorianDate, "yyyy")
    persianMonth = Format(gregorianDate, "mm")
    persianDay = Format(gregorianDate, "dd")

    ' Combine the Persian date components into a single string
    GetPersianDate = persianYear & "/" & persianMonth & "/" & persianDay
End Function
Sub InsertAndConvertDate()
    Dim rng As Range
    Set rng = Selection.Range ' Use the current selection as the insertion point
    rng.Collapse wdCollapseStart ' Collapse the range to the start of the selection
    ' Get the current date in Persian (Shamsi) format
    Dim persianDate As String
    persianDate = GetPersianDate(Date) ' Convert and format the current date to Persian (Shamsi) format
    ' Insert the Persian date at the insertion point
    rng.InsertAfter persianDate
    rng.Select
On Error GoTo ER
    txt = Selection.text
    txt = Format(Shamsi(txt), "dd/MM/YYYY")
    Selection.TypeText text:=txt
    Exit Sub
ER:
    MsgBox ChrW(1601) & ChrW(1585) & ChrW(1605) & ChrW(1578) & " " & ChrW(1606) & ChrW(1575) & "" & ChrW(1605) & ChrW(1593) & ChrW(1578) & ChrW(1576) & ChrW(1585) & ChrW(1575) & ChrW(1587) & ChrW(1578)
End Sub

Please read above VBA code and then write following:
A very short VBA function for Persian Date insertion in document. 
And secondly a sub prodecure to Insert current date (Persian Calender) in current insertion in Document