Excel 64-bit and comdlg32.dll custom colours - vba

I'm trying to adapt the code in either here or here to open the custom colour palette in Excel 2010 64-bit but cannot get it to work. Code on both sites work fine in Excel 2003
One attempt
Option Explicit
Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare PtrSafe Function ChooseColorAPI Lib "comdlg32.dll" Alias _
"ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
Dim CustomColors() As Byte
Private Sub Command1_Click()
Dim cc As CHOOSECOLOR
Dim Custcolor(16) As Long
Dim lReturn As Long
cc.lStructSize = Len(cc)
cc.hwndOwner = Application.Hwnd
cc.hInstance = 0
cc.lpCustColors = StrConv(CustomColors, vbUnicode)
cc.flags = 0
lReturn = ChooseColorAPI(cc)
If lReturn <> 0 Then
Application.Caption = "RGB Value User Chose: " & Str$(cc.rgbResult)
Application.BackColor = cc.rgbResult ' Visual Basic only ****
Application.Section(0).BackColor = cc.rgbResult ' Access only **********
CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
Else
MsgBox "User chose the Cancel Button"
End If
End Sub
Private Sub Form_Load()
ReDim CustomColors(0 To 16 * 4 - 1) As Byte
Dim i As Integer
For i = LBound(CustomColors) To UBound(CustomColors)
CustomColors(i) = 0
Next i
End Sub
This runs ok but doesn't show the dialog. I've also tried changing some LONG types to LONGPTR with no success. Does anyone know how to get this working on a 64-bit machine; or if it's even possible? Perhaps there's a new library?
Thanks
Edit: Slight rewording with offer of bounty...
How do I access and use this custom colour chooser (image below) in Excel 2010 64-bit (MUST work on 64-bit!) to set cells in Excel 2010 with the colour chosen and store the colour? The image is taken from Excel 2010 64-bit by selecting fill button>more colors>Custom
Valid XHTML http://img851.imageshack.us/img851/2057/unlednvn.png

Two things I would try. First, replace every use of Long with LongPtr.
Private Type CHOOSECOLOR
lStructSize As LongPtr
hwndOwner As LongPtr
hInstance As LongPtr
rgbResult As LongPtr
lpCustColors As String
flags As LongPtr
lCustData As LongPtr
lpfnHook As LongPtr
lpTemplateName As String
End Type
Private Declare PtrSafe Function ChooseColorAPI Lib "comdlg32.dll" Alias _
"ChooseColorA" (pChoosecolor As CHOOSECOLOR) As LongPtr
Second, replace the use of Len with LenB.
Private Sub Command1_Click()
Dim cc As CHOOSECOLOR
Dim Custcolor(16) As LongPtr
Dim lReturn As LongPtr
cc.lStructSize = LenB(cc)
cc.hwndOwner = Application.Hwnd
cc.hInstance = 0
cc.lpCustColors = StrConv(CustomColors, vbUnicode)
cc.flags = 0
lReturn = ChooseColorAPI(cc)
If lReturn <> 0 Then
Application.Caption = "RGB Value User Chose: " & Str$(cc.rgbResult)
Application.BackColor = cc.rgbResult ' Visual Basic only ****
Application.Section(0).BackColor = cc.rgbResult ' Access only **********
CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
Else
MsgBox "User chose the Cancel Button"
End If
End Sub
Private Sub Form_Load()
ReDim CustomColors(0 To 16 * 4 - 1) As Byte
Dim i As Integer
For i = LBound(CustomColors) To UBound(CustomColors)
CustomColors(i) = 0
Next i
End Sub
More Info
LongPtr Data Type
LenB Function

AFAIK 32-bit dll's cannot be used by a 64-bit application.
Use comdlg64.dll instead (if there is such a dll).
Using google reveals that there a host of viruses floating around on the net by that name.
So if comdlg64.dll is not on your machine don't download it from the net!
(Unless you want to experience zombieness).

Related

Using TaskDialogIndirect in 64-Bit VBA

Problem description
I try to get code working under 64-Bit VBA which works fine in 32-Bit VBA.
It is regarding Common Controls TaskDialogs.
I use Microsoft Access, but the problem should be the same in other VBA hosts.
One part works fine in both (32- and 64-Bit) VBA, the other part doesn't.
TaskDialog API working well in both (32- and 64-Bit) VBA
You can start the procedure TestTaskDlg for a test.
Option Explicit
'Original API definition:
'------------------------
'HRESULT TaskDialog(
' HWND hwndOwner,
' HINSTANCE hInstance,
' PCWSTR pszWindowTitle,
' PCWSTR pszMainInstruction,
' PCWSTR pszContent,
' TASKDIALOG_COMMON_BUTTON_FLAGS dwCommonButtons,
' PCWSTR pszIcon,
' int *pnButton
');
Private Declare PtrSafe Function TaskDialog Lib "Comctl32.dll" _
(ByVal hWndParent As LongPtr, _
ByVal hInstance As LongPtr, _
ByVal pszWindowTitle As LongPtr, _
ByVal pszMainInstruction As LongPtr, _
ByVal pszContent As LongPtr, _
ByVal dwCommonButtons As Long, _
ByVal pszIcon As LongPtr, _
ByRef pnButton As Long _
) As Long
'Works fine with 32-Bit VBA and 64-Bit VBA:
Public Sub TestTaskDlg()
Debug.Print TaskDlg("Title", "MainInstructionText", "ContentText")
End Sub
Public Function TaskDlg( _
sWindowTitle As String, _
sMainInstruction As String, _
sContent As String _
) As Long
On Local Error GoTo Catch
Dim clickedButton As Long
TaskDlg = TaskDialog(0, _
0, _
StrPtr(sWindowTitle), _
StrPtr(sMainInstruction), _
StrPtr(sContent), _
0, _
0, _
clickedButton)
Debug.Print "Clicked button:", clickedButton
Done:
Exit Function
Catch:
MsgBox Err.Description, , Err.Number
Resume Done
End Function
TaskDialogIndirect API working well only in 32-Bit VBA
You can start the procedure TestTaskDlgIndirect for a test.
In 64-Bit VBA it returns E_INVALIDARG (0x80070057 | -2147024809), pointing to invalid arguments somehow...
If I use Len() instead of LenB() and comment this three lines of code, it shows a proper (empty) dialog, so the call of TaskDialogIndirect should be correct.
tdlgConfig.pszWindowTitle = StrPtr(sWindowTitle)
tdlgConfig.pszMainInstruction = StrPtr(sMainInstruction)
tdlgConfig.pszContent = StrPtr(sContent)
Does anybody have an idea why it is not working in 64-bit VBA?
In my opinion I already converted the types from Long to LongPtr properly.
I expect it is a problem with the values/pointers which will be stored in the structure at runtime.
Maybe some Hi-/Low-Byte stuff?
Any help appreciated. :-)
Option Explicit
'Original API definition:
'------------------------
'typedef struct _TASKDIALOGCONFIG {
' UINT cbSize;
' HWND hwndParent;
' HINSTANCE hInstance;
' TASKDIALOG_FLAGS dwFlags;
' TASKDIALOG_COMMON_BUTTON_FLAGS dwCommonButtons;
' PCWSTR pszWindowTitle;
' union {
' HICON hMainIcon;
' PCWSTR pszMainIcon;
' } DUMMYUNIONNAME;
' PCWSTR pszMainInstruction;
' PCWSTR pszContent;
' UINT cButtons;
' const TASKDIALOG_BUTTON *pButtons;
' int nDefaultButton;
' UINT cRadioButtons;
' const TASKDIALOG_BUTTON *pRadioButtons;
' int nDefaultRadioButton;
' PCWSTR pszVerificationText;
' PCWSTR pszExpandedInformation;
' PCWSTR pszExpandedControlText;
' PCWSTR pszCollapsedControlText;
' union {
' HICON hFooterIcon;
' PCWSTR pszFooterIcon;
' } DUMMYUNIONNAME2;
' PCWSTR pszFooter;
' PFTASKDIALOGCALLBACK pfCallback;
' LONG_PTR lpCallbackData;
' UINT cxWidth;
'} TASKDIALOGCONFIG;
Public Type TASKDIALOGCONFIG
cbSize As Long 'UINT
hWndParent As LongPtr 'HWND
hInstance As LongPtr 'HINSTANCE
dwFlags As Long 'TASKDIALOG_FLAGS
dwCommonButtons As Long 'TASKDIALOG_COMMON_BUTTON_FLAGS
pszWindowTitle As LongPtr 'PCWSTR
' Union
' {
hMainIcon As LongPtr 'Union means that the biggest type has to be declared: So LongPtr
' hMainIcon 'HICON
' pszMainIcon 'PCWSTR
' };
pszMainInstruction As LongPtr 'PCWSTR
pszContent As LongPtr 'PCWSTR
cButtons As Long 'UINT
pButtons As LongPtr 'TASKDIALOG_BUTTON *pButtons;
nDefaultButton As Long 'INT
cRadioButtons As Long 'UINT
pRadioButtons As LongPtr 'TASKDIALOG_BUTTON *pRadioButtons;
nDefaultRadioButton As Long 'INT
pszVerificationText As LongPtr 'PCWSTR
pszExpandedInformation As LongPtr 'PCWSTR
pszExpandedControlText As LongPtr 'PCWSTR
pszCollapsedControlText As LongPtr 'PCWSTR
'Union
'{
hFooterIcon As LongPtr 'Union means that the biggest type has to be declared: So LongPtr
' hFooterIcon 'HICON
' pszFooterIcon 'PCWSTR
'};
pszFooter As LongPtr 'PCWSTR
pfCallback As LongPtr 'PFTASKDIALOGCALLBACK
lpCallbackData As LongPtr 'LONG_PTR
cxWidth As Long 'UINT
End Type
'Original API definition:
'------------------------
'HRESULT TaskDialogIndirect(
' const TASKDIALOGCONFIG *pTaskConfig,
' int *pnButton,
' int *pnRadioButton,
' BOOL *pfVerificationFlagChecked
');
Private Declare PtrSafe Function TaskDialogIndirect Lib "Comctl32.dll" ( _
ByRef pTaskConfig As TASKDIALOGCONFIG, _
ByRef pnButton As Long, _
ByRef pnRadioButton As Long, _
ByRef pfVerificationFlagChecked As Long _
) As Long
'Works fine with 32-Bit VBA. But with 64-Bit VBA it returns E_INVALIDARG (0x80070057 | -2147024809)
Public Sub TestTaskDlgIndirect()
Debug.Print TaskDlgIndirect("Title", "MainInstructionText", "ContentText")
End Sub
Public Function TaskDlgIndirect( _
sWindowTitle As String, _
sMainInstruction As String, _
sContent As String _
) As Long
On Local Error GoTo Catch
Dim tdlgConfig As TASKDIALOGCONFIG
tdlgConfig.cbSize = LenB(tdlgConfig)
'Usually LenB() should be the right way to use, but when I use Len() and comment the three texts below, it shows a proper empty dialog!
tdlgConfig.pszWindowTitle = StrPtr(sWindowTitle)
tdlgConfig.pszMainInstruction = StrPtr(sMainInstruction)
tdlgConfig.pszContent = StrPtr(sContent)
Dim clickedButton As Long
Dim selectedRadio As Long
Dim verificationFlagChecked As Long
TaskDlgIndirect = TaskDialogIndirect(tdlgConfig, clickedButton, _
selectedRadio, verificationFlagChecked)
Debug.Print "Clicked button:", clickedButton
Done:
Exit Function
Catch:
MsgBox Err.Description, , Err.Number
Resume Done
End Function
Update
Some new insights:
It seems that TASKDIALOGCONFIG uses a 1-byte packing internally.
In 32-bit VBA (which uses 4-byte padding for structs) this didn't matter because all members of the struct were of type Long and so 4 byte, so no padding occured at all.
Also in this constellation there is no difference in using Len(tdlgConfig), which calculates the sum of the datatypes only, and LenB(tdlgConfig), which calculates the real size of the struct indeed.
Both result in 96 bytes here.
But in 64-bit VBA (which uses 8-byte padding for structs) some members of the struct are of type Long (4 byte) and some are LongLong (8 byte) (declared as LongPtr for 32-bit compatibility).
This results to VBA applies padding and that is the reason why Len(tdlgConfig) returns 160 and LenB(tdlgConfig) 176.
So because my test without providing any texts (commenting the mentioned 3 lines of code) displays a dialog only when I use Len(tdlgConfig) (instead of LenB(tdlgConfig)) leads to the same conclusion, that the 64-bit API expects a structure of 160 bytes only.
So to provide a struct of 160 bytes I used this for a test:
Public Type TASKDIALOGCONFIG
cbSize As Long
dummy2 As Long
dummy3 As Long
dummy4 As Long
dummy5 As Long
dummy6 As Long
dwCommonButtons As Long
dummy8 As Long
dummy9 As Long
dummy10 As Long
dummy11 As Long
dummy12 As Long
dummy13 As Long
dummy14 As Long
dummy15 As Long
dummy16 As Long
dummy17 As Long
dummy18 As Long
nDefaultButton As Long
dummy20 As Long
dummy21 As Long
dummy22 As Long
dummy23 As Long
dummy24 As Long
dummy25 As Long
dummy26 As Long
dummy27 As Long
dummy28 As Long
dummy29 As Long
dummy30 As Long
dummy31 As Long
dummy32 As Long
dummy33 As Long
dummy34 As Long
dummy35 As Long
dummy36 As Long
dummy37 As Long
dummy38 As Long
dummy39 As Long
dummy40 As Long
End Type
Now both, Len(tdlgConfig) and LenB(tdlgConfig) return 160.
Calling the empty dialog without texts still runs well.
And I now can set dwCommonButtons and nDefaultButton (both type Long) and it works correct so far.
For example:
Public Enum TD_COMMON_BUTTON_FLAGS
TDCBF_OK_BUTTON = &H1& '// Selected control returns value IDOK
TDCBF_YES_BUTTON = &H2& '// Selected control returns value IDYES
TDCBF_NO_BUTTON = &H4& '// Selected control returns value IDNO
TDCBF_CANCEL_BUTTON = &H8& '// Selected control returns value IDCANCEL
TDCBF_RETRY_BUTTON = &H10& '// Selected control returns value IDRETRY
TDCBF_CLOSE_BUTTON = &H20& '// Selected control returns value IDCLOSE
End Enum
'typedef DWORD TASKDIALOG_COMMON_BUTTON_FLAGS; // Note: _TASKDIALOG_COMMON_BUTTON_FLAGS is an int
Public Enum TD_COMMON_BUTTON_RETURN_CODES
IDOK = 1
IDCANCEL = 2
IDRETRY = 4
IDYES = 6
IDNO = 7
IDCLOSE = 8
End Enum
tdlgConfig.dwCommonButtons = TDCBF_YES_BUTTON Or TDCBF_NO_BUTTON
tdlgConfig.nDefaultButton = IDNO
So I can expect the size of the struct is fine and now I have to find out how to set the LongLong (LongPtr) types...
Finally I got it working to set the icon to be used and a string in the struct in 64-Bit VBA.
This is the new struct, where I named the members for the main icon and the main instruction text additionally:
Public Type TASKDIALOGCONFIG
cbSize As Long
dummy2 As Long
dummy3 As Long
dummy4 As Long
dummy5 As Long
dummy6 As Long
dwCommonButtons As Long
dummy8 As Long
dummy9 As Long
hMainIcon1 As Long
hMainIcon2 As Long
pszMainInstruction1 As Long
pszMainInstruction2 As Long
dummy14 As Long
dummy15 As Long
dummy16 As Long
dummy17 As Long
dummy18 As Long
nDefaultButton As Long
dummy20 As Long
dummy21 As Long
dummy22 As Long
dummy23 As Long
dummy24 As Long
dummy25 As Long
dummy26 As Long
dummy27 As Long
dummy28 As Long
dummy29 As Long
dummy30 As Long
dummy31 As Long
dummy32 As Long
dummy33 As Long
dummy34 As Long
dummy35 As Long
dummy36 As Long
dummy37 As Long
dummy38 As Long
dummy39 As Long
dummy40 As Long
End Type
Because the LongLong values in the struct now all are split into separate Long values, I couldn't set them in a common way.
With some try and error I found a way to set the icon. It is enough to set the first Long value in the same way it has to be done in 32-Bit VBA:
Const TD_SECURITY_ICON_OK As Integer = -8
tdlgConfig.hMainIcon1 = &HFFFF And TD_SECURITY_ICON_OK
Setting the pointer to a string also was a bit tricky. I finally declare the CopyMemory API sub...
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
ByVal destination As LongPtr, _
ByVal source As LongPtr, _
ByVal dataLength As LongPtr)
...and use it like this to set a string reference in the struct:
CopyMemory VarPtr(tdlgConfig.pszMainInstruction1), VarPtr(StrPtr("My main instruction")), 8
Finally I can use the function TaskDialogIndirect like this:
Dim clickedButton As Long
Dim selectedRadio As Long
Dim verificationFlagChecked As Long
Call TaskDialogIndirect(tdlgConfig, clickedButton, _
selectedRadio, verificationFlagChecked)
Debug.Print "Clicked button:", clickedButton
The rest is pure diligence to set the other texts etc. and make the code executable for 32-bit and 64-bit using case distinctions.
Thanks again to GSerg for replying.
This is an old thread at this point but since I was just making a TaskDialogIndirect class I wanted to be compatible with VBA7x64, I came across it and saw there's a lot of misunderstandings that were never cleared up. I've had a hell of a time in the past year dealing with all sorts of packing/alignment issues as I move code to 64bit, so thought I good explainer was in order for anyone else who stumbles upon this question.
VBA will pad the structure under x64. That's the correct behavior-- not because every API expects unpadded structures, as GSerg suggested, but because this API does. If you look in the SDK header where these things are defined, CommCtrl.h, right before the Task Dialog definitions, you'll see this:
#include <pshpack1.h>
Then after the Task Dialogs,
#include <poppack.h>
What these headers do is adjust the alignment. pshpack1 means no packing is applied from the point where it's included to where poppack restores the default native packing rules. So this API, unlike most APIs, requires an unpadded structure. It's fairly uncommon for this to be the case; I don't know why it is here, but it is.
VBA does not provide any option to not pad a structure. So that means using an 8 byte data type is not going to work. But the API interprets the structure according to how it thinks the memory is laid out.
As to the link to the URL_COMPONENTS, I don't know what else was done, maybe it's actually 32bit Office and the structure is passed through without WOW64 converting it (like the event trace API), but you can verify the LenB and offsets are all the same with or without those padding members.
I found the easiest way to implement this API was to just declare
#If VBA7 Then
#If (Win64 <> 0) And (TWINBASIC = 0) Then
Private Type TASKDIALOG_BUTTON_VBA7
data(11) As byte
End Type
Private Type TASKDIALOGCONFIG_VBA7
data(159) As Byte
End Type
Private m_uButtons_VBA7() As TASKDIALOG_BUTTON_VBA7
Private m_uRadioButtons_VBA7() As TASKDIALOG_BUTTON_VBA7
Private uTDC_VBA7 As TASKDIALOGCONFIG_VBA7
Those are the correct, packing free sizes.
The normal structure still there for all other modes (twinBASIC is a 100% compatible successor to VB6/VBA supporting building 64bit exes using VBA7 syntax), right before calling the API, I copy all of the regular structure to their correct offsets, including the button arrays:
#If (VBA7 <> 0) And (TWINBASIC = 0) And (Win64 <> 0) Then
'Special handling for 64bit VBA7, which doesn't support our manually aligned structure.
ReDim m_uButtons_VBA7(uTDC.cButtons)
Dim i As Long
If uTDC.cButtons Then
For i = 0 to uTDC.cButtons - 1
CopyMemory m_uButtons_VBA7(i).data(0), m_uButtons(i).nButtonID, 4
CopyMemory m_uButtons_VBA7(i).data(4), m_uButtons(i).pszButtonText, 8
next i
End If
ReDim m_uRadioButtons_VBA7(uTDC.cRadioButtons)
If uTDC.cRadioButtons Then
For i = 0 to uTDC.cRadioButtons - 1
CopyMemory m_uRadioButtons_VBA7(i).data(0), m_uRadioButtons(i).nButtonID, 4
CopyMemory m_uRadioButtons_VBA7(i).data(4), m_uRadioButtons(i).pszButtonText, 8
next i
End If
Dim ptrBtn As LongPtr, ptrRbn As LongPtr
ptrBtn = VarPtr(m_uButtons_VBA7): ptrRbn = VarPtr(m_uRadioButtons_VBA7)
CopyMemory uTDC_VBA7.data(0), uTDC.cbSize, 4: CopyMemory uTDC_VBA7.data(4), uTDC.hWndParent, 8: CopyMemory uTDC_VBA7.data(12), uTDC.hInstance, 8
CopyMemory uTDC_VBA7.data(16), uTDC.dwFlags, 4: CopyMemory uTDC_VBA7.data(20), uTDC.dwCommonButtons, 4: CopyMemory uTDC_VBA7.data(24), uTDC.pszWindowTitle, 8
CopyMemory uTDC_VBA7.data(32), uTDC.pszMainIcon, 8: CopyMemory uTDC_VBA7.data(40), uTDC.pszMainInstruction, 8: CopyMemory uTDC_VBA7.data(48), uTDC.pszContent, 8
CopyMemory uTDC_VBA7.data(56), uTDC.cButtons, 4: CopyMemory uTDC_VBA7.data(60), ptrBtn, 8: CopyMemory uTDC_VBA7.data(68), uTDC.nDefaultButton, 4
CopyMemory uTDC_VBA7.data(72), uTDC.cRadioButtons, 4: CopyMemory uTDC_VBA7.data(76), ptrRbn, 8: CopyMemory uTDC_VBA7.data(84), uTDC.nDefaultRadioButton, 4
CopyMemory uTDC_VBA7.data(88), uTDC.pszVerificationText, 8: CopyMemory uTDC_VBA7.data(96), uTDC.pszExpandedInformation, 8: CopyMemory uTDC_VBA7.data(104), uTDC.pszExpandedControlText, 8
CopyMemory uTDC_VBA7.data(112), uTDC.pszCollapsedControlText, 8: CopyMemory uTDC_VBA7.data(120), uTDC.pszFooterIcon, 8: CopyMemory uTDC_VBA7.data(128), uTDC.pszFooter, 8
CopyMemory uTDC_VBA7.data(136), uTDC.pfCallback, 8: CopyMemory uTDC_VBA7.data(144), uTDC.lpCallbackData, 8: CopyMemory uTDC_VBA7.data(156), uTDC.CXWidth, 4
hr = TaskDialogIndirect_VBA7(uTDC_VBA7, pnButton, pnRadButton, pfVerify)
#Else
hr = TaskDialogIndirect(uTDC, pnButton, pnRadButton, pfVerify)
#End If
(If you wanted to see the full class, it's on GitHub)

Get Window position of a Visio Application

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

Run Time error 5

Function GetUNC(strMappedDrive As String) As String
Dim objFso As FileSystemObject
Set objFso = New FileSystemObject
Dim strDrive As String
Dim strShare As String
'Separated the mapped letter from
'any following sub-folders
strDrive = objFso.GetDriveName(strMappedDrive)
'find the UNC share name from the mapped letter
strShare = objFso.Drives(strDrive).ShareName '<<<< this is the line that the code fails on
'The Replace function allows for sub-folders
'of the mapped drive
GetUNC = Replace(strMappedDrive, strDrive, strShare)
Set objFso = Nothing 'Destroy the object
End Function
It works fine on my laptop and network, but when a colleague uses the same spreadsheet with the same code on their laptop and network the code throws a run-time error 5 exception 'invalid procedure call or argument' at the following line:
strShare = objFso.Drives(strDrive).ShareName
When I hover over the line of code I see: when I run the code to this point I see a file path.
My colleague has tried running the code on his local drive as well as a network drive with no success. We both have the same references selected as well. Does anyone know what I need to do to get this working on my colleagues machine?
Not entirely sure what the issue is, but it might be worth using an API call instead:
#If Win64 Then
Declare PtrSafe Function WNetGetConnection32 Lib "MPR.DLL" Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, lSize As Long) As Long
#Else
Declare Function WNetGetConnection32 Lib "MPR.DLL" Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, lSize As Long) As Long
#End If
Dim lpszRemoteName As String * lBUFFER_SIZE
Dim lSize As Long
Const NO_ERROR As Long = 0&
Const lBUFFER_SIZE As Long = 255&
Function GetUNC(ByRef strDriveLetter As String) As String
strDriveLetter = UCase$(strDriveLetter) & ":"
GetUNC = IIf(WNetGetConnection32(strDriveLetter, lpszRemoteName, lBUFFER_SIZE) = NO_ERROR, lpszRemoteName, "Error")
End Function
Then simply use something like:
MsgBox GetUNC("S")

VBA and GetRawInputDeviceList

I am working in Access 2013 and try to get GetRawInputDeviceList, GetRawInputDeviceInfo, RegisterRawInputDevices and GetRawInputData equivalents for VBA with no success. I have also searched in vain for a procedure, function or module to get a list of connected HID devices to a computer to pick out a barcode scanner. This is the beginning of the third week so I am on my knees begging for assistance. Do any of you all have a module you're willing to share, a link to a website where this is dealt with? Any help is greatly appreciated.
Using the GetRawInputDeviceList API from VBA would be pretty tricky because of the pRawInputDeviceList parameter. Unless you're willing to jump through a ton of hoops to manage your own memory and manually handle the resulting array of RAWINPUTDEVICELIST in raw memory, you'll be better off coming at this from another direction.
Most barcode scanners I've dealt with present themselves to Windows as a keyboard. One possible solution would be to use a WMI query to enumerate attached Win32_Keyboard devices:
Private Sub ShowKeyboardInfo()
Dim WmiServer As Object
Dim ResultSet As Object
Dim Keyboard As Object
Dim Query As String
Query = "SELECT * From Win32_Keyboard"
Set WmiServer = GetObject("winmgmts:root/CIMV2")
Set ResultSet = WmiServer.ExecQuery(Query)
For Each Keyboard In ResultSet
Debug.Print Keyboard.Name & vbTab & _
Keyboard.Description & vbTab & _
Keyboard.DeviceID & vbTab & _
Keyboard.Status
Next Keyboard
End Sub
Note: If it doesn't turn up there, you can enumerate all of the USB devices by querying CIM_USBDevice: Query = "SELECT * From Win32_Keyboard"
EDIT: Per the comments, the above code won't return the handle needed to register to receive raw input events. This should get you started though - the RegisterRawInputDevices and GetRawInputData aspects are beyond the scope of what will easily go in an answer. Take a hack at it, and if you run into any problems post your code in another question.
Declarations:
Private Type RawInputDeviceList
hDevice As Long
dwType As Long
End Type
Private Type RidKeyboardInfo
cbSize As Long
dwType As Long
dwKeyboardMode As Long
dwNumberOfFunctionKeys As Long
dwNumberOfIndicators As Long
dwNumberOfKeysTotal As Long
End Type
Private Enum DeviceType
TypeMouse = 0
TypeKeyboard = 1
TypeHID = 2
End Enum
Private Enum DeviceCommand
DeviceName = &H20000007
DeviceInfo = &H2000000B
PreParseData = &H20000005
End Enum
Private Declare Function GetRawInputDeviceList Lib "user32" ( _
ByVal pRawInputDeviceList As Long, _
ByRef puiNumDevices As Long, _
ByVal cbSize As Long) As Long
Private Declare Function GetRawInputDeviceInfo Lib "user32" Alias "GetRawInputDeviceInfoW" ( _
ByVal hDevice As Long, _
ByVal uiCommand As Long, _
ByVal pData As Long, _
ByRef pcbSize As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Sample of retrieving device names with GetRawInputDeviceInfo:
Private Sub SampleCode()
Dim devices() As RawInputDeviceList
devices = GetRawInputDevices
Dim i As Long
For i = 0 To UBound(devices)
'Inspect the type - only looking for a keyboard.
If devices(i).dwType = TypeKeyboard Then
Dim buffer As String
Dim size As Long
'First call with a null pointer returns the string length in size.
If GetRawInputDeviceInfo(devices(i).hDevice, DeviceName, 0&, size) = -1 Then
Debug.Print "GetRawInputDeviceInfo error " & GetLastError()
Else
'Size the string buffer.
buffer = String(size, Chr$(0))
'The second call copies the name into the passed buffer.
If GetRawInputDeviceInfo(devices(i).hDevice, DeviceName, StrPtr(buffer), size) = -1 Then
Debug.Print "GetRawInputDeviceInfo error " & GetLastError()
Else
Debug.Print buffer
End If
End If
End If
Next i
End Sub
Private Function GetRawInputDevices() As RawInputDeviceList()
Dim devs As Long
Dim output() As RawInputDeviceList
'First call with a null pointer returns the number of devices in devs
If GetRawInputDeviceList(0&, devs, LenB(output(0))) = -1 Then
Debug.Print "GetRawInputDeviceList error " & GetLastError()
Else
'Size the output array.
ReDim output(devs - 1)
'Second call actually fills the array.
If GetRawInputDeviceList(VarPtr(output(0)), devs, LenB(output(0))) = -1 Then
Debug.Print "GetRawInputDeviceList error " & GetLastError()
Else
GetRawInputDevices = output
End If
End If
End Function
Sorry about the side scrolling.

How to register a type library in VBA

I am trying to register a type library programatically from VBA code, using two variants of a technique found using Google (Subs RegisterTypeLibrary and RegisterTypeLibrary2 below).
The code below crashes with an access violation on the call to LoadTypeLib / LoadTypeLibEx. What am I doing wrong? In case it's relevant, the type library is a TLB file generated from a .NET assembly using tlbexp.
Private Enum RegKind
RegKind_Default = 0
RegKind_Register = 1
RegKind_None = 2
End Enum
Private Declare Function LoadTypeLibEx Lib "oleaut32.dll" ( _
pFileName As Byte, ByVal RegKind As RegKind, pptlib As Object) As Long
Private Declare Function LoadTypeLib Lib "oleaut32.dll" ( _
pFileName As Byte, pptlib As Object) As Long
Private Declare Function RegisterTypeLib Lib "oleaut32.dll" ( _
ByVal ptlib As Object, szFullPath As Byte, _
szHelpFile As Byte) As Long
Private Sub RegisterTypeLibrary(FileName As String)
Dim abNullTerminatedFileName() As Byte
Dim objTypeLib As Object
Dim lHResult As Long
abNullTerminatedFileName = FileName & vbNullChar
lHResult = LoadTypeLib(abNullTerminatedFileName(0), objTypeLib)
If lHResult <> 0 Then
Err.Raise lHResult, "LoadTypeLib", "Error registering type library " & FileName
End If
lHResult = RegisterTypeLib(objTypeLib, abNullTerminatedFileName(0), 0)
If lHResult <> 0 Then
Err.Raise lHResult, "RegisterTypeLib", "Error registering type library " & FileName
End If
Exit Sub
End Sub
Private Sub RegisterTypeLibrary2(FileName As String)
Dim abNullTerminatedFileName() As Byte
Dim objTypeLib As Object
Dim lHResult As Long
abNullTerminatedFileName = FileName & vbNullChar
lHResult = LoadTypeLibEx(abNullTerminatedFileName(0), ByVal RegKind_Register, objTypeLib)
If lHResult <> 0 Then
Err.Raise lHResult, "LoadTypeLibEx", "Error registering type library " & FileName
End If
End Sub
EDIT
I suspect it is something specific about my type library. I've found a solution which I've posted as an answer below.
I've found a solution, using the code below. Basically, the third parameter to LoadTypeLibEx (ITypeLib** in C/C++) is declared as stdole.IUnknown instead of as Object.
To do so, I needed to add a reference to stdole32.tlb to the VBA project.
I suspect there is something about my type library that means it can't be declared as a VB (late-bound) Object.
I could also have declared the third parameter as Long, but I'm not sure that wouldn't lead to problems with reference counting.
Private Enum RegKind
RegKind_Default = 0
RegKind_Register = 1
RegKind_None = 2
End Enum
Private Declare Function LoadTypeLibEx Lib "oleaut32.dll" ( _
pFileName As Byte, ByVal RegKind As RegKind, pptlib As stdole.IUnknown) As Long
Public Sub RegisterTypeLibrary(FileName As String)
Dim abNullTerminatedFileName() As Byte
Dim objTypeLib As stdole.IUnknown
Dim lHResult As Long
abNullTerminatedFileName = FileName & vbNullChar
lHResult = LoadTypeLibEx(abNullTerminatedFileName(0), ByVal RegKind_Register, objTypeLib)
If lHResult <> 0 Then
Err.Raise lHResult, "LoadTypeLibEx", "Error registering type library " & FileName
End If
End Sub
I suspect your type library (TLB) has errors because the code you provided works when I tested against a third-party TLB.
I am assuming you are going to use your .NET Assembly from VBA. Therefore, I suggest you make sure you can reference your TLB from VBA without errors.
Note, that all objects exposed by your .NET library must have public constructors that accept no arguments. This may be causing the problem.