ماژولی برای صفجه کلید فارسی

**iranweld** · 2015/10/14, 09:27

با سلام

این نمونه فایلی است که قبلا سرکار خانم خاکزاد زحمت تهیه آنرا تقبل کرده اند.

حال با یک تغییر کوچک به خواسته شما تغییر یافت

کد PHP:


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

On Error Resume Next

 If Not Application.Intersect(Target, Range("b2")) Is Nothing Or _
 Not Application.Intersect(Target, Range("g2")) Is Nothing Then
  
 changelanguage
 
 Else
 
 changelanguage2
 
 End If
 

On Error GoTo 0

End Sub

کد PHP:


Private Declare Function GetKeyboardLayoutName Lib "user32" _
Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Private Declare Function LoadKeyboardLayout Lib "user32" _
Alias "LoadKeyboardLayoutA" _
(ByVal pwszKLID As String, ByVal flags As Long) As Long

Const KLF_ACTIVATE = &H1


Global Const LANG_ENGLISH As String = "00000409"
Global Const LANG_persian As String = "00000429"


Sub changelanguage()

If Application.LanguageSettings.LanguagePreferredForEditing(msoLanguageIDEnglishUS) Then

SwitchKeyboardLang (LANG_persian)
End If

End Sub


'End Sub'
 Function SwitchKeyboardLang(ByVal strLangID As String) As Boolean

Dim strRet As String
On Error Resume Next
strRet = String(9, 0)
GetKeyboardLayoutName strRet
If strRet = (strLangID & Chr(0)) Then

SwitchKeyboardLang = True
Exit Function
Else
strRet = String(9, 0)
strRet = LoadKeyboardLayout((strLangID & Chr(0)), KLF_ACTIVATE)
End If

GetKeyboardLayoutName strRet
If strRet = (strLangID) Then
SwitchKeyboardLang = True
End If
End Function
Sub changelanguage2()

If Application.LanguageSettings.LanguagePreferredForEditing(msoLanguageIDEnglishUS) Then

SwitchKeyboardLang (LANG_ENGLISH)
End If

End Sub