اذهب الي المحتوي
أوفيسنا

تحويل اللغة مباشرة عند اختيار خلية


giknim

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

السلام عليكم جميعاً

كما هو مبين بالعنوان ، ما اود السؤال عنه هل من الممكن عمل كود معين لجعل اللغة تتحول مثلاً من العربية الى الانجليزيه مباشرة عند اختيار خلية معينة دون الحاجة الى استخدام الازرار

شكراً لكم مقدماً على المعاينة والمتابعة

رابط هذا التعليق
شارك

السلام عليكم

يرجي الإفادة عند استخدام فورم واستخدام تكست بوكس وأرغب في أن تتحول لوحة المفاتيح عند الكتابة فيه إلي اللغة العربية فما هو الكود المطلوب لذلك

وشكرا مقدما

 

 

رابط هذا التعليق
شارك

السلام عليكم

لو افترضنا أن التكست بوكس هو TextBox1 ضع الكود التالي في موديول الفورم

Option Explicit

Private Const KL_NAMELENGTH = 9
#If Win64 Then
    Private Declare PtrSafe Function LoadKeyboardLayoutA Lib "user32" (ByVal pwszKLID As String, ByVal flags As Long) As LongPtr
    Private Declare PtrSafe Function ActivateKeyboardLayoutA Lib "user32" Alias "ActivateKeyboardLayout" (ByVal HKL As LongPtr, ByVal flags As Long) As LongPtr
    Private Declare PtrSafe Function UnloadKeyboardLayoutA Lib "user32" Alias "UnloadKeyboardLayout" (ByVal HKL As LongPtr) As Long
    Private Declare PtrSafe Function GetKeyboardLayoutNameA Lib "user32" (ByVal pwszKLID As String) As Long
#Else
    Private Declare Function LoadKeyboardLayoutA Lib "user32" (ByVal pwszKLID As String, ByVal flags As Long) As Long
    Private Declare Function ActivateKeyboardLayoutA Lib "user32" Alias "ActivateKeyboardLayout" (ByVal HKL As Long, ByVal flags As Long) As Long
    Private Declare Function UnloadKeyboardLayoutA Lib "user32" Alias "UnloadKeyboardLayout" (ByVal HKL As Long) As Long
    Private Declare Function GetKeyboardLayoutNameA Lib "user32" (ByVal pwszKLID As String) As Long
#End If

#If Win64 Then
    Dim HKLsystem As LongPtr, HKLarabic As LongPtr
#Else
    Dim HKLsystem As Long, HKLarabic As Long
#End If

Private Sub TextBox1_Enter()
  ActivateKeyboardLayout HKLarabic
End Sub

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
  ActivateKeyboardLayout HKLsystem
End Sub

Private Sub UserForm_Initialize()
  HKLsystem = LoadKeyboardLayout(GetKeyboardLCID)
  HKLarabic = LoadKeyboardLayout(1025)
End Sub

Private Sub UserForm_Terminate()
  ActivateKeyboardLayout HKLsystem
  UnloadKeyboardLayout HKLarabic
End Sub

Private Function GetKeyboardLCID() As Long
  Dim KLID As String * KL_NAMELENGTH
  GetKeyboardLayoutNameA KLID
  GetKeyboardLCID = CLng("&H" & KLID)
End Function

#If Win64 Then
   Private Function LoadKeyboardLayout(ByVal LCID As Long) As LongPtr
#Else
   Private Function LoadKeyboardLayout(ByVal LCID As Long) As Long
#End If
    Dim KLID As String * KL_NAMELENGTH
    KLID = Right(String(KL_NAMELENGTH - 1, "0") & Hex(LCID), KL_NAMELENGTH - 1) & vbNullChar
    LoadKeyboardLayout = LoadKeyboardLayoutA(KLID, 0)
End Function

#If Win64 Then
    Private Function UnloadKeyboardLayout(ByVal HKL As LongPtr) As Boolean
#Else
   Private Function UnloadKeyboardLayout(ByVal HKL As Long) As Boolean
#End If
    UnloadKeyboardLayout = UnloadKeyboardLayoutA(HKL) <> 0
End Function

#If Win64 Then
    Private Function ActivateKeyboardLayout(ByVal HKL As LongPtr) As LongPtr
#Else
    Private Function ActivateKeyboardLayout(ByVal HKL As Long) As Long
#End If
    ActivateKeyboardLayout = ActivateKeyboardLayoutA(HKL, 0)
    DoEvents
End Function

 

تم تعديل بواسطه جعفر الطريبق
  • Like 3
رابط هذا التعليق
شارك

اخى واستاذنا جعفر

ماشاء الله عليك

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

بارك الله فيك

تقبل تحياتى

بارك الله فيك يا اسناذ ابراهيم

تم تعديل بواسطه جعفر الطريبق
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information