دالتان 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

 

تم تعديل سبتمبر 17, 2022 بواسطه AbuuAhmed
تنقيح الكود

[Ali Mohamed Ali]

أحسنت أستاذنا الكريم وبارك الله فيك .. طبعاً موضوع مهم وقيم , جعله الله فى ميزان حسناتك

[ميدو63]

السادة الكرام

اسف لم افهم ماذا على ان اعمل لو اردت ان استخدم الكود من العبارة التالية ...

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

 

لو ممكن الشرح او ايداع اكسيل اكن شاكر لكم...

[AbuuAhmed]

مثال لاستخدام الدالتين ، وقد تم فصل أمر الفتح والإغلاق في هذين الحدثين

Private Sub Workbook_Open()
    Call OpenxlApp
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call ClosexlApp
End Sub

UmAlqura4Excel_01.xlsm

[ميدو63]

اشكرك وبارك الله فيك

[antoninomubarik]

بارك الله فيك