Discussion :

[Carabistouilleur]

Bonjour.
Je sais vous allez vous dire "encore un qui ne fait aucune recherche de sources sur le site"
Mais là je sèche.
Je souhaite dans mon outil(application c'est plus joli) que l'utilisateur choisisse une couleur pour un certain paramètre donné via une boite de dialogue de sélection de couleur.
Puis ensuite, par le code enrichir une table de ce type:


Bien sûr je me suis basé sur ceci : https://access.developpez.com/source...ndlg#ShowColor

Voici mon code (dans la module du formulaire) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
Option Compare Database
Private Declare PtrSafe Function CHOOSECOLOR Lib "comdlg32.dll" Alias _
"ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
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 Sub Commande0_Click()
Dim lacouleur As Long
lacouleur = ShowColor(Me.Hwnd)
'Debug.Print lacouleur
End Sub
 
 
Public Function ShowColor(Handle As Long) As Long
    Dim cc As CHOOSECOLOR
    Dim Custcolor(16) As Long
    Dim lReturn As Long
 
    'set the structure size
    cc.lStructSize = Len(cc)
    'Set the owner
    cc.hwndOwner = Handle
    'set the custom colors (converted to Unicode)
    cc.lpCustColors = StrConv(CustomColors, vbUnicode)
    'no extra flags
    cc.flags = 0
 
    'Show the 'Select Color'-dialog
    If CHOOSECOLOR(cc) <> 0 Then
        ShowColor = cc.rgbResult
        CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
    Else
        ShowColor = -1
    End If
End Function

La valeur de lacouleur reste à -1, aucune boite de dialogue de sélection de couleur ne s'affiche...
Quel est le soucis svp ?
Merci.
Cordialement.
Pour info je joins le fichier:
Palette_couleur_DPC.zip

[Thumb down]

Bonjour,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Type Font
    FontName As String
    FontBold As Boolean
    FontItalic As Boolean
    FontSize As Single
    Strikethrough As Boolean
End Type
Public Property Get GetFont() As Font
With CreateObject("MSComDlg.CommonDialog")
    .showfont
       GetFont.FontBold = .FontBold
       GetFont.FontItalic = .FontItalic
       GetFont.FontName = .FontName
       GetFont.FontSize = .FontSize
       GetFont.Strikethrough = .FontStrikethru
End With
End Property
Public Property Get GetColor() As OLE_COLOR
Dim C As OLE_COLOR
With CreateObject("MSComDlg.CommonDialog")
    .CancelError = True
    On Error Resume Next
    .ShowColor
    If Err Then
       GetColor = -1
    Else
       GetColor = .Color
    End If
    On Error GoTo 0
End With
End Property
Property Get GetFichier(Optional Filter = "*.*") As String
With CreateObject("MSComDlg.CommonDialog")
    .Filter = Filter
    .ShowOpen
   GetFichier = .Filename
End With
 
End Property
 
Sub test()
Dim Fich As String, Fon As Font, Coul As OLE_COLOR
Fich = GetFichier("Image ( *.jpg)|*.jpg|Image ( *.gif)|*.gif|Image (*.bmp)|*.bmp")
Fon = GetFont
Coul = GetColor
End Sub

[Carabistouilleur]

Bonjour et merci pour la réponse.

J'ai cette erreur :


sur cette ligne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

With CreateObject("MSComDlg.CommonDialog")

Ne manque-t-il pas une référence ? Voici ma conf actuelle :


Merci.

PS : on est bien d'accord que le but est d'afficher une boite de dialogue de ce type :



?
Merci.

[Thumb down]

Bonjour,
Désolé, c'est pourtant ce que j'utilise, bizarre.

Createobject permet de créer une instance d'objets sans activer sa référence.

[Carabistouilleur]

Bonjour,
Désolé, c'est pourtant ce que j'utilise, bizarre.

Createobject permet de créer une instance d'objets sans activer sa référence.

C'est l'argument "MSComDlg.CommonDialog" et non la fonction Createobject qui coince. Je vais chercher de mon côté. Merci pour la capture, c'est exactement ce que je veux.
(ma version Office : 2021 pro +)
A+

[nemog]

Bonjour, je suis loin d' être un expert, mais j' avais pas mal galéré à une époque pour la même chose
et avec de l' aide ici et ailleurs, j'utilise ça :

Dans un module :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Option Compare Database
Option Explicit
 
#If VBA7 Then
Declare PtrSafe Sub ChooseColor Lib "msaccess.exe" _
Alias "#53" ( _
ByVal Hwnd As LongPtr, _
rgb As Long)
#Else
Declare Sub ChooseColor Lib "msaccess.exe" _
  Alias "#53" ( _
  ByVal Hwnd As Long, _
  rgb As Long)
#End If
 
Public Function DialogColor(DefaultColor As Long) As Long
    Dim lngColor As Long
    lngColor = DefaultColor
    ChooseColor Application.hWndAccessApp, lngColor ' Application.hWndAccessApp Screen.ActiveForm.Hwnd
    If lngColor = DefaultColor Then
        DialogColor = -1 ' DefaultColor
    Else
        DialogColor = lngColor
    End If
End Function

Dans le VBA du formulaire, suivant le déclencheur :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
    Dim pLong, pBlue, pRed, pGreen As Long
    Dim clr As Long    
 
 
            clr = DialogColor(Me.Section(0).BackColor)
 
        If clr <> -1 Then 'si on n'a pas appuyé sur Annuler dans la boite de dialogue couleurs
 
            Me.Section(0).BackColor = clr 'change la couleur du formulaire
 
            pLong = Me.Section(0).BackColor 
 
            pBlue = Int(pLong / 65536) ' on récupère les valeurs de R, G et B
            pGreen = Int((pLong - (65536 * pBlue)) / 256)
            pRed = pLong - ((pBlue * 65536) + (pGreen * 256))
 
        End If

Qu'en pensez-vous ?

(en me relisant, je vois que pLong= clr ! on peut encore simplifier )

[Carabistouilleur]

Bonjour, je suis loin d' être un expert, mais j' avais pas mal galéré à une époque pour la même chose
et avec de l' aide ici et ailleurs, j'utilise ça :

Dans un module :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Option Compare Database
Option Explicit
 
#If VBA7 Then
Declare PtrSafe Sub ChooseColor Lib "msaccess.exe" _
Alias "#53" ( _
ByVal Hwnd As LongPtr, _
rgb As Long)
#Else
Declare Sub ChooseColor Lib "msaccess.exe" _
  Alias "#53" ( _
  ByVal Hwnd As Long, _
  rgb As Long)
#End If
 
Public Function DialogColor(DefaultColor As Long) As Long
    Dim lngColor As Long
    lngColor = DefaultColor
    ChooseColor Application.hWndAccessApp, lngColor ' Application.hWndAccessApp Screen.ActiveForm.Hwnd
    If lngColor = DefaultColor Then
        DialogColor = -1 ' DefaultColor
    Else
        DialogColor = lngColor
    End If
End Function

Dans le VBA du formulaire, suivant le déclencheur :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
    Dim pLong, pBlue, pRed, pGreen As Long
    Dim clr As Long    
 
 
            clr = DialogColor(Me.Section(0).BackColor)
 
        If clr <> -1 Then 'si on n'a pas appuyé sur Annuler dans la boite de dialogue couleurs
 
            Me.Section(0).BackColor = clr 'change la couleur du formulaire
 
            pLong = Me.Section(0).BackColor 
 
            pBlue = Int(pLong / 65536) ' on récupère les valeurs de R, G et B
            pGreen = Int((pLong - (65536 * pBlue)) / 256)
            pRed = pLong - ((pBlue * 65536) + (pGreen * 256))
 
        End If

Qu'en pensez-vous ?

(en me relisant, je vois que pLong= clr ! on peut encore simplifier )

Bonjour nemog et merci, ça fonctionne

@thumb-down, le soucis est lié avec l'absence du fichier comdlg32.ocx sur mon pc (bien que je l'ai rétabli, et j'ai toujours une erreur mais différente...je vais continuer d'investiguer).

Voir :

En tout cas je vous remercie tous les deux.
Pourquoi n'y a t'il pas de control activx dédié, il me semble que cela serait beaucoup plus simple..

Bonne journée et bon JO !!