Attribute VB_Name = "basHijri"
'------------------------------------------
'   (c) 1999 Trigeminal Software, Inc.  All Rights Reserved
'------------------------------------------
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