Visio VBA Alternative to xlDialogueEditColor

[matthew]

Hi,
I want to update my existing VBA app by using a couple of userforms.  One of these will have ask the user to pick a colour to use with the app.  I was hoping to use the Visio alternative to the excel color picker xlDialogueEditColor but it seems from the posts I've read this may not be possible.  Can someone please advise how I can pick a color via a userform?  Is this even possible? 
Kind regards
Matthew

[Machine]

I'm interested as well.
Was trying to use Excel dialogs (after adding references), but couldn't make it work.
If anyone have working implementation of a color picker for Visio, would be great.

[wapperdude]

Some related links:
http://www.visguy.com/2010/05/14/get-web-hex-color-values-from-visio-shapes/
https://visualsignals.typepad.co.uk/vislog/2012/01/creating-a-color-picker-in-visio.html

wapperdude

[AndyW]

Code Select Expand

Option Explicit

'Hex colours Blue/Green/Red

Private Type ChooseColorStruct
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As Long
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" _
    (lpChoosecolor As ChooseColorStruct) As Long
   
Private Const CC_RGBINIT = &H1&
Private Const CC_FULLOPEN = &H2&
'Private Const CC_PREVENTFULLOPEN = &H4&
'Private Const CC_SHOWHELP = &H8&
'Private Const CC_ENABLEHOOK = &H10&
'Private Const CC_ENABLETEMPLATE = &H20&
'Private Const CC_ENABLETEMPLATEHANDLE = &H40&
Private Const CC_SOLIDCOLOR = &H80&
Private Const CC_ANYCOLOR = &H100&
Private Const CLR_INVALID = &HFFFF

Public Function colourToRGBFormula( _
    ByVal lngColour As Long) As String
   
    colourToRGBFormula = "RGB(" & _
                            (lngColour And &HFF&) & "," & _
                            (lngColour And &HFF00&) \ &H100 & "," & _
                            (lngColour And &HFF0000) \ &H10000 & ")"
   
End Function

Public Function RGBFormulaToColour( _
    ByRef strRGB As String) As Long
   
    Dim re As RegExp
    Dim strToken() As String
   
    Set re = New RegExp
   
    re.Global = True
    re.Pattern = "[^0-9,]"
   
    strToken = Split(re.Replace(strRGB, vbNullString), ",")
   
    If UBound(strToken) = 2 Then
   
        RGBFormulaToColour = RGB(strToken(0), strToken(1), strToken(2))
       
    End If
   
End Function
   
Public Function TranslateColor( _
    ByVal oClr As OLE_COLOR, _
    Optional hPal As Long = 0) As Long
   
    ' Convert Automation color to Windows color
    Const CLR_INVALID = -1
   
    If OleTranslateColor(oClr, hPal, TranslateColor) Then
        TranslateColor = CLR_INVALID
    End If

End Function

' Show the common dialog for choosing a color.
' Return the chosen color, or -1 if the dialog is canceled
'
' hParent is the handle of the parent form
' bFullOpen specifies whether the dialog will be open with the Full style
' (allows to choose many more colors)
' InitColor is the color initially selected when the dialog is open

' Example:
'    Dim oleNewColor As OLE_COLOR
'    oleNewColor = ShowColorsDialog(Me.hwnd, True, vbRed)
'    If oleNewColor <> -1 Then Me.BackColor = oleNewColor

Function ShowColorDialog( _
    Optional ByVal hParent As Long, _
    Optional ByVal bFullOpen As Boolean, _
    Optional ByVal InitColor As OLE_COLOR) As Long
   
    Dim cc As ChooseColorStruct
    Dim aColorRef(15) As Long
    Dim lInitColor As Long
   
    ' translate the initial OLE color to a long value
    On Error GoTo ShowColorDialog_Error

    If InitColor <> 0 Then
        If OleTranslateColor(InitColor, 0, lInitColor) Then
            lInitColor = CLR_INVALID
        End If
    End If
       
    'Add used colour to custom in case it is not present.
   
    aColorRef(1) = lInitColor
   
    'fill the ChooseColorStruct struct
    With cc
        .lStructSize = Len(cc)
        .hwndOwner = hParent
        .lpCustColors = VarPtr(aColorRef(0))
        .rgbResult = lInitColor
        .flags = CC_SOLIDCOLOR Or CC_ANYCOLOR Or CC_RGBINIT Or IIf(bFullOpen, CC_FULLOPEN, 0)
    End With
   
    ' Show the dialog
    If ChooseColor(cc) Then
        'if not canceled, return the color
        ShowColorDialog = cc.rgbResult
    Else
        'else return -1
        ShowColorDialog = -1
    End If

ShowColorDialog_Exit:

    On Error GoTo 0

    Exit Function

ShowColorDialog_Error:

    'Err.Source = "Module: MDiagramColours.ShowColorDialog"
    'Call errorHandler(Err)

    Resume ShowColorDialog_Exit
   
End Function





[matthew]

thanks Andy and wapperdude, I'll have a go with the code at the weekend, I saw those links before but not quite what I was after, I'll maybe think about taking a different approach to this until it becomes a VSTO (which is beyond me)
thanks again
Matthew