الحصول على التاريخ الهجري للويندوز

السامر · يناير 20, 2005

مساء الخير وكل عام وانتم بخير

الموضوع باختصار عندي حقل يتم ادراج التاريخ الهجري الحالي به تلقائيا ولكن عند ما يكون التاريخ مختلف عن تاريخ الجهاز وأقوم بظبطه عن طريق إعدادات لوحة التحكم من الخيارات الإقليمية بحيث ازوده يوم او انقصه يوم ولكن المشكله أن التاريخ في النوذج لايتغير . فتكفون ماهي الطريقه لحل هذه المشكله ولكم خالص تحياتي،،،،،،،

**أبو هادي** · يناير 20, 2005

السلام عليكم

إبحث عن "أم القرى" وسترى الكثير من الحلول والأفكار .. وعلى مهلك .

تحياتي .

السامر · يناير 20, 2005

تسلم يابو هادي على الرد السريع ولكن شوي باغلبك معي .

مافيه طريقه بحيث ان التاريخ يتعرف على تاريخ الويندوز بعد ماغيرته من لوحة الاعداد ومن غير اني اضيف للنموذج تقويم خارجي كام القرى مثلاً.

تسلم لي

**أبو هادي** · يناير 20, 2005

السلام عليكم

سأبحث في الموضوع إن شاء الله تعالى .

وهذه معلومات لمن يعانون نفس المشكلة :

Advanced settings for Hijri date in Windows XP and Window 2003

SYMPTOMS
The new Hijri calendar table which is implemented in "Um Al Cora" Hijri calendar, is not available in Windows or Office, but the user can use the Advanced Hijri date setting to adjust the Hijri date.

MORE INFORMATION
Hijri calendar is available only when System Locale and User Locale are set to Arabic.

RESOLUTION
Adjust Hijri date in Windows XP and Windows 2003:
1. From "Control Panel' , select 'Regional and Language Options'
2. In 'General' tab press on 'Customize' button
3. In the Date tab, ensure that Hijri date is selected (you can select Hijri calendar from 'Calendar type' drop down list)
4. From 'Adjust Hijri date to' you can adjust the Hijri date by adding or removing one or 2 days from the current Hijri date

How to set the language for the system and user local:
1. Log as Administrator to your computer
2. From Start open 'Control Panel'
3. From the left task pane press on the 'Switch to Classic view' to find the 'Regional and language options' icon , then double click on this icon.
4. From the 'Languages' tab, make sure you check on the 'Install files for complex script and right-to-left languages (including Thai)', then press 'Apply' button to make the language appear on the other list boxes.
5. From the 'Regional options' tab, you can set the User Local settings, by choosing the correct choice for the following settinga. Select your Language/Country from 'Standards and formats' (e.g. Arabic (Saudi Arabia)).
b. From the Location list box, select your locale country (e.g. Saudi Arabia)

6. From the 'Advanced' tab, select the 'Language for non-Unicode programs' which will be default for your operating system. For example if you choose Arabic, so this setting will force ANSI application to display Arabic text correctly.
7. Make sure to check the "Default user account settings" check box and press 'OK' button then reboot your computer.

APPLIES TO
• Microsoft Windows XP Professional Edition
• Microsoft Windows XP Home Edition
• Microsoft Windows Server 2003, Standard Edition
• Microsoft Windows Server 2003, Enterprise Edition
• Microsoft Windows Server 2003, Web Edition

تحياتي .

تم تعديل يناير 20, 2005 بواسطه أبو هادي

**الدكتور خضر الرجبي** · يناير 20, 2005

السلام عليكم

أخي السامر، أود المساعدة (قدر استطاعتي) في هذه المسألة بعد إذنك وإذن الاخ أبا هادي طبعا.

1. ذكرت في الشرح أنك تقوم بتعديل التقويم الهجري يدويا في Windows وهذا جزء من المسألة، أود أن ارشدك إلى برنامج تقويم هجري رائع يعدل نفسه تلقائيا وله خصائص كثيرة لطيفة من أهمها أنه يعمل حسب حالات القمر وليس حسب خوارزميات رياضية وهذا البرنامج موجود في الموقع التالي يمكنك تحميله من هناك

http://ultimaterepository.com/business/calendar/10506.aspx

2. بشأن السؤال الاخر المتعلق بتعديل التاريخ بنموذج ليتوافق مع تاريخ الجهاز فإنه محفز وسأفكر به.

مع الاحترام

**الدكتور خضر الرجبي** · يناير 21, 2005

السلام عليكم

الاخوة الاعضاء الكرام، بعد بحثي في المشكلة المطروحة أود أن ابين ما توصلت له من معلومات متعلقة بهذه المسألة حتى الان:

1. عند (تعديل) زيادة أو انقاص التاريخ الهجري من التعريفات الاقليمية فإنه كما ذكر الاخ المستفسر في سؤاله لا يتغير حقل مربع النص المعرف على التاريخ الهجري ولكن هناك قيمة في تسجيلات ويندوز (Windows Registry) تتغير وهي في (HKey_current_user\Control Panel\International)

والخاصية هي AddHijriDate وتتغير قيمتها بالشكل التالي

إذا قمنا بتنقيص يومين تصبح قيمة الخاصية AddHijriDate-2

إذا قمنا بتنقيص يوم تصبح قيمة الخاصية AddHijriDate

إذا لم ننقص أو نزيد تصبح قيمة الخاصية (فراغ)

إذا قمنا بزيادة يوم تصبح قيمة الخاصية AddHijriDate+1

إذا قمنا بزيادة يومين تصبح قيمة الخاصية AddHijriDate+2

2. طبعا هذا مفتاح لحل المشكلة حيث يمكن وضع كود في حدث ما للنموذج الذي به التاريخ الهجري بحيث يقرأ قيمة AddHijriDate من Windows Registry وبناء Select Case بناء على القيمة كما بينت أعلاه لزيادة أو إنقاص التاريخ الهجري تلقائيا في النموذج.

3. ما تبقى لتطبيق الحل المقترح هو معرفة كيفية قراءة القيمة المطلوبة من Windows Registry فأرجو المساعدة.

مع الاحترام

**أبو هادي** · يناير 21, 2005

السلام عليكم

3. ما تبقى لتطبيق الحل المقترح هو معرفة كيفية قراءة القيمة المطلوبة من Windows فأرجو المساعدة

ما تبقى هو كل الموضوع أخي خضر الرجبي .. وهو ما أتعبني يوم أمس بعد عمل كثير من الإجراءات ولم أستطع الوصول لمكان التخزين . يالله همتك معنا الآن في كيفية قراءتها .

تحياتي .

**الدكتور خضر الرجبي** · يناير 21, 2005

السلام عليكم

صدقت، أخي أبا هادي إن ما تبقى هو كل الموضوع بلا شك، أنا أيضا تعبت وأن أبحث عن حل لهذه المسألة ولكني توصلت إلى بوادره واتمنى أن يساعدنا أحد الاعضاء في اكمال الحل من حيث وصلنا.

لقد حصلت على كل التعريفات المتعلقة بتعريفات تسجيلات ويندوز من حذف واضافة وتعديل واستعراض ولكني أجد صعوبة في استخدامها.

الاقترانات والتعريفات التالية يجب وضعها في وحدة نمطية كي يتم طلبها من تعريف الاجراء لحدث معين في النموذج وهي :

Enum RegHive
    HKEY_CLASSES_ROOT = &H80000000
    HK_CR = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HK_CU = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HK_LM = &H80000002
    HKEY_USERS = &H80000003
    HK_US = &H80000003
    HKEY_CURRENT_CONFIG = &H80000005
    HK_CC = &H80000005
    HKEY_DYN_DATA = &H80000006
    HK_DD = &H80000006
End Enum

Enum RegType
    REG_SZ = 1 'Unicode nul terminated string
    REG_BINARY = 3 'Free form binary
    REG_DWORD = 4 '32-bit number
End Enum

Public Const ERROR_SUCCESS = 0&
Public Declare Function RegCloseKey Lib "advapi32.dll" _
    (ByVal hKey As Long) As Long
Public Declare Function RegCreateKey Lib "advapi32.dll" _
    Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, _
    phkResult As Long) As Long
Public Declare Function RegDeleteKey Lib "advapi32.dll" _
    Alias "RegDeleteKeyA" (ByVal hKey As Long, _
    ByVal lpSubKey As String) As Long
Public Declare Function RegDeleteValue Lib "advapi32.dll" _
    Alias "RegDeleteValueA" (ByVal hKey As Long, _
    ByVal lpValueName As String) As Long
Public Declare Function RegOpenKey Lib "advapi32.dll" _
    Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, _
    phkResult As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" _
    Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
    ByVal lpReserved As Long, lpType As Long, lpData As Any, _
    lpcbData As Long) As Long
Public Declare Function RegSetValueEx Lib "advapi32.dll" _
    Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
    ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, _
    ByVal cbData As Long) As Long
Public Declare Function RegEnumKey Lib "advapi32.dll" _
    Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, _
    ByVal lpName As String, ByVal cbName As Long) As Long

Public Function DelRegValue(ByVal hKey As RegHive, ByVal strPath As String, _
    ByVal strValue As String)
Dim hCurKey As Long
Dim lRegResult As Long
    lRegResult = RegOpenKey(hKey, strPath, hCurKey)
    lRegResult = RegDeleteValue(hCurKey, strValue)
    lRegResult = RegCloseKey(hCurKey)
End Function

Public Function DelRegKey(ByVal hKey As RegHive, ByVal strPath As String) As Long
Dim lRegResult As Long
    lRegResult = RegDeleteKey(hKey, strPath)
    DelRegKey = lRegResult
End Function

Public Function CreateRegKey(hKey As RegHive, strPath As String)
Dim hCurKey As Long
Dim lRegResult As Long
    lRegResult = RegCreateKey(hKey, strPath, hCurKey)
        If lRegResult <> ERROR_SUCCESS Then
            'there is a problem
        End If
    lRegResult = RegCloseKey(hCurKey)
End Function
Public Function GetRegString(hKey As RegHive, strPath As String, _
    strValue As String, Optional Default As String) As String
Dim hCurKey As Long
Dim lResult As Long
Dim lValueType As Long
Dim strBuffer As String
Dim lDataBufferSize As Long
Dim intZeroPos As Integer
Dim lRegResult As Long
    'Set up default value
    If Not IsEmpty(Default) Then
        GetRegString = Default
    Else
        GetRegString = ""
    End If
    lRegResult = RegOpenKey(hKey, strPath, hCurKey)
    lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, lValueType, _
                 ByVal 0&, lDataBufferSize)
    If lRegResult = ERROR_SUCCESS Then
        If lValueType = REG_SZ Then
            strBuffer = String(lDataBufferSize, " ")
            lResult = RegQueryValueEx(hCurKey, strValue, 0&, 0&, _
                      ByVal strBuffer, lDataBufferSize)
            intZeroPos = InStr(strBuffer, Chr$(0))
                If intZeroPos > 0 Then
                    GetRegString = Left$(strBuffer, intZeroPos - 1)
                Else
                    GetRegString = strBuffer
                End If
        End If
    Else
        'there is a problem
    End If
    lRegResult = RegCloseKey(hCurKey)
End Function

Public Function SaveRegString(hKey As RegHive, strPath As String, _
    strValue As String, strData As String)
Dim hCurKey As Long
Dim lRegResult As Long
    lRegResult = RegCreateKey(hKey, strPath, hCurKey)
    lRegResult = RegSetValueEx(hCurKey, strValue, 0, REG_SZ, _
                ByVal strData, Len(strData))
    If lRegResult <> ERROR_SUCCESS Then
        'there is a problem
    End If
    lRegResult = RegCloseKey(hCurKey)
End Function

Public Function GetRegLong(ByVal hKey As RegHive, ByVal strPath As String, _
    ByVal strValue As String, Optional Default As Long) As Long
Dim lRegResult As Long
Dim lValueType As Long
Dim lBuffer As Long
Dim lDataBufferSize As Long
Dim hCurKey As Long
    'Set up default value
    If Not IsEmpty(Default) Then
        GetRegLong = Default
    Else
        GetRegLong = 0
    End If
    lRegResult = RegOpenKey(hKey, strPath, hCurKey)
    lDataBufferSize = 4 '4 bytes = 32 bits = long
    lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, lValueType, lBuffer, _
                 lDataBufferSize)
    If lRegResult = ERROR_SUCCESS Then
        If lValueType = REG_DWORD Then
            GetRegLong = lBuffer
        End If
    Else
        'there is a problem
    End If
    lRegResult = RegCloseKey(hCurKey)
End Function

Public Function SaveRegLong(ByVal hKey As RegHive, ByVal strPath As String, _
    ByVal strValue As String, ByVal lData As Long)
Dim hCurKey As Long
Dim lRegResult As Long
    lRegResult = RegCreateKey(hKey, strPath, hCurKey)
    lRegResult = RegSetValueEx(hCurKey, strValue, 0&, REG_DWORD, lData, 4)
    If lRegResult <> ERROR_SUCCESS Then
        'there is a problem
    End If
    lRegResult = RegCloseKey(hCurKey)
End Function

Public Function GetRegByte(ByVal hKey As RegHive, ByVal strPath As String, _
    ByVal strValueName As String, Optional Default As Variant) As Variant
Dim lValueType As Long
Dim byBuffer() As Byte
Dim lDataBufferSize As Long
Dim lRegResult As Long
Dim hCurKey As Long
    If Not IsEmpty(Default) Then
        If VarType(Default) = vbArray + vbByte Then
            GetRegByte = Default
        Else
            GetRegByte = 0
        End If
    Else
        GetRegByte = 0
    End If
    lRegResult = RegOpenKey(hKey, strPath, hCurKey)
    lRegResult = RegQueryValueEx(hCurKey, strValueName, 0&, lValueType, _
                 ByVal 0&, lDataBufferSize)
    If lRegResult = ERROR_SUCCESS Then
        If lValueType = REG_BINARY Then
            ReDim byBuffer(lDataBufferSize - 1) As Byte
            lRegResult = RegQueryValueEx(hCurKey, strValueName, 0&, lValueType, _
                         byBuffer(0), lDataBufferSize)
            GetRegByte = byBuffer
        End If
    Else
        'there is a problem
    End If
    lRegResult = RegCloseKey(hCurKey)
End Function

Public Function SaveRegByte(ByVal hKey As RegHive, ByVal strPath As String, _
    ByVal strValueName As String, byData() As Byte)
Dim lRegResult As Long
Dim hCurKey As Long
    lRegResult = RegCreateKey(hKey, strPath, hCurKey)
    lRegResult = RegSetValueEx(hCurKey, strValueName, 0&, REG_BINARY, _
                 byData(0), UBound(byData()) + 1)
    lRegResult = RegCloseKey(hCurKey)
End Function

Public Function CopyRegByte(ByVal From_hKey As RegHive, _
    ByVal From_strPath As String, ByVal From_strKeyName As String, _
    ByVal To_strPath As String, Optional ByVal To_hKey As RegHive, _
    Optional ByVal To_strKeyName As String)

    If To_hKey = 0 Then
        To_hKey = From_hKey
    Else
        To_hKey = To_hKey
    End If
    If To_strKeyName = "" Then
        To_strKeyName = From_strKeyName
    Else
        To_strKeyName = To_strKeyName
    End If

Dim mybytes As Variant
    mybytes = GetRegByte(From_hKey, From_strPath, From_strKeyName)
    thelen = UBound(mybytes)
    Dim x() As Byte
    ReDim x(thelen)
    For i = 0 To UBound(mybytes)
        x(i) = mybytes(i)
    Next i
    rslt = SaveRegByte(To_hKey, To_strPath, To_strKeyName, x)
End Function

Public Function CopyRegString(ByVal From_hKey As RegHive, _
    ByVal From_strPath As String, ByVal From_strKeyName As String, _
    ByVal To_strPath As String, Optional ByVal To_hKey As RegHive, _
    Optional ByVal To_strKeyName As String)

    If To_hKey = 0 Then
        To_hKey = From_hKey
    Else
        To_hKey = To_hKey
    End If
    If To_strKeyName = "" Then
        To_strKeyName = From_strKeyName
    Else
        To_strKeyName = To_strKeyName
    End If

    Dim mystring As String
    mystring = GetRegString(From_hKey, From_strPath, From_strKeyName)
    rslt = SaveRegString(To_hKey, To_strPath, To_strKeyName, mystring)

End Function

Public Function CopyRegLong(ByVal hKey As RegHive, ByVal From_strPath As String, _
    ByVal From_strKeyName As String, ByVal To_strPath As String, _
    Optional ByVal To_hKey As RegHive, Optional ByVal To_strKeyName As String)

    If To_hKey = 0 Then
        To_hKey = From_hKey
    Else
        To_hKey = To_hKey
    End If
    If To_strKeyName = "" Then
        To_strKeyName = From_strKeyName
    Else
        To_strKeyName = To_strKeyName
    End If

    Dim mylong As Long
    mylong = GetRegLong(From_hKey, From_strPath, From_strKeyName)
    rslt = SaveRegLong(To_hKey, To_strPath, To_strKeyName, mylong)

End Function
Public Function GetRegSubKeyList(ByVal hKey As RegHive, ByVal strPath As String)
'On Error Resume Next
Dim lResult As Long, lKeyValue As Long, lDataTypeValue As Long, lValueLength As Long
Dim sValue As String, td As Double, i As Long, Ret As Boolean, tmprst()
Do Until Ret = True
    lResult = RegOpenKey(hKey, strPath, lKeyValue)
    sValue = Space$(2048)
    lValueLength = Len(sValue)
    lResult = RegEnumKey(lKeyValue, i, sValue, lValueLength)
    If (lResult = 0) And (Err.Number = 0) Then
        ReDim Preserve tmprst(i)
        tmprst(i) = Left$(sValue, InStr(sValue, Chr(0)) - 1)
    Else
       Ret = True
    End If
    lResult = RegCloseKey(lKeyValue)
    i = i + 1
Loop
GetRegSubKeyList = tmprst
End Function

ملاحظات مهمة :

1. الكود اعلاه تم تجربته وهو يعمل بدون أخطاء.

2. يجب استدعاء احد الاقترانات لمعرفة القيمة من Registry واعتقد أنه الاقتران GetRegSubKeyList

3. يجب الحذر عند استخدام اقترانات التعديل والحذف لأن أي تغير في Registry ممكن أن يعطل بعض الامور في ويندوز والبرامج.

مع الاحترام

**الدكتور خضر الرجبي** · يناير 21, 2005

السلام عليكم

جميع الاخوة الاعضاء والاخ أبا هاديا وأخير توصلت إلى الكود والطريقة التي تمكننا من الوصول إلى قيم المفاتيح في windows registry وتكمن أهمية هذه العملية في حل الكثير من المسائل المتعلقة بتعريفات الويندز مثل هذا السؤال حول التاريخ الهجري وكيفية معرفته من windows registry والحل مؤلف من خطوتين:

1. وضع الكود التالي الذي كتباه (تيري كريفت و ديف أشيس) في وحدة نمطية وتخزينة بأي اسم.

'********Code Start**************
'This code was originally written by Terry Kreft
' and Dev Ashish.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Dev Ashish & Terry Kreft
'
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006

Private Const STANDARD_RIGHTS_READ = &H20000
Private Const KEY_QUERY_VALUE = &H1&
Private Const KEY_ENUMERATE_SUB_KEYS = &H8&
Private Const KEY_NOTIFY = &H10&
Private Const SYNCHRONIZE = &H100000
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or _
                        KEY_QUERY_VALUE Or _
                        KEY_ENUMERATE_SUB_KEYS Or _
                        KEY_NOTIFY) And _
                        (Not SYNCHRONIZE))
Private Const MAXLEN = 256
Private Const ERROR_SUCCESS = &H0&

Const REG_NONE = 0
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_DWORD_LITTLE_ENDIAN = 4
Const REG_DWORD_BIG_ENDIAN = 5
Const REG_LINK = 6
Const REG_MULTI_SZ = 7
Const REG_RESOURCE_LIST = 8

Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Declare Function apiRegOpenKeyEx Lib "advapi32.dll" _
        Alias "RegOpenKeyExA" (ByVal hKey As Long, _
        ByVal lpSubKey As String, ByVal ulOptions As Long, _
        ByVal samDesired As Long, ByRef phkResult As Long) _
        As Long

Private Declare Function apiRegCloseKey Lib "advapi32.dll" _
        Alias "RegCloseKey" (ByVal hKey As Long) As Long

Private Declare Function apiRegQueryValueEx Lib "advapi32.dll" _
        Alias "RegQueryValueExA" (ByVal hKey As Long, _
        ByVal lpValueName As String, ByVal lpReserved As Long, _
        ByRef lpType As Long, lpData As Any, _
        ByRef lpcbData As Long) As Long

Private Declare Function apiRegQueryInfoKey Lib "advapi32.dll" _
        Alias "RegQueryInfoKeyA" (ByVal hKey As Long, _
        ByVal lpClass As String, ByRef lpcbClass As Long, _
        ByVal lpReserved As Long, ByRef lpcSubKeys As Long, _
        ByRef lpcbMaxSubKeyLen As Long, _
        ByRef lpcbMaxClassLen As Long, _
        ByRef lpcValues As Long, _
        ByRef lpcbMaxValueNameLen As Long, _
        ByRef lpcbMaxValueLen As Long, _
        ByRef lpcbSecurityDescriptor As Long, _
        ByRef lpftLastWriteTime As FILETIME) As Long

Function fReturnRegKeyValue(ByVal lngKeyToGet As Long, _
                            ByVal strKeyName As String, _
                            ByVal strValueName As String) _
                            As String
Dim lnghKey As Long
Dim strClassName As String
Dim lngClassLen As Long
Dim lngReserved As Long
Dim lngSubKeys As Long
Dim lngMaxSubKeyLen As Long
Dim lngMaxClassLen As Long
Dim lngValues As Long
Dim lngMaxValueNameLen As Long
Dim lngMaxValueLen As Long
Dim lngSecurity As Long
Dim ftLastWrite As FILETIME
Dim lngType As Long
Dim lngData As Long
Dim lngTmp As Long
Dim strRet As String
Dim varRet As Variant
Dim lngRet As Long On Error GoTo fReturnRegKeyValue_Err

    'Open the key first
    lngTmp = apiRegOpenKeyEx(lngKeyToGet, _
                strKeyName, 0&, KEY_READ, lnghKey)

    'Are we ok?
    If Not (lngTmp = ERROR_SUCCESS) Then Err.Raise _
                                lngTmp + vbObjectError

    lngReserved = 0&
    strClassName = String$(MAXLEN, 0):  lngClassLen = MAXLEN

    'Get boundary values
    lngTmp = apiRegQueryInfoKey(lnghKey, strClassName, _
        lngClassLen, lngReserved, lngSubKeys, lngMaxSubKeyLen, _
        lngMaxClassLen, lngValues, lngMaxValueNameLen, _
        lngMaxValueLen, lngSecurity, ftLastWrite)

    'How we doin?
    If Not (lngTmp = ERROR_SUCCESS) Then Err.Raise _
                                lngTmp + vbObjectError

    'Now grab the value for the key
    strRet = String$(MAXLEN - 1, 0)
    lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _
                lngReserved, lngType, ByVal strRet, lngData)
    Select Case lngType
      Case REG_SZ
        lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _
                lngReserved, lngType, ByVal strRet, lngData)
        varRet = Left(strRet, lngData - 1)
      Case REG_DWORD
        lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _
                lngReserved, lngType, lngRet, lngData)
        varRet = lngRet
      Case REG_BINARY
        lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _
                lngReserved, lngType, ByVal strRet, lngData)
        varRet = Left(strRet, lngData)
    End Select

    'All quiet on the western front?
    If Not (lngTmp = ERROR_SUCCESS) Then Err.Raise _
                                lngTmp + vbObjectError

fReturnRegKeyValue_Exit:
    fReturnRegKeyValue = varRet
    lngTmp = apiRegCloseKey(lnghKey)
    Exit Function
fReturnRegKeyValue_Err:
    varRet = "Error: Key or Value Not Found."
    Resume fReturnRegKeyValue_Exit
End Function

'********Code End**************

2. يمكن معرفة قيمة التاريخ الهجري التي تم الشرح عنها سابقا في windows registry بالطريقة التالية :

MsgBox fReturnRegKeyValue(HKEY_CURRENT_USER, _
        "control Panel\International", "AddHijriDate")

مع الاحترام

**أبو هادي** · يناير 21, 2005

السلام عليكم

نعم أخي خضر الرجبي .. إنه الحل فعلا ، لك الشكر الجزيل .

Function WinHijriDate() As Date
  Dim AddDays As Integer
  
  Select Case fReturnRegKeyValue(HKEY_CURRENT_USER, "control Panel\International", "AddHijriDate")
    Case "AddHijriDate-2": AddDays = -2
    Case "AddHijriDate":   AddDays = -1
    Case "":               AddDays = 0
    Case "AddHijriDate+1": AddDays = 1
    Case "AddHijriDate+2": AddDays = 2
  End Select
  WinHijriDate = Date + AddDays
End Function

تحياتي .

تم تعديل يناير 21, 2005 بواسطه أبو هادي

**أبو هادي** · يناير 21, 2005

السلام عليكم

تم التعديل على الدالة بحيث لا يتم التعديل على التاريخ إلا للشهر الحالي حيث أن هذا التعديل على التاريخ لشهر واحد فقط .

Function WinHijriDate(HijriDate As Date) As Date
  Dim AddDays As Integer
  
  If Year(HijriDate) = Year(Date) And _
     Month(HijriDate) = Month(Date) Then
     Select Case fReturnRegKeyValue(HKEY_CURRENT_USER, _
                                    "control Panel\International", _
                                    "AddHijriDate")
       Case "AddHijriDate-2": AddDays = -2
       Case "AddHijriDate":   AddDays = -1
       Case "":               AddDays = 0
       Case "AddHijriDate+1": AddDays = 1
       Case "AddHijriDate+2": AddDays = 2
     End Select
  Else
    AddDays = 0
  End If
  
  WinHijriDate = HijriDate + AddDays
End Function

تحياتي .

**الدكتور خضر الرجبي** · يناير 21, 2005

السلام عليكم

أخي ابا هادي لقد سعدت جدا بتعقيباتك الرائعة وبعمل الاقتران الذي يساعد المستفسر في حل مشكلته، ولقد فرحت كثيرا عندما وجدت هذا الموضوع مثبتا (وفعلا هو يستحق التثبيت)، مع احترامي وتقدير الكبيرين لك ولملاحظاتك الرائعة التي تنم عن خبرتك الكبيرة في الموضوع.

ولك تحياتي واحترامي

**الدكتور خضر الرجبي** · يناير 22, 2005

السلام عليكم

لك وللإخوة الاعضاء ذلك يا أبا سليمان وسأقوم بذلك في الوقت القريب إن شاء الله (على الاكثر 3 أيام).

مع الاحترام

السامر · يناير 22, 2005

ماأقدر أقول إلا ماشــــــــــــــــاالله عليكم والله يزيدكم من العلم

ابو هادي ممكن طلب:
كيف الطريقه فين اضع الكود بحيث يتتم عمل النموذج بالشكل المطلوب

تحييييياتي لك وآسف

<{POST_SNAPBACK}>

وإذا ممكن يابوهادي او احد من الاخوان المتمكنين ارفاق ملف

<{POST_SNAPBACK}>

مساء الخير .
ممكن مثال يابو هادي على الكلام اللي قلته او تشرح لي كيف اسوي عشان اضيف الدوال حقت التاريخ في النوذج

تحياتي لك وآسف تعبتك معي

<{POST_SNAPBACK}>

تم تعديل يناير 23, 2005 بواسطه أبو هادي

**أبو هادي** · يناير 23, 2005

السلام عليكم

السلام عليكم

الأخ السامر .. موضوعك الحقيقة صاير مثل علم الهندسة الوراثية ، نحن الآن فقط فتحنا الشفرة ولازال للأمر بقية .

سأحاول مناقشة الموضوع مع أخي خضر الرجبي وأخي أبو سليمان غدا إن شاء الله .

الحقيقة أن استخدامه بهذه الطريقة سيؤدي إلى مشكلات كثيرة والمفترض كما أرى الآن أن يستخدم نوعا كنص فقط أما كتاريخ أو رقم فأعتقد أن الأمر يحتاج إلى إعادة نظر .

دعوة للجميع في كيفية الإستفادة من هذه النتيجة .. أنا بانتظار آرائكم .

أخي أبومؤنس .. أنت تأمر أمر بس بعد مشاركتنا برأيك حول الإستفسار أعلاه :d .

تحياتي .

**عبد الله فتحي** · يناير 23, 2005

ما شاء الله .. جهد مبارك ..

وللمشاركة معكم قمت بإضافة طريقتين للتعامل مع الريجستري، يمكنكم الوصول إليهما من هنا:

http://www.officena.net/ib/index.php?showtopic=5345

أو هنا:

http://www.officena.net/ib/index.php?showtopic=5346

مع تمنياتي لكم بدوام التوفيق والسداد

**الدكتور خضر الرجبي** · يناير 25, 2005

السلام عليكم

أخي أبا هادي، أخواني الاعضاء،

لقد تابعت البحث في الموضوع الاساس وهو كيفية الحصول على قيمة من تسجيلات ويندوز وقد توصلت أخير إلى طريقة مبسطة جدا بدون استخدام API Modules ويهذا نختصر الحل كثيرا.

والمثال التالي يوضح الطريقة، يوضع الكود في حدث عند النقر لزر أمر للتجربة:

Private Sub ShowRegKey_Click()
    Dim oKey As Variant
    Dim strValue As String
    Set oKey = CreateObject("Wscript.Shell")
    strValue = oKey.RegRead("HKEY_CURRENT_USER\control Panel\International\AddHijriDate")
    MsgBox strValue
End Sub

ملاحظة : لإستخراج التاريخ الهجري طبعا لا يمكن الاستغناء عن الدالة السابقة التي صممها أخي أبا هادي مشكورا، انما هذه الطريقة تختصر API Modules كما ذكرت سابقا.

مع الاحترام

تم تعديل يناير 25, 2005 بواسطه خضر الرجبي

**أبو هادي** · يناير 25, 2005

السلام عليكم

يا سلام عليك أخي خضر الرجبي .. فينك من زمان .

الحقيقة أنا أكره كثرة المديولات في البرنامج وخصوصا أكواد API .

الدالة بشكلها الأخير وبدون موديول الـ API .

Function GetSysHijri(ByVal HijriDate As Variant, _
                     Optional ByVal FormatPic As String = "dd/mm/yyyy") As String
  Dim oKey As Variant
  Dim AddDays As Integer
  Dim CurrCal As Byte
  Dim NewDate As String
  Dim ddd As String
  Dim dddd As String
  Dim Pos As Integer
  
  On Error Resume Next
  
  CurrCal = Calendar
  Calendar = vbCalHijri
  
  HijriDate = CDate(HijriDate)
  If Not IsDate(HijriDate) Then Exit Function
  
  If Year(HijriDate) = Year(Date) And _
     Month(HijriDate) = Month(Date) Then
     Set oKey = CreateObject("Wscript.Shell")
     Select Case oKey.RegRead("HKEY_CURRENT_USER\control Panel\International\AddHijriDate")
       Case "AddHijriDate-2": AddDays = -2
       Case "AddHijriDate":   AddDays = -1
       Case "":               AddDays = 0
       Case "AddHijriDate+1": AddDays = 1
       Case "AddHijriDate+2": AddDays = 2
     End Select
     Set oKey = Nothing
  Else
    AddDays = 0
  End If
  
  ddd = format(HijriDate + AddDays, "ddd")
  dddd = format(HijriDate + AddDays, "dddd")
  NewDate = format(HijriDate + AddDays, FormatPic)
  
  If ddd <> format(HijriDate, "ddd") Then
    Do While True
      If NewDate Like "*" & dddd & "*" Then
        Pos = InStr(1, NewDate, dddd)
        NewDate = Left(NewDate, Pos - 1) & _
                  format(HijriDate, "dddd") & _
                  Mid(NewDate, Pos + Len(dddd))
      ElseIf NewDate Like "*" & ddd & "*" Then
        Pos = InStr(1, NewDate, ddd)
        NewDate = Left(NewDate, Pos - 1) & _
                  format(HijriDate, "ddd") & _
                  Mid(NewDate, Pos + Len(ddd))
      Else
        Exit Do
      End If
    Loop
  End If
  
  GetSysHijri = NewDate
  Calendar = CurrCal
End Function

تحياتي .

SysHijriDate.rar

تم تعديل يناير 25, 2005 بواسطه أبو هادي

السامر · يناير 26, 2005

ما أقول الا بيض الله وجيهكم وعيني عليكم بارده . الله يعطيكم العافية ويكثر من أمثالكم

أأأأأأأأأأأأأأأأأأأأأأأأأألللللللللللللللللللللللللفففففففففف

شششششششششششششككككككككر

ابوفيصل

**أبوسليمان** · يناير 26, 2005

تطور رائع

أصبح الكود صغير وبسيط

جزاك الله الجنة أخي خضر على البحث المتواصل

وجزاك الله ألف خير أخي أبو هادي على المثال الجميل

أبو سليمان

تسجيل الدخول

الحصول على التاريخ الهجري للويندوز

الردود الموصى بها

السامر

أبو هادي

السامر

أبو هادي

الدكتور خضر الرجبي

الدكتور خضر الرجبي

أبو هادي

الدكتور خضر الرجبي

الدكتور خضر الرجبي

أبو هادي

أبو هادي

الدكتور خضر الرجبي

الدكتور خضر الرجبي

السامر

أبو هادي

عبد الله فتحي

الدكتور خضر الرجبي

أبو هادي

السامر

أبوسليمان

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information