none
Center ChooseColorAPI in center of Application Screen RRS feed

  • Question

  • 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
    Dim CustomColors() As Byte
    Private Declare Function ChooseColorAPI Lib "comdlg32.dll" Alias _
        "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
    Private Declare Function FindWindow Lib "user32" _
        Alias "FindWindowA" (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
    
    Private Sub CallDialog()
    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
      ShowPicker
    End Sub
    Private Function GetWinwordHwnd() As Long
        Dim hWnd As Long
        hWnd = FindWindow("opusApp", vbNullString)
        GetWinwordHwnd = hWnd
    End Function
    
    Private Sub ShowPicker()
        Dim cc As CHOOSECOLOR
        Dim lReturn As Long, Rval As Long
        Dim Gval As Long, Bval As Long
        Dim i As Integer
        cc.lStructSize = Len(cc)
        cc.hwndOwner = GetWinwordHwnd()
        cc.hInstance = 0
        cc.lpCustColors = StrConv(CustomColors, vbUnicode)
        cc.Flags = 0
        ' call the color picker
        lReturn = ChooseColorAPI(cc)
        If lReturn <> 0 Then
            ' extract the color values
            Rval = cc.rgbResult Mod 256
            Bval = Int(cc.rgbResult / 65536)
            Gval = Int((cc.rgbResult - (Bval * 65536) - Rval) / 256)
            MsgBox "RGB Value User Chose: R=" & Str$(Rval) & _
                 "  G=" & Str$(Gval) & "  B=" & Str$(Bval)
            ' save the color values to send to the
            ' color picker for the next iteration
            CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
            ReDim CustomColors(0 To 16 * 4 - 1) As Byte
            For i = LBound(CustomColors) To UBound(CustomColors)
               CustomColors(i) = 0
            Next i
        Else
            MsgBox "User chose the Cancel Button"
        End If
    End Sub

    Hi,

    Then code posted above will display the ChooseColorAPI dialog in the top left corner of the application (Word) screen.  Can someone explain if (and how) it can be shown center screen?  Thank you!


    Greg Maxey Please visit my website at: http://gregmaxey.mvps.org/word_tips.htm

    Thursday, April 12, 2018 6:39 PM

All replies

  • There are other more complex ways but for something simple could attach it to your own window positioned wherever before showing the color picker. In a light test these small changes to your CallDialog and GetWinwordHwnd routines worked for me, oh and add a userform

    Private Sub CallDialog()
    Dim uf As UserForm1
    Dim i As Long ' no point to use As Integer since Win32
    
        ReDim CustomColors(0 To 16 * 4 - 1) As Byte
        For i = LBound(CustomColors) To UBound(CustomColors)
            CustomColors(i) = 0
        Next i
    
        Set uf = New UserForm1
        uf.Left = Application.Left + Application.Width / 3
        uf.Top = Application.Top + Application.Height / 4
        uf.Caption = "GregsDummyWindow" ' a unique caption
    
        ShowPicker
        Unload uf
    End Sub
    
    Private Function GetWinwordHwnd() As Long
        Dim hWnd As Long
        hWnd = FindWindow("ThunderDFrame", "GregsDummyWindow")
        GetWinwordHwnd = hWnd
    End Function


    Thursday, April 12, 2018 9:30 PM
    Moderator
  • Peter, Thank you. Your changes result in an improvement but unfortunately the dialog still appears a bit skewed to the left. I can tinker with the left setting a bit to center it in my personal monitor, but was hoping for a way to show it dead center screen and then if the Define Custom Color is clicked it would relocate (or always remain) center screen. If you think the more complex ways are over my head (you would probably be right) just says so ;-)

    Greg Maxey Please visit my website at: http://gregmaxey.mvps.org/word_tips.htm

    Thursday, April 12, 2018 11:51 PM
  • Only an improvement:)
    I threw it together with a rough guess at the size of the dialog, but easy enough to get its dimensions, something like this show the colorpicker and -

    Dim rct As RECT
    Call GetWindowRect(FindWindow("#32770", "Color"), rct)

    (you'd probably need to do that in separate processes)

    You could get your app window's size in pixels the same way, then you've got all you need. Might need to get the user's screen res if not the default 0.75 points / pixel to convert the pixel dim's to points.

    I didn't mean to infer more complex ways might be over your head! The normal way seems to be with a windows hook but things like that are best reserved for when really necessary, especially in VBA, overkill for this I'd have thought.

    Friday, April 13, 2018 7:33 PM
    Moderator
  • Peter,

    You didn't infer ;-).  I dabble a little with VBA but this stuff "IS" probably over my head.

    E.g., You could get your app window's size in pixels the same way.

    That is over my head.  What way?  Where (what separate process) do these lines go?  What is RECT?  Is GetWindowsRect another API?

    Dim rct As RECT
    Call GetWindowRect(FindWindow("#32770", "Color"), rct

    When I show a userform it has a StartUpPosition 1-CenterOwner property.  I was hoping something like that would exist for this dialog.  I can't imagine why anyone would want it popping up in the top left corner.

    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
    Dim CustomColors() As Byte
    Private Declare Function ChooseColorAPI Lib "comdlg32.dll" Alias _
        "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
    Private Declare Function FindWindow Lib "user32" _
        Alias "FindWindowA" (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
    
    Private Sub CallDialog()
    Dim uf As UserForm1
    Dim i As Long ' no point to use As Integer since Win32
    
        ReDim CustomColors(0 To 16 * 4 - 1) As Byte
        For i = LBound(CustomColors) To UBound(CustomColors)
            CustomColors(i) = 0
        Next i
    
        Set uf = New UserForm1
        uf.Left = Application.Left + Application.Width / 3
        uf.Top = Application.Top + Application.Height / 4
        uf.Caption = "GregsDummyWindow" ' a unique caption
    
        ShowPicker
        Unload uf
    End Sub
    
    Private Function GetWinwordHwnd() As Long
        Dim hWnd As Long
        hWnd = FindWindow("ThunderDFrame", "GregsDummyWindow")
        GetWinwordHwnd = hWnd
    End Function
    Private Sub ShowPicker()
        Dim cc As CHOOSECOLOR
        Dim lReturn As Long, Rval As Long
        Dim Gval As Long, Bval As Long
        Dim i As Integer
        cc.lStructSize = Len(cc)
        cc.hwndOwner = GetWinwordHwnd()
        cc.hInstance = 0
        cc.lpCustColors = StrConv(CustomColors, vbUnicode)
        cc.Flags = 0
        ' call the color picker
        lReturn = ChooseColorAPI(cc)
        If lReturn <> 0 Then
            ' extract the color values
            Rval = cc.rgbResult Mod 256
            Bval = Int(cc.rgbResult / 65536)
            Gval = Int((cc.rgbResult - (Bval * 65536) - Rval) / 256)
            MsgBox "RGB Value User Chose: R=" & Str$(Rval) & _
                 "  G=" & Str$(Gval) & "  B=" & Str$(Bval)
            ' save the color values to send to the
            ' color picker for the next iteration
            CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
            ReDim CustomColors(0 To 16 * 4 - 1) As Byte
            For i = LBound(CustomColors) To UBound(CustomColors)
               CustomColors(i) = 0
            Next i
        Else
            MsgBox "User chose the Cancel Button"
        End If
    End Sub
    
    'Dim rct As RECT
    'Call GetWindowRect(FindWindow("#32770", "Color"), rct)
    


    Greg Maxey Please visit my website at: http://gregmaxey.mvps.org/word_tips.htm

    Saturday, April 14, 2018 12:48 AM
  • Greg,

    To get the color picker size show it in your existing code, then in another application instance (Excel perhaps) run try the following

    Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
    
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
                            ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GetWindowRect Lib "user32" ( _
                            ByVal hwnd As Long, lpRect As RECT) As Long
    
    
    Function GetWindowSize(wdPxls As Long, htPxls As Long, _
                           Optional sClass As String = vbNullString, _
                           Optional sWinCaption As String = vbNullString) As Boolean
    Dim hwnd As Long
    Dim rct As RECT
        hwnd = FindWindow(sClass, sWinCaption)
    
        Call GetWindowRect(hwnd, rct)
        With rct
            wdPxls = .Right - .Left
            htPxls = .Bottom - .Top
        End With
        GetWindowSize = CBool(hwnd)
    End Function
    
    Sub test()
    Dim w As Long, h As Long
    'Show the color picker. In a different instance, Excel perhaps, try this to get its size
    
        ' the color picker window's classname is "#32770"
        ' the caption in US-Eng is "Color" but language dependent, look at the picker and change to
        If GetWindowSize(w, h, "#32770", "Color") Then
            Debug.Print w, h
        End If
    
    End Sub
    

    I got slightly different sizes in different OS, see below

    Adapt Sub CallDialog as in your code above to include the color picker size, and with which to better centre it in your application window

    Private Sub CallDialog()
    Dim uf As UserForm1
    Dim i As Long ' no point to use As Integer since Win32
    ' Slightly different color picker sizes in different OS
    'Const wdPxls As Long = 222, htPxls As Long = 331 ' XP
    'Const wdPxls As Long = 228, htPxls As Long = 327 ' Win7
    'Const wdPxls As Long = 238, htPxls As Long = 338 ' Win10
    Const wdPxls As Long = 230, htPxls As Long = 332 ' rough average
    ' 0.75 is typical points per pixel but best to get the actual in user's systems
    Const ppp As Single = 0.75
    
        ReDim CustomColors(0 To 16 * 4 - 1) As Byte
        For i = LBound(CustomColors) To UBound(CustomColors)
            CustomColors(i) = 0
        Next i
    
        Set uf = New UserForm1
        
        'move the invisible form to where we want the co0lor picker to appear
        uf.Left = Application.Left + (Application.Width - (wdPxls * ppp)) / 2
        uf.Top = Application.Top + (Application.Height - (htPxls * ppp)) / 2
        uf.Caption = "GregsDummyWindow" ' a unique caption
    
        ShowPicker
        Unload uf
    End Sub

    For use in systems where the user has 'larger fonts' in screen settings you will need to get the points/pixel value. Plent of examples in a quick search, though here you could get your app window's pixel height with the GetWindowSize example above and

    ppp = app.width / (app window's pixel width) 
    might only be approximate but probably near enough for this objective

    In passing are you sure you want to clear the custom colors each time. If not, dimension the array in the declarations

    Dim CustomColors(0 To 63) As Long ' 16 * 4 - 1

    and delete the ReDim and loop that resets the colours in your CallDialog routine 

    Also in passing some aspects would need adapting for use in x64, beyond the normal ptrSafe and LongPtr changes

    Monday, April 16, 2018 9:13 AM
    Moderator
  • Peter,

    Thanks,  I'll see if I can apply what you are trying to explain.


    Greg Maxey Please visit my website at: http://gregmaxey.mvps.org/word_tips.htm

    Monday, April 16, 2018 11:07 AM
  • Greg,

    Seems like a userform might be an easier approach?...

    '---
    Jim Cone
    https://goo.gl/IUQUN2
    • Edited by James Cone Tuesday, April 17, 2018 12:43 AM image size
    Monday, April 16, 2018 3:18 PM