I want to change my default keyboard Layout for a installed another Keyboard Layout using my VB application.I googled about this and find Function LoadKeyboardLayout() Function to do that.But Is this support in vb 2010.When I wrote below code and there is no syntax error.But when I run the program there is an error called "PInvokeStackImbalance was detected... "
How can I solve this in vb 2010.
Here is my code:
Private Const KLF_ACTIVATE As Long = &H1
Private Const KLF_NOTELLSHELL As Long = &H80
Private Const KLF_REORDER As Long = &H8
Private Const KLF_REPLACELANG As Long = &H10
Private Const KLF_RESET As Long = &H40000000
Private Const KLF_SETFORPROCESS As Long = &H100
Private Const KLF_SHIFTLOCK As Long = &H10000
Private Const KLF_SUBSTITUTE_OK As Long = &H2
Private Const KLF_UNLOADPREVIOUS As Long = &H4
Private Declare Function LoadKeyboardLayout _
Lib "user32.dll" _
Alias "LoadKeyboardLayoutA" ( _
ByVal pwszKLID As String, _
ByVal flags As Long) As Long
'Inside a button click event
LoadKeyboardLayout("00000409", KLF_ACTIVATE)
Can anyone help me...
I think all you have to do is switch the longs to integers...
Private Declare Function LoadKeyboardLayout Lib "user32.dll" _
Alias "LoadKeyboardLayoutA" ( ByVal pwszKLID As String, _
ByVal flags As Integer) As Integer
Related
I was using the below code to programaticaly set my desktop wallpaper in VB.NET
Private Const SPI_SETDESKWALLPAPER As Integer = &H14
Private Const SPIF_UPDATEINIFILE As Integer = &H1
Private Const SPIF_SENDWININICHANGE As Integer = &H2
Private Declare Auto Function SystemParametersInfo Lib "user32.dll" (ByVal uAction As Integer, ByVal uParam As Integer, ByVal lpvParam As String, ByVal fuWinIni As Integer) As Integer
Sub Main()
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, "result.jpg", SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
End Sub
It was working fine earlier. But now when i run it, it sets my desktop as black, instead of setting the image and I am not able to find out why. Does anyone know why this happens? Does this method have any dependency?
Today im using this code to copy a file to clipboard with excel 2010 (32 bit).
Im trying to get this to work with office 2016 (64 bit), but everytime the function is used excel crashes.
Is it possible to get this code to work with both excel 2016 (64 bit) and office 2010 (32 bit)?
Option Explicit
' Required data structures
Private Type POINTAPI
x As Long
y As Long
End Type
' Clipboard Manager Functions
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
' Other required Win32 APIs
Private Declare PtrSafe Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
Private Declare PtrSafe Function DragQueryPoint Lib "shell32.dll" (ByVal hDrop As Long, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
' Predefined Clipboard Formats
Private Const CF_TEXT = 1
Private Const CF_BITMAP = 2
Private Const CF_METAFILEPICT = 3
Private Const CF_SYLK = 4
Private Const CF_DIF = 5
Private Const CF_TIFF = 6
Private Const CF_OEMTEXT = 7
Private Const CF_DIB = 8
Private Const CF_PALETTE = 9
Private Const CF_PENDATA = 10
Private Const CF_RIFF = 11
Private Const CF_WAVE = 12
Private Const CF_UNICODETEXT = 13
Private Const CF_ENHMETAFILE = 14
Private Const CF_HDROP = 15
Private Const CF_LOCALE = 16
Private Const CF_MAX = 17
' New shell-oriented clipboard formats
Private Const CFSTR_SHELLIDLIST As String = "Shell IDList Array"
Private Const CFSTR_SHELLIDLISTOFFSET As String = "Shell Object Offsets"
Private Const CFSTR_NETRESOURCES As String = "Net Resource"
Private Const CFSTR_FILEDESCRIPTOR As String = "FileGroupDescriptor"
Private Const CFSTR_FILECONTENTS As String = "FileContents"
Private Const CFSTR_FILENAME As String = "FileName"
Private Const CFSTR_PRINTERGROUP As String = "PrinterFriendlyName"
Private Const CFSTR_FILENAMEMAP As String = "FileNameMap"
' Global Memory Flags
Private Const GMEM_FIXED = &H0
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_NOCOMPACT = &H10
Private Const GMEM_NODISCARD = &H20
Private Const GMEM_ZEROINIT = &H40
Private Const GMEM_MODIFY = &H80
Private Const GMEM_DISCARDABLE = &H100
Private Const GMEM_NOT_BANKED = &H1000
Private Const GMEM_SHARE = &H2000
Private Const GMEM_DDESHARE = &H2000
Private Const GMEM_NOTIFY = &H4000
Private Const GMEM_LOWER = GMEM_NOT_BANKED
Private Const GMEM_VALID_FLAGS = &H7F72
Private Const GMEM_INVALID_HANDLE = &H8000
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)
Private Type DROPFILES
pFiles As Long
pt As POINTAPI
fNC As Long
fWide As Long
End Type
Public Function ClipboardCopySingleFile(File As String) As Boolean
Dim Files(0) As String
Files(0) = File
ClipboardCopyFiles Files()
End Function
Public Function ClipboardCopyFiles(Files() As String) As Boolean
Dim data As String
Dim df As DROPFILES
Dim hGlobal As Long
Dim lpGlobal As Long
Dim I As Long
' Open and clear existing crud off clipboard.
If OpenClipboard(0&) Then
Call EmptyClipboard
' Build double-null terminated list of files.
For I = LBound(Files) To UBound(Files)
data = data & Files(I) & vbNullChar
Next
data = data & vbNullChar
' Allocate and get pointer to global memory,
' then copy file list to it.
hGlobal = GlobalAlloc(GHND, Len(df) + Len(data))
If hGlobal Then
lpGlobal = GlobalLock(hGlobal)
' Build DROPFILES structure in global memory.
df.pFiles = Len(df)
Call CopyMem(ByVal lpGlobal, df, Len(df))
Call CopyMem(ByVal (lpGlobal + Len(df)), ByVal data, Len(data))
Call GlobalUnlock(hGlobal)
' Copy data to clipboard, and return success.
If SetClipboardData(CF_HDROP, hGlobal) Then
ClipboardCopyFiles = True
End If
End If
' Clean up
Call CloseClipboard
End If
End Function
Public Function ClipboardPasteFiles(Files() As String) As Long
Dim hDrop As Long
Dim nFiles As Long
Dim I As Long
Dim desc As String
Dim filename As String
Dim pt As POINTAPI
Const MAX_PATH As Long = 260
' Insure desired format is there, and open clipboard.
If IsClipboardFormatAvailable(CF_HDROP) Then
If OpenClipboard(0&) Then
' Get handle to Dropped Filelist data, and number of files.
hDrop = GetClipboardData(CF_HDROP)
nFiles = DragQueryFile(hDrop, -1&, "", 0)
' Allocate space for return and working variables.
ReDim Files(0 To nFiles - 1) As String
filename = Space(MAX_PATH)
' Retrieve each filename in Dropped Filelist.
For I = 0 To nFiles - 1
Call DragQueryFile(hDrop, I, filename, Len(filename))
Files(I) = TrimNull(filename)
Next
' Clean up
Call CloseClipboard
End If
' Assign return value equal to number of files dropped.
ClipboardPasteFiles = nFiles
End If
End Function
Private Function TrimNull(ByVal sTmp As String) As String
Dim nNul As Long
' Truncate input sTmpg at first Null.
' If no Nulls, perform ordinary Trim.
nNul = InStr(sTmp, vbNullChar)
Select Case nNul
Case Is > 1
TrimNull = Left(sTmp, nNul - 1)
Case 1
TrimNull = ""
Case 0
TrimNull = Trim(sTmp)
End Select
End Function
Have you checked the need of compile directives?
https://msdn.microsoft.com/en-us/library/office/gg264731.aspx
I have used before, for similar problems, something like the example below:
#If VBA7 Then
Private Declare PtrSafe Function apiGetComputerName Lib "kernel32" Alias _
"GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
#Else
Private Declare Function apiGetComputerName Lib "kernel32" Alias _
"GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
#End If
I need to check the Internet connection when an Excel workbook opens. For that, I'm trying the following code:
Private Declare PtrSafe Function InternetGetConnectedState _
Lib "wininet.dll" (ByRef dwflags As Long, _
ByVal dwReserved As Long) As Long
Private Const INTERNET_CONNECTION_MODEM As Long = &H1
Private Const INTERNET_CONNECTION_LAN As Long = &H2
Private Const INTERNET_CONNECTION_PROXY As Long = &H4
Private Const INTERNET_CONNECTION_OFFLINE As Long = &H20
Function IsInternetConnected() As Boolean
Dim L As Long
Dim R As Long
R = InternetGetConnectedState(L, 0&)
If R = 0 Then
IsInternetConnected = False
Else
If R <= 4 Then
IsInternetConnected = True
Else
IsInternetConnected = False
End If
End If
End Function
It works, but some users are reporting this is breaking Excel (it freezes Excel forever).
Is there a way to throw an error or somehow correct this code in order to find out what is the cause of the problem (Firewall, etc.)?
Thank you so much for helping!
Here are the proper imports with compiler directives.
Option Explicit
#If Win64 Then
Public Flg As LongPtr
Public Declare PtrSafe Function InternetGetConnectedState _
Lib "wininet.dll" (lpdwFlags As LongPtr, _
ByVal dwReserved As Long) As Boolean
#Else
Public Flg As Long
Public Declare Function InternetGetConnectedState _
Lib "wininet.dll" (lpdwFlags As Long, _
ByVal dwReserved As Long) As Boolean
#End If
Private Const INTERNET_CONNECTION_MODEM As Long = &H1
Private Const INTERNET_CONNECTION_LAN As Long = &H2
Private Const INTERNET_CONNECTION_PROXY As Long = &H4
Private Const INTERNET_CONNECTION_OFFLINE As Long = &H20
Function IsInternetConnected() As Boolean
Dim R As Long
R = InternetGetConnectedState(Flg, 0&)
If Flg >= INTERNET_CONNECTION_OFFLINE Then
Debug.Print "INTERNET_CONNECTION_OFFLINE"
End If
If CBool(R) Then
IsInternetConnected = True
Else
IsInternetConnected = False
End If
End Function
Sub main()
Dim mssg As String
If IsInternetConnected Then
mssg = "Connected"
Else
mssg = "Not connected"
End If
MsgBox mssg
End Sub
I believe at least one of the problems was failing to provide the correct var-type to receive the lpdwFlags. I've added a public var within the compiler directives. The Flg var receives the flags from the function. These can be parsed bitwise against your constants to determine the state. See InternetGetConnectedState for more information (and a full set of flags).
This has been tested on both 32-bit and 64-bit xl2010.
Basically, I have a degree of automation that requires the Onscreen Keyboard app within windows to run.
When it runs, I would ideally need it to open within the same set of co-ordinates for any machine that it is run from.
Even more ideal, would be a way to make sure that if there is a difference in resolution, that the co-ordinates of the keys will not change. - This may be a step too far??
Any support is appreciated!
Cheers.
This is VB6 (same language as VBA). You can get it compiled in https://onedrive.live.com/?cid=e2f0ce17a268a4fa&id=E2F0CE17A268A4FA%21121 (Topmost.zip).
It reads the VB6 command line so needs to be changed for use in Office.
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Const SWP_DRAWFRAME = &H20
Public Const SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
Public Const SWP_HIDEWINDOW = &H80
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_NOCOPYBITS = &H100
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOOWNERZORDER = &H200 ' Don't do owner Z ordering
Public Const SWP_NOREDRAW = &H8
Public Const SWP_NOREPOSITION = &H200
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOZORDER = &H4
Public Const SWP_SHOWWINDOW = &H40
Public Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Sub Main()
On Error Resume Next
HWND_TOPMOST = -1
CmdLine = Command()
A = Split(CmdLine, Chr(32), 2, 1)
B = Split(A(0), "x", 2, 1)
hwindows = FindWindow(vbNullString, A(1))
Ret = SetWindowPos(hwindows, HWND_NOTOPMOST, B(0), B(1), 0, 0, SWP_NOREPOSITION + SWP_NOSIZE)
If Ret = 0 Then MsgBox "Set Pos Error is " & Err.LastDllError
End Sub
In VB6 I could easily create a balloon message that would be shown next to the textbox.
It would automatically disappear as soon as the text is changed.
I could use this balloon tooltip for messages like "Enter a valid eMail address!".
I used the Windows API to create this balloon. I have attached the code below.
Is there no framework solution for this?
Thank you for the help!
Option Explicit
Private Const ECM_FIRST = &H1500 '// Edit control messages
Private Const EM_SETCUEBANNER = (ECM_FIRST + 1)
Private Const EM_GETCUEBANNER = (ECM_FIRST + 2) '// Set the cue banner with the lParm = LPCWSTR
Private Type EDITBALLOONTIP
cbStruct As Long
pszTitle As Long
pszText As Long
ttiIcon As Long ' ; // From TTI_*
End Type
Private Const EM_SHOWBALLOONTIP = (ECM_FIRST + 3) '// Show a balloon tip associated to the edit control
Private Const EM_HIDEBALLOONTIP = (ECM_FIRST + 4) '// Hide any balloon tip associated with the edit control
Private Declare Function SendMessageW Lib "user32" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function LocalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal wBytes As Long) As Long
Private Declare Function LocalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function LocalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Const GMEM_FIXED = &H0
Private Const GMEM_ZEROINIT = &H40
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)
Private m_hWnd As Long
Private m_sCueBanner As String
Private m_sTitle As String
Private m_sText As String
Private m_eIcon As BalloonTipIconConstants
Public Property Let TextBox(txtThis As TextBox)
m_hWnd = txtThis.hwnd
End Property
Public Property Let CueBanner(ByVal value As String)
m_sCueBanner = value
setCueBanner
End Property
Public Property Get CueBanner() As String
CueBanner = m_sCueBanner
End Property
Public Property Let BalloonTipTitle(ByVal value As String)
m_sTitle = value
End Property
Public Property Get BalloonTipTitle() As String
BalloonTipTitle = m_sTitle
End Property
Public Property Let BalloonTipText(ByVal value As String)
m_sText = value
End Property
Public Property Get BalloonTipText() As String
BalloonTipText = m_sText
End Property
Public Property Let BalloonTipIcon(ByVal value As BalloonTipIconConstants)
m_eIcon = value
End Property
Public Property Get BalloonTipIcon() As BalloonTipIconConstants
BalloonTipIcon = m_eIcon
End Property
Public Sub ShowBalloonTip()
Dim lR As Long
Dim tEBT As EDITBALLOONTIP
tEBT.cbStruct = LenB(tEBT)
tEBT.pszText = StrPtr(m_sText)
tEBT.pszTitle = StrPtr(m_sTitle)
tEBT.ttiIcon = m_eIcon
lR = SendMessageW(m_hWnd, EM_SHOWBALLOONTIP, 0, tEBT)
End Sub
Public Sub HideBalloonTip()
Dim lR As Long
lR = SendMessageLongW(m_hWnd, EM_HIDEBALLOONTIP, 0, 0)
Debug.Print lR
End Sub
Private Sub setCueBanner()
Dim lR As Long
' Reports success, but doesn'/t actually work...
' (is this because the VB text box is ANSI?)
lR = SendMessageLongW(m_hWnd, EM_SETCUEBANNER, 0, StrPtr(m_sCueBanner))
Debug.Print lR
End Sub
You can set a tooltip like this
Dim toolTip1 As New ToolTip()
toolTip1.SetToolTip(Me.textbox1, "Hello World")
and hide the tooltip with
toolTip1.SetToolTip(Me.textbox1, "")
Note that you can also add a ToolTip-Control to the form the toolbox instead of creating it programmatically. It magically adds a ToolTip-property to all controls in the properties window where you can enter a tooltip message. The controls themselves, however, will not aquire a ToolTip property and you can only set or remove the tooltip through the ToolTip.SetToolTip method in code.
I think it can only be done in the way I want it using the API way.
I found a perfect migration of my VB6 sample here:
http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=7109&lngWId=10