Choix d'une couleur

Mouais,

Je n'avais pas bien cherché, j'ai trouvé 172 articles dans Google, mais je n'y comprends pas grand-chose, vous avez toujours le
droit de m'aider :-))))

J-Pierre

Bonjour.

1/ La boîte de dialogue ne s'ouvre pas au milieu de l'écran mais en haut à
gauche

voici le message de Jessy à la même question le 22/9/03:

Voici grace à Gérard Louisjean (gégé) le code que j'ai mis à ma sauce
permettant d'ouvrir la boîte de sélection de fichier au centre de l'écran...

PS : ce code utilise la fonction AdressOf qui n'est pas disponible sous
Access 97 mais pour ceux que ça interresse, j'ai une fonction de
remplacement
pour cette fonction...

Voici le code, pour essayer, il suffit de lancer la fonction :
"OpenFile_EXE()"

'***********************************************
'** Déclaration pour centrage boîte de dialogue FICHIER
Public Const HCBT_ACTIVATE = 5
Public Const WH_CBT = 5

Public hHook As Long

Public Declare Function GetCurrentThreadId Lib "KERNEL32" () As Long

Public Declare Function SetWindowsHookEx Lib "user32" Alias _
"SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, _
ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As
Long) As Long

'** Déclaration pour centrer une boîte de dailogue
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _
lpRect As RECT) As Long

Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long)
As Long

Public Const SM_CXFULLSCREEN = 16
Public Const SM_CYFULLSCREEN = 17

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, _
ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal bRepaint As Long) As Long

Public CntrDialog As Boolean

Public Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
Instance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustomFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Public Declare Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Public Const OFN_AllowMultiSelect = &H200
Public Const OFN_EXPLORER = &H80000
Public Const OFN_LongNames = &H200000

Global Dialogue As OPENFILENAME

Public strFiltre As String
Public strFile As String
Public RetVal As Long

Public Function OpenFile_EXE()
OpenFile "c:"
End Function

Public Function OpenFile(strInitialDir As String, Optional ctrDialogue As
Boolean = True) As String

OpenFile = ""
strFiltre = "Fichiers Word" & Chr$(0) & "*.doc;*txt" & Chr$(0) & _
"Fichiers Access" & Chr$(0) & "*.mdb" & Chr$(0) & _
"Fichiers Excel" & Chr$(0) & "*.xls" & Chr$(0) & _
"Tous les fichiers" & Chr$(0) & "*.*"

If ctrDialogue Or IsMissing(ctrDialogue) Then
Dim Thread As Long
Thread = GetCurrentThreadId()
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProc, 0, Thread)
End If

With Dialogue
.lStructSize = Len(Dialogue)
.lpstrFilter = strFiltre
.lpstrFile = Space(254)
.nMaxFile = 255
.lpstrFileTitle = Space(254)
.nMaxFileTitle = 255
.lpstrInitialDir = strInitialDir
.lpstrTitle = "Recherche d'un fichier"
.Flags = 6148 Or OFN_AllowMultiSelect Or OFN_LongNames Or OFN_EXPLORER
End With

RetVal = GetOpenFileName(Dialogue)

If RetVal >= 1 Then
OpenFile = Dialogue.lpstrFile
Else
OpenFile = ""
Exit Function
End If

End Function

'** Procédure de centrage boîte de dialogue FICHIER
Public Function WinProc(ByVal lMsg As Long, ByVal hwnd As Long, _
ByVal lParam As Long) As Long

If lMsg = HCBT_ACTIVATE Then
CenterDialog hwnd
UnhookWindowsHookEx hHook
End If
WinProc = False

End Function

'** Procédure pour centrer une boîte de dialogue sur le bureau
Public Function CenterDialog(hwnd As Long)
Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer
Dim DlgWidth As Integer, DlgHeight As Integer
GetWindowRect hwnd, WinRect
DlgWidth = WinRect.Right - WinRect.Left
DlgHeight = WinRect.Bottom - WinRect.Top
ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
(ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Function
'***********************************************
--
@+
Raymond Access MVP.
http://access.seneque.free.fr/
http://access2003.free.fr/
http://users.skynet.be/mpfa/charte.htm pour une meilleure
efficacité de tes interventions sur MPFA.


"J-Pierre" <jpberchtold@hotmail.com> a écrit dans le message de
news:e%23B6fDAkDHA.1284@TK2MSFTNGP09.phx.gbl...

Mouais,

Je n'avais pas bien cherché, j'ai trouvé 172 articles dans Google, mais je
n'y comprends pas grand-chose, vous avez toujours le

droit de m'aider :-))))

J-Pierre

Raymond,

J'ai copié bêtement et ça a marché du premier coup. Bravo Raymond.

Maintenant, il va falloir que j'adapte à la boîte de dialogue sélection couleur, mon fameux "ChooseColorA".......
Je reviens pour dire "merci encore" ou bien "au secours......"

J-Pierre

Voilà voilà voilà, on progresse.....

Pour pouvoir réutiliser le code plus facilement, j'ai créé 3 modules standard et 2 formulaires:

------------------------------------------------------------------
module boiteCouleur
------------------------------------------------------------------
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

' Constantes utilisées par ChooseColor
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 dwCustClrs(0 To 15) As Long ' Tableau statique contenant les couleurs personnalisées

Private Declare Function ShowColour Lib "comdlg32.dll" Alias "ChooseColorA" _
(pChoosecolor As CHOOSECOLOR) As Long

Public Function ShowDialogColorBox() As Variant

Dim tChooseColour As CHOOSECOLOR
Dim cnt As Integer
Dim r As Variant

For cnt = 0 To 15
dwCustClrs(cnt) = RGB(255, 255, 255)
Next

Dim Thread As Long
Thread = GetCurrentThreadId()
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProc, 0, Thread)

With tChooseColour
.lStructSize = Len(tChooseColour)
.hwndOwner = hWndAccessApp
.lpCustColors = VarPtr(dwCustClrs(0))
.Flags = CC_ANYCOLOR Or CC_RGBINIT Or CC_FULLOPEN
End With

r = ShowColour(tChooseColour)

If r = 0 Then
ShowDialogColorBox = ""
Else
ShowDialogColorBox = tChooseColour.rgbResult
End If

End Function

----------------------------------------------------------------
module selectionFichier
----------------------------------------------------------------

Public Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
Instance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustomFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Public Declare Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Public Const OFN_AllowMultiSelect = &H200
Public Const OFN_EXPLORER = &H80000
Public Const OFN_LongNames = &H200000

Global Dialogue As OPENFILENAME

Public strFiltre As String
Public RetVal As Long

Public Function OpenFile(strInitialDir As String, Optional ctrDialogue As Boolean = True) As String

OpenFile = ""
strFiltre = "Fichiers Word" & Chr$(0) & "*.doc;*txt" & Chr$(0) & _
"Fichiers Access" & Chr$(0) & "*.mdb" & Chr$(0) & _
"Fichiers Excel" & Chr$(0) & "*.xls" & Chr$(0) & _
"Tous les fichiers" & Chr$(0) & "*.*"

If ctrDialogue Or IsMissing(ctrDialogue) Then
Dim Thread As Long
Thread = GetCurrentThreadId()
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProc, 0, Thread)
End If

With Dialogue
.lStructSize = Len(Dialogue)
.lpstrFilter = strFiltre
.lpstrFile = Space(254)
.nMaxFile = 255
.lpstrFileTitle = Space(254)
.nMaxFileTitle = 255
.lpstrInitialDir = strInitialDir
.lpstrTitle = "Recherche d'un fichier"
.Flags = 6148 Or OFN_AllowMultiSelect Or OFN_LongNames Or OFN_EXPLORER
End With

RetVal = GetOpenFileName(Dialogue)

If RetVal >= 1 Then
OpenFile = Dialogue.lpstrFile
Else
OpenFile = ""
End If

End Function
----------------------------------------------------------------------
module centrerBoite
----------------------------------------------------------------------

Public Const HCBT_ACTIVATE = 5
Public Const WH_CBT = 5

Public hHook As Long

Public Declare Function GetCurrentThreadId Lib "KERNEL32" () As Long

Public Declare Function SetWindowsHookEx Lib "user32" Alias _
"SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, _
ByVal hmod As Long, ByVal dwThreadId As Long) As Long

Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

'** Déclaration pour centrer une boîte de dailogue
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _
lpRect As RECT) As Long

Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Public Const SM_CXFULLSCREEN = 16
Public Const SM_CYFULLSCREEN = 17

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, _
ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal bRepaint As Long) As Long

'** Procédure de centrage boîte de dialogue FICHIER
Public Function WinProc(ByVal lMsg As Long, ByVal hwnd As Long, _
ByVal lParam As Long) As Long

If lMsg = HCBT_ACTIVATE Then
CenterDialog hwnd
UnhookWindowsHookEx hHook
End If

WinProc = False

End Function

'** Procédure pour centrer une boîte de dialogue sur le bureau
Public Function CenterDialog(hwnd As Long)

Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer
Dim DlgWidth As Integer, DlgHeight As Integer

GetWindowRect hwnd, WinRect
DlgWidth = WinRect.Right - WinRect.Left
DlgHeight = WinRect.Bottom - WinRect.Top
ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
(ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Function

-------------------------------------------------------------
formulaire frmBoiteCouleur
------------------------------------------------------------
avec une zone de texte "maCouleur" et un bouton "Commande0"

Le code VBA:

Private Sub Commande0_Click()

Dim codeCouleur As String

codeCouleur = ShowDialogColorBox ' donne le numéro de la couleur

If codeCouleur <> "" Then
Me.maCouleur.BackColor = codeCouleur
Me.maCouleur = codeCouleur
End If

End Sub

Private Sub Form_Load()

Me.maCouleur = Me.maCouleur.BackColor

End Sub
---------------------------------------------------
formulaire frmOpenFile
--------------------------------------------------
avec une zone de texte "maCouleur" et un bouton "Commande0"

Le code VBA:

Private Sub Commande0_Click()

Me.maCouleur = OpenFile("c:")

End Sub

-------------------------------------------------------

Pour ceux qui sont encore là, vous remarquerez que je n'ai pas inventé grand-chose, j'ai recopié et légèrement adapté.........

Et j'ai encore deux questions:

Pour ouvrir la boîte de couleur, j'initialise les couleurs personnalisées à blanc, mais ça ne marche pas. Le code:
For cnt = 0 To 15
dwCustClrs(cnt) = RGB(255, 255, 255)
Next
C'est sans doute mon
.lpCustColors = VarPtr(dwCustClrs(0))
qui ne marche pas fort, j'ai trouvé ça sur google......

Et puis, j'aimerais passer à l'API la couleur actuelle de mon contrôle pour qu'il l'affiche dans la partie droite, et je n'ai
toujours pas trouvé comment faire. Pourtant, si vous voulez sélectionner une couleur avec Access, il le fait très bien

Vu mon âge, il est temps de mettre mon bonnet de nuit, mon dentier dans mon verre d'eau, ma longue chemise de laine, ma lampe à
pétrole sur la table de chevet, pour lire un numéro de l'Illustration avant de ronfler pire que la grosse Bertha.....

Bonne nuit tout le monde, bisous Raymond, merci encore

J-Pierre

Finalement, je me suis relevé, maintenant, j'arrive à passer la couleur à l'API et à initialiser les couleurs personnalisées à
blanc. En plus, d'un appel à l'autre, les couleurs personnalisées choisies sont conservées...... Qui disait que la nuit porte
conseil ????????

Voilà les deux codes complets modifiés:
------------------------------------------------------------------
module boiteCouleur
------------------------------------------------------------------

Private Type CHOOSECOLOR
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

' Constantes utilisées par ChooseColor
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 dwCustClrs(0 To 15) As Long ' Tableau statique contenant les couleurs personnalisées
Dim initFlag As Boolean

Private Declare Function ShowColour Lib "comdlg32.dll" Alias "ChooseColorA" _
(pChoosecolor As CHOOSECOLOR) As Long

Public Function ShowDialogColorBox(Optional initCouleur As Long = 16777215) As Variant

Dim tChooseColour As CHOOSECOLOR
Dim cnt As Integer
Dim r As Variant

If initFlag = False Then
initFlag = True
For cnt = 0 To 15
dwCustClrs(cnt) = RGB(255, 255, 255)
Next
End If

Dim Thread As Long
Thread = GetCurrentThreadId()
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProc, 0, Thread)

With tChooseColour
.lStructSize = Len(tChooseColour)
.hwndOwner = hWndAccessApp
.lpCustColors = VarPtr(dwCustClrs(0))
.Flags = CC_ANYCOLOR Or CC_RGBINIT Or CC_FULLOPEN
.rgbResult = initCouleur ' default color will put cursor on this Color
End With

r = ShowColour(tChooseColour)

If r = 0 Then
ShowDialogColorBox = ""
Else
ShowDialogColorBox = tChooseColour.rgbResult
End If

End Function

-------------------------------------------------------------
formulaire frmBoiteCouleur
------------------------------------------------------------
avec une zone de texte "maCouleur" et un bouton "Commande0"

Le code VBA:

Private Sub Commande0_Click()

Dim codeCouleur As String

codeCouleur = ShowDialogColorBox(Me.maCouleur.BackColor)

If codeCouleur <> "" Then
Me.maCouleur.BackColor = codeCouleur
Me.maCouleur = codeCouleur
End If

End Sub

Private Sub Form_Load()

Me.maCouleur = Me.maCouleur.BackColor

End Sub
----------------------------------------------------------------------
Bonne nuit

J-Pierre

Bonjour.

Tu travailles en 3x8 maintenant ? ça a l'ai de fonctionner.

je vais trier tout ça et le mettre sur mon site pour les autres
contributeurs.

Bon dimanche.

--
@+
Raymond Access MVP.
http://access.seneque.free.fr/
http://access2003.free.fr/
http://users.skynet.be/mpfa/charte.htm pour une meilleure
efficacité de tes interventions sur MPFA.


"J-Pierre" <jpberchtold@hotmail.com> a écrit dans le message de
news:u8ikQ4FkDHA.360@TK2MSFTNGP10.phx.gbl...

Finalement, je me suis relevé, maintenant, j'arrive à passer la couleur à
l'API et à initialiser les couleurs personnalisées à

blanc. En plus, d'un appel à l'autre, les couleurs personnalisées choisies
sont conservées...... Qui disait que la nuit porte

conseil ????????

Voilà les deux codes complets modifiés:
------------------------------------------------------------------
module boiteCouleur
------------------------------------------------------------------

Private Type CHOOSECOLOR
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

' Constantes utilisées par ChooseColor
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 dwCustClrs(0 To 15) As Long ' Tableau statique contenant les
couleurs personnalisées

Dim initFlag As Boolean

Private Declare Function ShowColour Lib "comdlg32.dll" Alias
"ChooseColorA" _

(pChoosecolor As CHOOSECOLOR) As Long

Public Function ShowDialogColorBox(Optional initCouleur As Long 16777215) As Variant

Dim tChooseColour As CHOOSECOLOR
Dim cnt As Integer
Dim r As Variant

If initFlag = False Then
initFlag = True
For cnt = 0 To 15
dwCustClrs(cnt) = RGB(255, 255, 255)
Next
End If

Dim Thread As Long
Thread = GetCurrentThreadId()
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProc, 0, Thread)

With tChooseColour
.lStructSize = Len(tChooseColour)
.hwndOwner = hWndAccessApp
.lpCustColors = VarPtr(dwCustClrs(0))
.Flags = CC_ANYCOLOR Or CC_RGBINIT Or CC_FULLOPEN
.rgbResult = initCouleur ' default color will put cursor on this
Color

End With

r = ShowColour(tChooseColour)

If r = 0 Then
ShowDialogColorBox = ""
Else
ShowDialogColorBox = tChooseColour.rgbResult
End If

End Function

-------------------------------------------------------------
formulaire frmBoiteCouleur
------------------------------------------------------------
avec une zone de texte "maCouleur" et un bouton "Commande0"

Le code VBA:

Private Sub Commande0_Click()

Dim codeCouleur As String

codeCouleur = ShowDialogColorBox(Me.maCouleur.BackColor)

If codeCouleur <> "" Then
Me.maCouleur.BackColor = codeCouleur
Me.maCouleur = codeCouleur
End If

End Sub

Private Sub Form_Load()

Me.maCouleur = Me.maCouleur.BackColor

End Sub
----------------------------------------------------------------------
Bonne nuit

J-Pierre