Running VBA under XP I was able to call ActivateKeyboardLayout to switch my input language from English to another language. However, this no longer works under Vista64.
Any suggestions or workarounds?
The code that used to work under XP was similar to the following:
Private Declare Function ActivateKeyboardLayout Lib "user32" ( _
ByVal HKL As Long, ByVal flags As Integer) As Integer
Const aklPUNJABI As Long = &H4460446
ActivateKeyboardLayout aklPUNJABI, 0
There was a suggestion to try
Public Declare Function ActivateKeyboardLayout Lib "user32" ( _
ByVal nkl As IntPtr, ByVal Flags As uint) As Integer
When I try this I get the error message:
Variable uses an Automation type not supported in Visual Basic
Your declaration for the ActivateKeyboardLayout is actually incorrect. For 32-bit systems your code should be something like this:
Private Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, _
ByVal flags As Long) As Long
Const aklPUNJABI As Long = &H4460446
Dim oldLayout as Long
oldLayout = ActivateKeyboardLayout(aklPUNJABI, 0)
If oldLayout = 0 Then
'Oops an error'
Else
'Save old layout for later restore?'
End If
The 64-bitness of the operating system is a bit of a red herring in this case. Since you are running a VBA app it must be running as a 32-bit app regardless of OS. I suspect your problem may be that on your Vista system the Punjabi keyboard layout that you want is not loaded. ActivateKeyboardLayout will only work to activate a keyboard layout that is already loaded. For some reason the designers of this API felt that failure due to the keyboard layout not existing was not an error so the LastDllError is not set. You may want to look into using LoadKeyboardLayout for this type of situation.
EDIT: To double check that the keyboard layout you are trying to get is actually loaded you can use this:
Private Declare Function GetKeyboardLayoutList Lib "user32" (ByVal size As Long, _
ByRef layouts As Long) As Long
Dim numLayouts As Long
Dim i As Long
Dim layouts() As Long
numLayouts = GetKeyboardLayoutList(0, ByVal 0&)
ReDim layouts(numLayouts - 1)
GetKeyboardLayoutList numLayouts, layouts(0)
Dim msg As String
msg = "Loaded keyboard layouts: " & vbCrLf & vbCrLf
For i = 0 To numLayouts - 1
msg = msg & Hex(layouts(i)) & vbCrLf
Next
MsgBox msg
This is just a blind guess, but have you tried running your app as elevated administrator to see if it makes a difference? What's the error code / value of GetLastError?
Did you try a .Net line (as in VB.Net script or those snippets) like:
InputLanguage.CurrentInputLanguage =
InputLanguage.FromCulture(New System.Globalization.CultureInfo("ar-EG"))
InputLanguage should be supported for Vista64 with a .Net3.5
VB.Net code:
Public Sub ChangeInputLanguage(ByVal InputLang As InputLanguage)
If InputLanguage.InstalledInputLanguages.IndexOf(InputLang) = -1 Then
Throw New ArgumentOutOfRangeException()
End If
InputLanguage.CurrentInputLanguage = InputLang
End Sub
For 64-bit portability you may need to use IntPtr. Can you give this a shot?
Public Declare Function ActivateKeyboardLayout Lib "user32" (ByVal nkl As IntPtr, ByVal Flags As uint) As Integer
In 64-bit editions of Office apps, VBA is indeed 64-bit. See Office 2010 documentation for details of the changes. For the example given in Stephen Martin's answer, you will need to change the code as follows to add the PtrSafe attribute and fixup the parameters that have a HKL type in the Win32 API:
Private Declare PtrSafe Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As LongPtr, _
ByVal flags As Long) As LongPtr
Const aklPUNJABI As LongPtr = &H4460446
Dim oldLayout as LongPtr
oldLayout = ActivateKeyboardLayout(aklPUNJABI, 0)
If oldLayout = 0 Then
'Oops an error'
Else
'Save old layout for later restore?'
End If
and
Private Declare PtrSafe Function GetKeyboardLayoutList Lib "user32" (ByVal size As Long, _
ByRef layouts As LongPtr) As Long
Dim numLayouts As Long
Dim i As Long
Dim layouts() As LongPtr
numLayouts = GetKeyboardLayoutList(0, ByVal 0&)
ReDim layouts(numLayouts - 1)
GetKeyboardLayoutList numLayouts, layouts(0)
Dim msg As String
msg = "Loaded keyboard layouts: " & vbCrLf & vbCrLf
For i = 0 To numLayouts - 1
msg = msg & Hex(layouts(i)) & vbCrLf
Next
MsgBox msg
The thing that everyone seems to overlook here is that you are working in VBA, not in .NET. IntPtr is a .NET type which represents an integer which is native to the platform. On a 32-bit platform it is 32 bits, on a 64 bit platform, it is 64 bits.
Given that an HKL is a typedef for a handle, which is a typedef for PVOID which is a typedef for VOID *, it's exactly what you need, if you were using .NET.
VBA doesn't have anything for 64-bit numbers, so you have to take a different approach.
On a 64-bit machine, you will have to do something like this:
Public Type HKL64
High As Long
Low As Long
End Type
Private Declare Function ActivateKeyboardLayout Lib "user32" ( _
Byval HklHigh As Long, Byval HklLow As Long, _
ByVal flags As Integer) As HKL64
This should allow you to pass a 64 bit value on the stack to the API function (across two variables). However, if you are going to use this code on 64 bit and 32 bit machines, you are going to have to make two declarations of the API and then determine which one to call.
Also, any other code in VBA that calls APIs that deal with pointers or handles will have to be changed appropriately to handle 64 bit input (not 32).
On a side note, the original declaration of ActivateKeyboardLayout is wrong, as it had a return type of Integer, which is a 16-bit value, while the API returns a type of HKL, which is 32 or 64 bits, depending on the platform.
Related
MS Access 2019 (64 bit) on windows 10 (64 bit) crashes when calling the GDIP GetImageGraphicsContext or GdipCreateHBITMAPFromBitmap function
Declaration part______________________
GDIP code from:
'-------------------------------------------------
' Picture functions using GDIPlus-API (GDIP) |
'-------------------------------------------------
' * Office 2003/2007/2010 version * |
'-------------------------------------------------
' (c) mossSOFT / Sascha Trowitzsch rev. 04/2010 |
'-------------------------------------------------
Option Compare Database
Option Explicit
...Private Enum PixelFormat
PixelFormat1bppIndexed = &H30101
PixelFormat4bppIndexed = &H30402
pixelFormat8bppIndexed = &H30803
PixelFormat16bppGreyScale = &H101004
PixelFormat16bppRGB555 = &H21005
PixelFormat16bppRGB565 = &H21006
PixelFormat16bppARGB1555 = &H61007
PixelFormat24bppRGB = &H21808
PixelFormat32bppRGB = &H22009
PixelFormat32bppARGB = &H26200A
PixelFormat32bppPARGB = &HE200B
PixelFormat48bppRGB = &H10300C
PixelFormat64bppARGB = &H34400D
PixelFormat64bppPARGB = &H1C400E
PixelFormatMax = 15 '&HF
End Enum
...
Dim lGraph As Long
Dim lBitmap2 As Long
Dim lBitmap As Long
...
Private Declare PtrSafe Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, bitmap As Long) As Long
Private Declare PtrSafe Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal Image As Long, graphics As Long) As Long
...
Private Sub Form_Load()
Dim locRet as Long
InitGDIP '-> appaears to work fine
locRet = GdipCreateBitmapFromScan0(CLng(600), CLng(600), 0&, PixelFormat32bppARGB, ByVal 0&, lBitmap2) ' <- Appears to work fine until here (return value = 0)
locRet = GdipGetImageGraphicsContext(lBitmap2, lGraph) <- MS ACCESS 2019 crashes
or
Private Sub Form_Current()
locRet = GdipCreateHBITMAPFromBitmap(lBitmap2, hBitmap, CLng(BackGrndClr)) ' <- MS ACCESS 2019 crashes here
...
I tried to use different data types for the 'lGraph' variable, but there is a pre-compiler error when changing the data type because of a data type incomatibility so this did not help.
Does someone know how to make it work again? Under Windows 7 (64 bit, I guess) and MS Access 2016 32 bit, it works fine, wtihout any issue -> I try to move now to W10 64 bit and Access 2019 (64 bit).
Access crashes also when calling the GdipCreateHBITMAPFromBitmap function…
There appears to be a systematic issue...
If you want your API calls to be 64-bit compatible, you need to use LongPtr wherever you're passing a pointer.
Slapping PtrSafe on your function is not actually going to make the pointers safe, you need to do that yourself, and that keyword is there to indicate you have done that, and the function is safe for use in 64-bit. If you use that without verifying that you've changed all the pointers from Long to LongPtr, VBA will hard-crash when calling the function in a 64-bit application (and in rare cases you can even destabilize other applications).
As far as I can see, Graph and bitmap are the only pointers used in those functions, so you need to use a LongPtr when storing and passing those, but my GDI knowledge is a bit limited.
Dim lGraph As LongPtr
Dim lBitmap2 As LongPtr
Dim lBitmap As LongPtr
Private Declare PtrSafe Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, bitmap As Long) As Long
Private Declare PtrSafe Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal Image As LongPtr, graphics As LongPtr) As Long
I have a few excel projects which utilize userforms. Those userforms have some code which uses Windows API calls to modify their style. An example of this can be found here:
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function DwmSetWindowAttribute Lib "dwmapi" (ByVal hwnd As Long, ByVal attr As Integer, ByRef attrValue As Integer, ByVal attrSize As Integer) As Long
Private Declare PtrSafe Function DwmExtendFrameIntoClientArea Lib "dwmapi" (ByVal hwnd As Long, ByRef NEWMARGINS As MARGINS) As Long
Private UFSHADOW As Long
Private Type MARGINS
leftWidth As Long
rightWidth As Long
topHeight As Long
bottomHeight As Long
End Type
Sub all_userForms_AddShadow(frm As Object)
'Sub adds a shadow
Dim MARGINS As MARGINS
UFSHADOW = FindWindow("ThunderDFrame", vbNullString) 'Create a new Window
DwmSetWindowAttribute UFSHADOW, 2, 2, 4 'DWMAPI
'Determine Margins
With MARGINS
.rightWidth = 1
.leftWidth = 1
.topHeight = 1
.bottomHeight = 1
End With
DwmExtendFrameIntoClientArea UFSHADOW, MARGINS 'DWMAPI
'Resize
frm.Width = frm.Width - 1
frm.Height = frm.Height - 1
End Sub
The issue is that on certain clients, this will compile fine, but the result will not be displayed when the userform is initialized. I believe this is because on some clients, the windows setting "Enable Desktop Composition" is disabled by default and unable to be modified. A workaround I plan on using is to test whether or not Desktop Composition is enabled and if it is not, I will not call the sub.
My issue is that I cannot figure out how to test this. In the remarks section of this link https://msdn.microsoft.com/en-us/library/windows/desktop/aa969524(v=vs.85).aspx describes what should be returned if the DwmSetWindowAttribute function fails: DWM_E_COMPOSITIONDISABLED. I have tried setting this function equal to a few variable types, but it will not work.
Examples:
Desktop Composition Disabled
Desktop Composition Enabled
Any Suggestions? Thanks
Edit: In response to Mat's Mug's questions:
No error is thrown, it simply just does not draw the shadow.
You probably did not get the intended result as there are a few other API functions I call in relation to the "Add Shadow" sub which turn of the window caption and another which turns off the border. I can post those as well, but would make this post quite long.
I am a bit new to using windows API functions, I don't quite know your comments on the IF conditionals and VB Signatures, but I am researching it now..
As far as the bitness go, it's very likely that this tool will be accessed on both 32 and 64 bit OS. update.. I have just tested on both versions, my local machine has 64bit OS, the problem version has 32bit
My vb6 program was running on 32bit.
Now I have to move it to 64bit.
The lib that I declare below code,the system seem can't get it.
Declare:
Public Declare Function LogonUser Lib "advapi32.dll" _
Alias "LogonUserA" (ByVal lpszUsername As String, _
ByVal lpszDomain As String, ByVal lpszPassword As String, _
ByVal dwLogonType As Long, ByVal dwLogonProvider As Long, _
phToken As Long) As Long
Public Declare Function ImpersonateLoggedOnUser Lib "advapi32.dll" (ByVal hToken As Long) As Long
Public Declare Function RevertToSelf Lib "advapi32.dll" () As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Run Code:
Public Sub Logon(ByVal strAdminUser As String, ByVal _
strAdminPassword As String, ByVal strAdminDomain As String)
Dim lngTokenHandle As Long
Dim lngLogonType As Long
Dim lngLogonProvider As Long
Dim blnResult As Boolean
lngLogonType = 2
lngLogonProvider = 0
blnResult = RevertToSelf()
blnResult = LogonUser(strAdminUser, strAdminDomain, strAdminPassword, _
lngLogonType, lngLogonProvider, _
lngTokenHandle)
blnResult = ImpersonateLoggedOnUser(lngTokenHandle)
CloseHandle (lngTokenHandle)
End Sub
I got the error message
Error 91:Object variable or With block variable not set
Almost people say need to add "ptrsafe" after Declare but there is no ptrsafe in vb6.
How can I declare function lib without "ptrsafe" in the 64bit and vb6 ?
Almost people say need to add "ptrsafe" after Declare but there is no ptrsafe in vb6.
How can I declare function lib without "ptrsafe" in the 64bit and vb6 ?
VBA needs to be able to deal with 64 bit Windows when its run within a 64 bit application such as one of the programs from the 64 bit Office suite.
VB6 runs on its own forever & always as a 32 bit process, it does not need to be 64 bit aware as 64 bit Windows happily emulates 32 bit code with no additional steps required.
Because of this pointer-safe types are not needed, use the 32 bit convention (Long) in VB6.
Your functions declarations are wrong.
You don't have to add the complete path for Lib, only the library name is need.
By add the path, your code fails on 32 bit OS environment, because "C:\Windows\SysWOW64 folder doesn't exists on 32 bit systems.
Public Declare Function LogonUser Lib "advapi32.dll" _
Alias "LogonUserA" (ByVal lpszUsername As String, _
ByVal lpszDomain As String, ByVal lpszPassword As String, _
ByVal dwLogonType As Long, ByVal dwLogonProvider As Long, _
phToken As Long) As Long
Public Declare Function ImpersonateLoggedOnUser Lib "advapi32.dll" (ByVal hToken As Long) As Long
Public Declare Function RevertToSelf Lib "advapi32.dll" () As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
See:
https://support.microsoft.com/en-us/help/248187/how-to-impersonate-a-user-from-active-server-pages
Since you are talking about API declarations the following may be helpful. VB6 does not recognize the LongLong data type (64-bit integer) but it can be faked by using the VB6 Currency data type. The Currency numbers are actually stored as 64-bit integers. The four decimal places are only shown in display by dividing the actual number by 10,000. Depending on the specific API calls you are using, you may need to have dual API declarations and select the correct one at run time. So you also need to be able to detect the "bitness" of the system running.
See the following links:
Detect Bitness
Faking 64-bit Integers
Good afternoon,
I am attempting to use SendMessage to pass a string from a VB6 EXE, to a .NET 2013 EXE. I know that the message is getting in to the .NET EXE, because I'm able to set a breakpoint on it and it comes up when I call SendMessage from the VB6 EXE. The problem I am having is retrieving the string.
This is how I am attempting to do it:
VB6 Code:
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, Source As Any, ByVal bytes As Long)
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal msg As Long, wParam As Long, lParam As Any) As Long
Private Const APPVIEWER_OPEN = &H400
Private Sub Command1_Click()
Dim hwndAppViewer As Long
Dim bytBuffer(1 To 255) As Byte
Dim sParams As String
Dim lStringAddress As Long
hwndAppViewer = FindWindow(vbNullString, "DotNetReceiver")
If hwndAppViewer > 0 Then
sParams = "STRINGDATA"
CopyMemory bytBuffer(1), sParams, Len(sParams)
lStringAddress = VarPtr(bytBuffer(1))
SendMessage hwndAppViewer, APPVIEWER_OPEN, Me.hwnd, lStringAddress
End If
End Sub
Here is the .NET code:
Imports System.Runtime.InteropServices
Public Class Form1
Protected Overrides Sub WndProc(ByRef m As Message)
Dim sPolicyInformation As String
If m.Msg = &H400 Then
sPolicyInformation = Marshal.PtrToStringAnsi(m.LParam)
Else
MyBase.WndProc(m)
End If
End Sub
End Class
The problem comes when I try and retrieve the string. I am getting a blank string. I noticed that the number in the VB6 lStringAddress and the number in .NET m.lParam are completely different, so I must be missing something about how I'm passing the address through lParam.
Any ideas what I might be missing?
Thank you.
You are sending an ANSI string to VB.NET. VB6 was designed for all MS's OSs and 9x wasn't unicode. So all strings passed to API calls will be converted to ANSI. Windows will convert that ANSI string to unicode for the VB.NET program when it recieves it.
Use the sendmessagew function and send the first element of a byte array that's null terminated.
Dim MyStr() as byte
MyStr = "cat" & chrw(0)
The pass only the first element to SendMessageW ie MyStr(0). Windows API uses null terminated C strings. COM and VB6 use BStr (a size header and a non null terminated string).
When passing strings by ref you pass the address of the header. When passing by value you pass the address of the first character (making it a c string if you tack a null on the end).
How do you determine if the computer you are on is a 32-bit machine or a 64-bit machine?
I need this done in vba preferrably.
#Wouter Simon's answer is sort of on the right track, but really incomplete. It is missing a couple of Declare statements as well as some kind of explanation.
Therefore I believe it's worth presenting a more complete and working version here.
Private Declare Function GetProcAddress Lib "kernel32" _
(ByVal hModule As Long, _
ByVal lpProcName As String) As Long
Private Declare Function GetModuleHandle Lib "kernel32" _
Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long '()
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function IsWow64Process Lib "kernel32" _
(ByVal hProcess As Long, ByRef Wow64Process As Long) As Long
Sub CheckWhetherIts64()
Dim Its64 As Long
Dim handle As Long
handle = GetProcAddress(GetModuleHandle("kernel32"), _
"IsWow64Process")
If handle > 0 Then ' IsWow64Process function exists
' Now use the function to determine if
' we are running under Wow64
IsWow64Process GetCurrentProcess(), Its64
End If
If Its64 = 1 Then
MsgBox "it's a 64 bit process."
End If
End Sub
Caveat:
For compatibility with operating systems that do not support this function, call GetProcAddress to detect whether IsWow64Process is implemented in Kernel32.dll. If GetProcAddress succeeds, it is safe to call this function. Otherwise, WOW64 is not present. Note that this technique is not a reliable way to detect whether the operating system is a 64-bit version of Windows because the Kernel32.dll in current versions of 32-bit Windows also contains this function.
http://msdn.microsoft.com/en-us/library/ms684139%28v=vs.85%29.aspx
got it from
http://www.msoffice.us/Access/PDF/Extending%20VBA%20with%20APIs.pdf. Seems like it is working on mine.
Option Compare Database
Type SYSTEM_INFO
wProcessorArchitecture As Integer
wReserved As Integer
dwPageSize As Long
lpMinimumApplicationAddress As Long
lpMaximumApplicationAddress As Long
dwActiveProcessorMask As Long
dwNumberOrfProcessors As Long
dwProcessorType As Long
dwAllocationGranularity As Long
wProcessorLevel As Integer
wProcessorRevision As Integer
End Type
Declare Sub GetNativeSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public Function Is64BitProcessor() As Boolean
Const PROCESSOR_ARCHITECTURE_AMD64 As Integer = 9
Const PROCESSOR_ARCHITECTURE_IA64 As Integer = 6
Dim si As SYSTEM_INFO
' call the API
GetNativeSystemInfo si
' check the struct
Is64BitProcessor = (si.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_AMD64 _
Or _
si.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_IA64)
End Function
http://msdn.microsoft.com/en-us/library/ms724340(v=vs.85).aspx
To determine whether the running Office is 64-bit or 32-bit:
Use IsWow64Process (answer from Jean-François Corbett).
To determine whether Windows is 64-bit or 32-bit:
Public Function isWin64bit() As Boolean
isWin64bit = 0 < Len(Environ("ProgramW6432"))
End Function
I think the most straightforward way is:
#If Win64 Then
MsgBox "Win 64"
#Else
MsgBox "Win 32"
#End If
Sometimes it is also useful to check whether your Office is 32 or 64 and use this information to access the correct key in registry. So you can do:
#If Win64 Then
#If VBA7 Then
MsgBox "Win 64 and Office 64" ' HKEY_LOCAL_MACHINE\SOFTWARE\YourApp
#Else
MsgBox "Win 64 and Office 32" ' HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\YourApp
#End If
#Else
MsgBox "Win 32 and Office 32" ' HKEY_LOCAL_MACHINE\SOFTWARE\YourApp
#End If
HTH
Conditional compilation could be very useful, WinXX detects environment but not hardware properties, example below :
Dim mVers As String
Sub Init()
#If Win64 Then
mVers = "Win64" ' Win64=true, Win32=true, Win16= false
Call VerCheck
#ElseIf win32 Then
mVers = "Win32" ' Win32=true, Win16=false
Call VerCheck
#ElseIf win16 Then
mVers = "Win16" ' Win16=true
Call VerCheck
#End If
End Sub
Sub VerCheck()
MsgBox "Version: " & mVers, vbInformation, "Version"
End Sub
I think VBA may be linked to the office version that is running and it really matters what type of process is running. This code snippet may help (VB6 code)
Private Declare Function GetProcAddress Lib "kernel32" _
(ByVal hModule As Long, _
ByVal lpProcName As String) As Long
Private Declare Function GetModuleHandle Lib "kernel32" _
Alias "GetModuleHandleA" _
handle = GetProcAddress(GetModuleHandle("kernel32"), _
"IsWow64Process")
If handle > 0 Then ' IsWow64Process function exists
' Now use the function to determine if
' we are running under Wow64
IsWow64Process GetCurrentProcess(), bolFunc
End If