thank you TMS! Attached is the sample workbook!
Maybe this solution will work?
Please correct if my idea is wrong!![]()
if Year(date1) <=1900 then 'its a hijri date else 'its a gregorian date end if
Thank you!
thank you TMS! Attached is the sample workbook!
Maybe this solution will work?
Please correct if my idea is wrong!![]()
if Year(date1) <=1900 then 'its a hijri date else 'its a gregorian date end if
Thank you!
I found the following code in an Access Forum and it works, unchanged, in Excel 2007.
![]()
' http://www.access-programmers.co.uk/forums/showthread.php?t=246559 ' hafeezksa ' Hijri (Arabic) date to Gregorian date converter module ... '------------------------------------------ Option Compare Binary Option Explicit ' Constants from olenls.h Private Const LOCALE_ICALENDARTYPE = &H1009 ' /* type of calendar specifier */ Private Const CAL_HIJRI = 6 ' /* Hijri (Arabic Lunar) calendar */ Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal lcid As Long, ByVal LCTYPE As Long, lpData As Any, ByVal cchData As Integer) As Integer Private Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long Private m_iHijri As Integer '------------------------------------------------------------ ' StDteGregOfStDteHijri '------------------------------------------------------------ Public Function StDteGregOfStDteHijri(ByVal stDateHijri As String) As String On Error Resume Next Dim dte As Date If Len(stDateHijri) > 0 Then VBA.Calendar = vbCalHijri dte = CDate(stDateHijri) VBA.Calendar = vbCalGreg StDteGregOfStDteHijri = CStr(dte) End If If Err.Number <> 0 Then StDteGregOfStDteHijri = stDateHijri End Function '------------------------------------------------------------ ' StDteHijriOfStDteGreg '------------------------------------------------------------ Public Function StDteHijriOfStDteGreg(ByVal stDateGreg As String) As String On Error Resume Next Dim dte As Date If Len(stDateGreg) > 0 Then dte = CDate(stDateGreg) VBA.Calendar = vbCalHijri StDteHijriOfStDteGreg = CStr(dte) VBA.Calendar = vbCalGreg End If If Err.Number <> 0 Then StDteHijriOfStDteGreg = stDateGreg End Function '----------------------------------------------------- ' FHijriCalendar '----------------------------------------------------- Public Property Get FHijriCalendar() As Boolean Dim stCal As String If m_iHijri = 0 Then stCal = StGetLocaleInfo(LOCALE_ICALENDARTYPE, False) If (Val(stCal) = CAL_HIJRI) Then m_iHijri = 1 Else m_iHijri = 2 End If End If FHijriCalendar = (m_iHijri = 1) End Property '---------------------------------------------------------------------- ' StGetLocaleInfo ' ' Gets Locale (international) info about current config ' See LOCALE constants at top of module for LCTYPE values '---------------------------------------------------------------------- Public Function StGetLocaleInfo(LCTYPE As Long, Optional fUserDefault As Boolean = True) As String Dim lcid As Long Dim stBuff As String * 255 'Get current language ID If fUserDefault Then lcid = GetUserDefaultLCID() Else lcid = GetSystemDefaultLCID() End If 'ask for the locale info If (GetLocaleInfo(lcid, LCTYPE, ByVal stBuff, Len(stBuff)) > 0) Then StGetLocaleInfo = StFromSz(stBuff) End If End Function '------------------------------------------------------------ ' StFromSz ' ' Find the first vbNullChar in a string, and return ' everything prior to that character. Extremely ' useful when combined with the Windows API function calls. '------------------------------------------------------------ Public Function StFromSz(ByVal sz As String) As String Dim ich As Integer ich = InStr(sz, vbNullChar) Select Case ich ' It's best to put the most likely case first. Case Is > 1 ' Found in the string, so return the portion ' up to the null character. StFromSz = Left$(sz, ich - 1) Case 0 ' Not found at all, so just ' return the original value. StFromSz = sz Case 1 ' Found at the first position, so return an empty string. StFromSz = vbNullString End Select End Function
Assuming that the calculation is accurate (which I can't really check), this should meet your needs.
See the attached updated sample workbook.
Regards, TMS
Trevor Shuttleworth - Retired Excel/VBA Consultant
I dream of a better world where chickens can cross the road without having their motives questioned
'Being unapologetic means never having to say you're sorry' John Cooper Clarke
There are currently 1 users browsing this thread. (0 members and 1 guests)
Bookmarks