دالتان vba للتحويل بين تقويمي أم القرى والميلادي باستخدام الإكسل

[AbuuAhmed]

كما العنوان ومدى الدالتين:
أم القـرى : بين 1317/08/29 و 1450/12/29
الميلادي : بين 1900/01/01 و 2029/05/13

طبعا لمن سيستخدمهما عليه أن يفصل أوامر فتح الإكسل وإغلاقه عن الدوال ووضعهم مع الفتح والخروج من مشروع الأكسس ، لتجنب البطء مع كل نداء للدالتين.
 

Option Explicit

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet

Sub OpenxlApp()
  Set xlApp = CreateObject("Excel.Application")
  Set xlBook = xlApp.Workbooks.Add
  Set xlSheet = xlBook.Worksheets(1)
End Sub

Sub ClosexlApp()
  xlBook.Close SaveChanges:=False
  xlApp.Quit
End Sub

'AbuuAhmed
Function sysUmTest(ByVal UmAlqura As String) As String
  Dim Dash1 As Byte, Dash2 As Byte, Dash3 As Byte
  Dim Part1 As String, Part2 As String
  Dim Part3 As String, Part4 As String
  
  On Error Resume Next
    
  Part4 = Replace(UmAlqura, "/", "-")
  If Not IsNumeric(Replace(Part4, "-", "", 1)) Then Exit Function
  Dash1 = InStr(1, Part4, "-"):         If Dash1 = 0 Then Exit Function
  Dash2 = InStr(Dash1 + 1, Part4, "-"): If Dash2 = 0 Then Exit Function
  Dash3 = InStr(Dash2 + 1, Part4, "-"): If Dash3 > 0 Then Exit Function
      
  Part1 = Left(Part4, Dash1 - 1)
  Part2 = Mid(Part4, Dash1 + 1, Dash2 - Dash1 - 1)
  Part3 = Mid(Part4, Dash2 + 1)
  If Len(Part1) < 4 And Len(Part3) < 4 Then Exit Function
      
  If Len(Part1) = 1 Then Part1 = Format(Part1, "00")
  If Len(Part2) = 1 Then Part2 = Format(Part2, "00")
  If Len(Part3) = 1 Then Part3 = Format(Part3, "00")
        
  If Len(Part1) = 2 Then
    Part4 = Part1
    Part1 = Part3
    Part3 = Part4
  End If
      
  If Not (Val(Part1) >= 1300 And Val(Part1) <= 1600) Then Exit Function
  If Not (Val(Part2) >= 1 And Val(Part2) <= 12) Then Exit Function
  If Not (Val(Part3) >= 1 And Val(Part3) <= 30) Then Exit Function

  sysUmTest = Part1 & "-" & Part2 & "-" & Part3
End Function

Function sysUm2Greg(ByVal UmAlqura As String) As Long
  Dim CurCal As VbCalendar
  Dim Greg As Long, Days As Long
  Dim Hdd As Byte
  
  On Error Resume Next
  
  UmAlqura = sysUmTest(UmAlqura)
  If UmAlqura = "" Or UmAlqura < "1317-08-29" Or UmAlqura > "1450-12-29" Then Exit Function
  
  Call OpenxlApp    'لتسريع الدالة يفضل نقل هذا السطر عند فتح الملف/البرنامج
  
  With xlSheet
    .Range("A1").NumberFormat = "m/d/yyyy"
    .Range("A2").NumberFormat = "0"
    
    .Range("A2").Formula = "=LEFT(TEXT(A1,""[$-1170000]B2dd/mm/yyyy;@""),2)"
    
    Hdd = Right(UmAlqura, 2)
  
    CurCal = Calendar
    Calendar = vbCalHijri
    Greg = DateSerial(Left(UmAlqura, 4), Mid(UmAlqura, 6, 2), Hdd)
    Calendar = CurCal
    
    .Range("A1") = Greg
    If Hdd = .Range("A2") Then
      sysUm2Greg = Greg
    Else
      For Days = Greg + 2 To Greg - 2 Step -1
        .Range("A1") = Days
        If Hdd = .Range("A2") Then Exit For
      Next Days
      sysUm2Greg = IIf(Abs(Days - Greg) > 2, Greg, Days)
    End If
  End With
  
  Call ClosexlApp   'لتسريع الدالة يفضل نقل هذا السطر عند اغلاق الملف/البرنامج
End Function

Function sysGreg2Um(ByVal Greg As Long) As String
  On Error Resume Next
  
  If Greg < DateSerial(1900, 1, 1) Then Exit Function
  If Greg > DateSerial(2029, 5, 13) Then Exit Function
  
  Call OpenxlApp    'لتسريع الدالة يفضل نقل هذا السطر عند فتح الملف/البرنامج
  
  With xlSheet
    .Range("A1").NumberFormat = "m/d/yyyy"
    .Range("A2").NumberFormat = "0"
    
    .Range("A1") = Greg
    .Range("A2").Formula = "=TEXT(A1,""[$-1170000]B2dd/mm/yyyy;@"")"
    
    sysGreg2Um = .Range("A2")
  End With
  
  Call ClosexlApp   'لتسريع الدالة يفضل نقل هذا السطر عند اغلاق الملف/البرنامج
End Function

Sub sysUmTesting()
  Dim UmAlqura As String
  
  UmAlqura = "30-6-1446"
  Debug.Print CDate(sysUm2Greg(UmAlqura))
  Debug.Print sysGreg2Um(sysUm2Greg(UmAlqura))
  Debug.Print
  
  UmAlqura = "1-7-1446"
  Debug.Print CDate(sysUm2Greg(UmAlqura))
  Debug.Print sysGreg2Um(sysUm2Greg(UmAlqura))
End Sub

 

[Ali Mohamed Ali]

جزاك الله خسر الثواب وأكرمك الله وأحسن الله اليك

[abouelhassan]

شكر وتقدير واحترام من اخيك 

[AbuuAhmed]

مثال للدوال 

systemUmAlQura.mdb

[AbuuAhmed]

نسخة منقحة بعد اكتشاف اخفاق بسيط في دالة التحويل من أم القرى إلى الميلادي.
وتم الاستغناء عن مرجع الإكسل.
وتمت تقيحات أخرى بسيطة.

من يستطيع تطوير المثال بتسريعه، فليتفضل مشكورا.

systemUmAlQura_02.mdb