Attribute VB_Name = "PickColor"
Option Explicit

'Modul nur für das Farbauswahlmenü benötigt
'Keine Änderungen nötig!

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (lpofn As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (lpofn As OPENFILENAME) As Long

Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_EXPLORER = &H80000
Private Const OFN_OVERWRITEPROMPT = &H2

Private Type OPENFILENAME
 lStructSize As Long
 hwndOwner As Long
 hInstance 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

Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (lpcc As ChooseColorType) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

Private Type ChooseColorType
 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 Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const CC_FULLOPEN = &H2
Private Const CC_RGBINIT = &H1



Private Const WM_NOTIFY = &H4E
Private Const WM_DESTROY = &H2
Private Const WM_INITDIALOG = &H110


Private Const CDM_GETFILEPATH = &H465
Private Const CDM_GETFOLDERPATH = &H466


Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Type RECT
 Left As Long
 Top As Long
 Right As Long
 Bottom As Long
End Type
Private 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
Private Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Private Const HWND_TOP = 0

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Dim CdlgHwnd As Long


Public Function ColorDialog(ByVal FrmHwnd As Long, Optional Colr As Long = 0) As Long
 Dim Col As ChooseColorType
 Dim Addr As Long
 Dim Memh As Long
 Dim ClrArray(15) As Long
 Dim i As Long
 Dim Result As Long


 Memh = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, 64)
 Addr = GlobalLock(Memh)

 For i = 0 To UBound(ClrArray)
  ClrArray(i) = &HFFFFFF
 Next i


 CopyMemory ByVal Addr, ClrArray(0), 64

 Col.lStructSize = Len(Col)
 Col.hwndOwner = FrmHwnd
 Col.lpCustColors = Addr
 Col.rgbResult = Colr
 Col.flags = CC_RGBINIT Or CC_FULLOPEN

 Result = ChooseColor(Col)

 
 GlobalUnlock Memh
 GlobalFree Memh

 If Result = 0 Then
  ColorDialog = -1
 Else
  ColorDialog = Col.rgbResult
 End If

End Function

