I would like to automatically change the keyboard layout and I create a simple console application in Visual Basic adding the following:
InputLanguage.CurrentInputLanguage = InputLanguage.FromCulture(New CultureInfo("ru"))
But when I compile this code it doesn't change the keyboard layout, so it remains what it was before compiling. What am I doing wrong?
There three ways to change keyboard language:
Using property .CurrentInputLanguage (only if input language installed)
InputLanguage.CurrentInputLanguage = InputLanguage.FromCulture(New CultureInfo("ru-RU"))
Using property .CurrentCulture (only if input language installed)
Dim culture = System.Globalization.CultureInfo.GetCultureInfo("ru-RU")
Dim lang = InputLanguage.FromCulture(culture)
If InputLanguage.InstalledInputLanguages.IndexOf(lang) >= 0 Then
InputLanguage.CurrentInputLanguage = InputLanguage.InstalledInputLanguages(InputLanguage.InstalledInputLanguages.IndexOf(lang))
System.Threading.Thread.CurrentThread.CurrentCulture = culture
End If
Using winapi function .LoadKeyboardLayout (slowly, works even if input language not installed)
<DllImport("user32.dll")>
Private Shared Function LoadKeyboardLayout(ByVal pwszKLID As String, ByVal Flags As UInteger) As IntPtr
End Function
LoadKeyboardLayout("00000419", 1)
Additional
For check current culture:
InputLanguage.CurrentInputLanguage.Culture.Name
Check is input language installed:
InputLanguage.InstalledInputLanguages.IndexOf(InputLanguage.FromCulture(New CultureInfo("ru-RU"))
Switch to next locale identifier (keyboard layout):
Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Integer, ByVal flags As Integer) As Integer
'switch keyboard layout to next
Sub SwitchKeyboardLayout()
Dim HKL_NEXT As Integer = 1
Dim dl As Integer = ActivateKeyboardLayout(HKL_NEXT, 0)
If dl = 0 Then MsgBox("Unsuccessful!")
End Sub
Additional materials
CultureInfo
Available Language Packs for Windows
Related
The user of my Word application has to be able to select a color. I currently use the color picker dialog in this way:
Private Type CHOOSECOLOR
lStructSize As LongLong
hwndOwner As LongPtr
hInstance As LongPtr
rgbResult As LongLong
lpCustColors As LongPtr
flags As LongLong
lCustData As LongLong
lpfnHook As LongLong
lpTemplateName As String
End Type
Private Declare PtrSafe Function MyChooseColor _
Lib "comdlg32.dll" Alias "ChooseColorW" _
(ByRef pChoosecolor As CHOOSECOLOR) As Boolean
Public Function GetColor(ByRef col As LongLong) As _
Boolean
Static CS As CHOOSECOLOR
Static CustColor(15) As LongLong
CS.lStructSize = Len(CS)
CS.hwndOwner = 0
CS.flags = &H1 Or &H2
CS.lpCustColors = VarPtr(CustColor(0))
CS.rgbResult = col
CS.hInstance = 0
GetColor = MyChooseColor(CS)
If GetColor = False Then Exit Function '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
GetColor = True
col = CS.rgbResult
End Function
However, I would like to offer a panel of the currently active theme colors to select from, to keep formatting consistency with the rest of the document.
Is there any way to do that?
AFAIK there isn't a way of getting a built-in color picker dialog to display theme colors, so you'll need to create your own.
You can get to the colors using code like:
Document.DocumentTheme.ThemeColorScheme(msoThemeAccent1).RGB
You need to be aware that when you apply the color to whatever object you are targeting you have to apply the theme color not its RGB value. Be prepared for the odd gotcha: not all objects have the required properties to be able to use theme colors.
I am trying use VBA to determine the user preference for the measurement unit in PowerPoint, however, I can't find the correct method. Do you know a way to determine if the unit setting is in inches, cm, pt?
I had this need too; with Word or Excel is easy, because Word.Application.Options.MeasurementUnit or Excel.Application.MeasurementUnit returns it; but for other Office Apps you have to grab it from a registry key, if your project has no Word or Excel reference, of course.
I have in one module:
Option Explicit
Public Const KeyInternationalMeasurementUnits As String = "HKEY_CURRENT_USER\Control Panel\International\iMeasure"
Enum eMeasure
Metrics = 0
Imperial = 1
End Enum
Function eMeasure_ToEnum(str As String) As eMeasure
Select Case str
Case "Metrics": eMeasure_ToEnum = Metrics
Case "Imperial": eMeasure_ToEnum = Imperial
End Select
End Function
Function eMeasure_ToString(value As eMeasure) As String
Select Case value
Case Metrics: eMeasure_ToString = "Metrics"
Case Imperial: eMeasure_ToString = "Imperial"
End Select
End Function
Function RegKeyRead(ByVal ReadedKey As String) As String
Dim thisWS As Object
Set thisWS = CreateObject("WScript.Shell")
RegKeyRead = thisWS.RegRead(ReadedKey)
Set thisWS = Nothing
End Function
Function RegKeyExists(ByVal RegKey As String) As Boolean
Dim thisWS As Object
On Error GoTo ErrorHandler
Set thisWS = CreateObject("WScript.Shell")
thisWS.RegRead RegKey
RegKeyExists = True
GoTo ExitFunction
ExitFunction:
Set thisWS = Nothing
Exit Function
ErrorHandler:
RegKeyExists = False
GoTo ExitFunction
End Function
And I call it whenever I need to:
Function WhichInternationalMeasurementUnits() As String
If RegKeyExists(KeyInternationalMeasurementUnits) Then
WhichInternationalMeasurementUnits = eMeasure_ToString(CInt(RegKeyRead(KeyInternationalMeasurementUnits)))
End If
End Function
You can adapt too an IsWord or IsExcel precondition test like this one that I used to grab which decimal sign is on regional settings.
If you're on Windows, there is no setting for preferred measurement units. PPT picks up the units, metric or imperial, from your Windows settings.
If it's important to know what units the user is seeing, you'd need to query the Win API.
If your code needs to use coordinates, the setting the user sees is not relevant; your code will use points (72 to the inch).
Did a bit of digging in a couple of Dan Appleman's old books and cobbled up this API call to determine whether the system is set to US or Metric. If I pass it 1033 (US English), it returns 1 until I go into Control Panel and set the system for metric; then it returns 0. But with the system set to US, the function returns 0 if I pass it the locale code for e.g. Dutch.
Fair warning: I'm strictly a cut/paste/play 'til it stops crashing API programmer. Nearly incompetent at it. Take it all with a grain of salt, eh?
Option Explicit
Declare Function GetLocaleInfo& Lib "kernel32" Alias "GetLocaleInfoA" (ByVal _
Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData _
As Long)
Function WindowsUSorMetric() As Long
' Returns 1 for U.S. or 0 for Metric
' NOTE: Needs modification before it'll work with 64-bit apps
' Assumes USEnglish
Dim Locale As Long
Dim LCType As Long
Dim lpLCData As String
Dim cchData As Long
' 1033 is the languageID for US English
' Use the Object Browser in the VBA IDE, look up msolanguageid for others
Locale = 1033
LCType = &HD
lpLCData = String$(255, 0)
cchData = 255
Call GetLocaleInfo(Locale, LCType, lpLCData, cchData)
WindowsUSorMetric = CLng(Left$(lpLCData, InStr(lpLCData, Chr$(0)) - 1))
End Function
Sub TestMe()
MsgBox WindowsUSorMetric
End Sub
Intro:
I've run into an issue when I tried to position Visio-UserForms relative to the calling Visio application window, as it is possible in other MS Office applications.
Normally I would use calling code like in the first block (Excel) to open a UserForm in a relative position to the application window.
The important properties for this uqestion are .Left and .Top, which return the offset of the window compared to the screen.
If I try the same in Visio (code block 2) I ran into the following Issue:
The application object of a the Visio application (vsApp) does not support the .Top an .Left properties, so obviously I get the standart Run.time error "438": “Object doesn't support this property or method”
Question:
My question is if there is an alternative relatively clean method to get the window position of the calling application (maybe even application-agnostic). When looking around there are a multitude of solutions for Excel, but none for Visio as far as I can tell.
This is my first question here, so please if I submitted something wrong or missed a rule/guideline please let me know.
Code:
In both cases the FooUserForm is a simple UserForm with a single button that hides the form with Me.Hide. The code below resides in a standard module
Code in Excel:
Option Explicit
Sub openFooUserForm()
Dim fooUF As FooUserForm
Set fooUF = New FooUserForm
Dim exApp As Excel.Application
Set exApp = ThisWorkbook.Application
fooUF.StartUpPosition = 0
fooUF.Top = exApp.Top + 25
fooUF.Left = exApp.Left + 25
fooUF.Show
Set fooUF = Nothing
End Sub
Code in Visio:
Option Explicit
Sub openFooUserForm()
Dim fooUF As FooUserForm
Set fooUF = New FooUserForm
Dim vsApp As Visio.Application
Set vsApp = ThisDocument.Application
fooUF.StartUpPosition = 0
fooUF.Top = vsApp.Top + 25
fooUF.Left = vsApp.Left + 25
fooUF.Show
Set fooUF = Nothing
End Sub
Since I assume to use this in many other project, I created a class containing all the code. The class works in 32-bit for now, mostly because I couldn't find a way to get the 64-bit handle from the Visio Application Object.
The code itself is prepared 64-bit thanks to the use of the LongPtr type. More Info here: https://codekabinett.com/rdumps.php?Lang=2&targetDoc=windows-api-declaration-vba-64-bit
The declarations should work since they were recreated in the 64-bit environment.
The class exposes 13 properties, 12 of these are Window positions and sizes and one is the Handle, this allows the user to target a different window instead of the application. This could be used to position a Userform in relation to a window opened inside the "Main" application.
Office UserForms (for some reason) use Points instead of Pixels to position themselves on the screen, to help with this I also built a conversion into the class.
There are still some things open that I want to change, like adding proper Error Handling and maybe giving the class a default Instance, but for now this is usable.
Resources
http://officeoneonline.com/vba/positioning_using_pixels.html
http://www.vbforums.com/showthread.php?436888-Get-Set-Window-Size-Position
Explanation
What happens in this Module/Class?
The class handles the interaction with the Windows API
It creates a Private Type Rect, which is used by the GetWindowRect function.
It declares the GetWindowRect function, wich takes the window handle of a window (obviously) and returns the position of the "Outline" in pixels
When the object is initialized it automatically stores the window handle of the Application in which it was called in this.Handle
When getting one of the px__ properties it simply updates the window position this.rc and returns the desired value.
When getting on of the pt__ properties it updates the window position and calculates the equivalent in points, this is usefull since VBA Userforms actually use points for positioning. The conversion is described here.
The windows handle can be changed by setting the Handle Property, this provides some more flexibility, for example when a multiple windows of the same application are opened.
Code
aModule (Module)
Sub openFooUserForm()
Dim winPo As WindowPositioner
Set winPo = New WindowPositioner
Dim fooUF As FooUserForm
Set fooUF = New FooUserForm
fooUF.StartUpPosition = 0
fooUF.Top = winPo.ptTop + 100
fooUF.Left = winPo.ptLeft + 50
fooUF.Show
Set fooUF = Nothing
End Sub
WindowPositioner (Class)
Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type TWindowPositioner
Handle As LongPtr
rc As RECT
End Type
Private this As TWindowPositioner
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
Const TWIPSPERINCH = 1440
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Sub Class_Initialize()
#If WIN64 THEN
'this.Handle = 'Method to get the 64-bit Handle of the Application Object
#Else
this.Handle = ThisDocument.Application.WindowHandle32
#End If
this.rc.Left = 0
this.rc.Top = 0
this.rc.Right = 0
this.rc.Bottom = 0
End Sub
Public Property Get Handle() As LongPtr
Handle = this.Handle
End Property
Public Property Let Handle(val As LongPtr)
this.Handle = val
End Property
Public Property Get pxTop() As Long
UpdatePosition
pxTop = this.rc.Top
End Property
Public Property Get pxLeft() As Long
UpdatePosition
pxLeft = this.rc.Left
End Property
Public Property Get pxBottom() As Long
UpdatePosition
pxBottom = this.rc.Bottom
End Property
Public Property Get pxRight() As Long
UpdatePosition
pxRight = this.rc.Right
End Property
Public Property Get pxHeight() As Long
UpdatePosition
pxHeight = this.rc.Bottom - this.rc.Top
End Property
Public Property Get pxWidth() As Long
UpdatePosition
pxWidth = this.rc.Left - this.rc.Right
End Property
Public Property Get ptTop() As Long
ptTop = CPxToPtY(pxTop)
End Property
Public Property Get ptLeft() As Long
ptLeft = CPxToPtX(pxLeft)
End Property
Public Property Get ptBottom() As Long
ptBottom = CPxToPtY(pxBottom)
End Property
Public Property Get ptRight() As Long
ptRight = CPxToPtX(pxRight)
End Property
Public Property Get ptHeight() As Long
ptHeight = CPxToPtY(pxBottom) - CPxToPtY(pxTop)
End Property
Public Property Get ptWidth() As Long
ptWidth = CPxToPtX(pxRight) - CPxToPtX(pxLeft)
End Property
Private Sub UpdatePosition()
GetWindowRect this.Handle, this.rc
End Sub
Private Function CPxToPtX(ByRef val As Long) As Long
Dim hDC As LongPtr
Dim RetVal As Long
Dim XPixelsPerInch As Long
hDC = GetDC(0)
XPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
RetVal = ReleaseDC(0, hDC)
CPxToPtX = CLng(val * TWIPSPERINCH / 20 / XPixelsPerInch)
End Function
Private Function CPxToPtY(ByRef val As Long) As Long
Dim hDC As LongPtr
Dim RetVal As Long
Dim YPixelsPerInch As Long
hDC = GetDC(0)
YPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSY)
RetVal = ReleaseDC(0, hDC)
CPxToPtY = CLng(val * TWIPSPERINCH / 20 / YPixelsPerInch)
End Function
You simply need to use Application.Window.GetWindowRect instead of Application.Top and Application.Left in Visio to get the main window coordinates (for historical reasons - when Visio became part of the Microsoft Office some 20 years ago, this API already existed, and it was different from other office apps you are referring to). Anyways, the subject can be done easier than in the accepted answer:
Set vsApp = ThisDocument.Application
'''' here we go
Dim left As Long, top As Long, width As Long, height As Long
vsApp.Window.GetWindowRect left, top, width, height
fooUF.StartUpPosition = 0
fooUF.Top = top + 25
fooUF.Left = left + 25
I have found plenty of examples in C#, but I cannot make this work in VB no matter what I try. The only icon I can extract is the one representing a file with no association. If there is a better approach I am open to that too. Here is the code:
Declaration:
Declare Auto Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As IntPtr, ByVal lpIconPat As String, ByRef lpiIcon As Integer) As IntPtr
Other Code:
Dim handle As IntPtr
Dim li As ListViewItem
Dim modul As System.Reflection.Module()
For Each filename As FileInfo In quotesFolder.GetFiles()
If ImgLstQuotes.Images.ContainsKey(filename.Extension) Then
Else
modul = System.Reflection.Assembly.GetExecutingAssembly.GetModules()
'handle = ExtractAssociatedIcon(Marshal.GetHINSTANCE(modul(0)), filename.FullName, -1) 'doesnt work
'handle = ExtractAssociatedIcon(IntPtr.Zero(), filename.FullName, -1) 'doesn't work
handle = ExtractAssociatedIcon(Process.GetCurrentProcess().Handle, filename.FullName, -1) 'doesn't work
ImgLstQuotes.Images.Add(filename.Extension, Drawing.Icon.FromHandle(handle))
End If
li = LstVwQuotes.Items.Add(filename.Name, filename.Extension)
li.Name = UCase(filename.Name)
li.SubItems.Add(filename.LastWriteTime)
Next
Thanks in advance!
Using VB6. It's not hard to roll your own, but I wondered if was a prebuilt one out there?
Prompted by Bob's comment: Google found this wrapper for UrlEscape in a newsgroup post from Karl Peterson.
Private Declare Function UrlEscape Lib "Shlwapi.dll" Alias "UrlEscapeA" ( _
ByVal pszURL As String, ByVal pszEscaped As String, ByRef pcchEscaped As Long, _
ByVal dwFlags As Long) As Long
Private Const URL_DONT_ESCAPE_EXTRA_INFO As Long = &H2000000
Private Function EscapeURL(ByVal URL As String) As String
' Purpose: A thin wrapper for the URLEscape API function. '
Dim EscTxt As String
Dim nLen As Long
' Create a maximum sized buffer. '
nLen = Len(URL) * 3
EscTxt = Space$(nLen)
If UrlEscape(URL, EscTxt, nLen, URL_DONT_ESCAPE_EXTRA_INFO) = 0 Then
EscapeURL = Left$(EscTxt, nLen)
End If
End Function
Disclaimer: I haven't tried this code myself.
You should use CoInternetParseUrl(), with URL_ENCODE.
The sample from MSDN, modified for your purposes. Of course, you'll have to figure out how to call CoInternetParseUrl() from VB6, but you seem well on your way to that.
#include <wininet.h>
// ...
WCHAR encoded_url[INTERNET_MAX_URL_LENGTH];
DWORD encoded_url_len = ARRAYSIZE(encoded_url);
// Assumes |url| contains the value you want to encode.
HRESULT hr = CoInternetParseUrl(url, PARSE_CANONICALIZE, URL_ENCODE, encoded_url,
INTERNET_MAX_URL_LENGTH, & encoded_url_len, 0);
if (SUCCEEDED(hr)) {
// Do stuff...
}
You may want to use PARSE_ENCODE instead of PARSE_CANONICALIZE, depending on your needs.
Also, consider using google-url. May be difficult since it's C++ and not COM based.