انتخاب رنگ استفاده از ChooseColor

ChooseColor : ms646912(v=vs.85)

DLL : Comdlg32.dll

LIB is Required 

If Use 64 bit windowse , before Function use PtrSafe

در لینک زیر نحوه استفاده و فراخوانی دیالوگ باکس ها مثل رنگ ، فونت ، پرینت بیان شده و می توانید به نحو احسنت و دلخواه فیض ببرید DLL آنهم در بالا گفته شده حتما در فراخوانی باید از LIB استفاده شود مثل 

Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long

توابع Api ویندوز را با همان نام و حروف کوچک و بزرگش فراخوانی کنید فرضا در GetWindow اگر getWindow تایپ کنید خطا می دهد. برای ویندوز 64 بیت قبل از Function از PtrSafe استفاده کنید و بعضی از آرگومانها مثل hWnd هم باید بجای دیتا تایپ Long از LongPtr استفاده کرد.

using-common-dialog-boxes

CHOOSECOLOR cc ' common dialog box structure static COLORREF acrCustClr[16] ' array of custom colors

HWND hwnd 'owner window

HBRUSH hbrush 'brush handle

static DWORD rgbCurrent 'initial color selectionInitialize CHOOSECOLOR ZeroMemory(&cc, sizeof(cc)); cc.lStructSize = sizeof(cc); cc.hwndOwner = hwnd; cc.lpCustColors = (LPDWORD) acrCustClr; cc.rgbResult = rgbCurrent; cc.Flags = CC_FULLOPEN | CC_RGBINIT;

See the link >>>>> choosecolora

typedef struct tagCHOOSECOLORA { 

 DWORD lStructSize; 

 HWND hwndOwner; 

 HWND hInstance; 

 COLORREF rgbResult; 

 COLORREF *lpCustColors; 

 DWORD Flags; 

 LPARAM lCustData; 

 LPCCHOOKPROC lpfnHook; 

 LPCSTR lpTemplateName; 

 LPEDITMENU lpEditInfo; } 

CHOOSECOLORA, *LPCHOOSECOLORA;

در لینک کاربرد هر کدام مفصل بیان شده که بعضی به کار کنونی ما ربط پیدا می نماید.

در بالا اول استراکچری تعریف شده که مقادیری را در خودش نگه می دارد 

Pubic Type ChooseColor

#if win64 Then

lStructSize As LongPtr

hwndOwner As LongPtr

lpCustColors() As LongPtr

rgbResult As LongPtr

Flags As LongPtr

#Else

lStructSize As Long

hwndOwner As Long

lpCustColors() As Long

rgbResult As Long

Flags As Long

#End if

End Type

 تابعی به اسم dlgColor تعریف شده و از نوع Long ... اگر رنگ دیفالتی قرار است تعریف شود در تابع می توانید بکار ببرید مثل Oprional iDefault As Long 

Dim cc As ChooseColor

Dim lRet As Long

Static CustomColors(16) As Long

'If yoy want to use

CustomColors(1)=RGB(255,255,255)

With cc

.lstructSize=LenB(cc)

.hwndOwner=Application.hWndAccessApp

.flags=

.lpCustcolors=VarPtr(CustomColors(0))

End With

lRet=ChooseColor(cc)

If lRet=0 Then '  کنسل توسط کاربر

dlgColor=RGB(255,255,255) ' سفید

Else

dlgColor=cc.rgbResult

End If 

اگر rgbResult صفر یا CC_RGBINIT تنظیم نشده باشد رنگ انتخاب شده اصلی مشکی است . اگر کاربر باتن OK را بفشارد rgbResult انتخاب کاربر خواهد بود.از RGB ماکرو استفاده کنید.

برای flags در استراکچر بالا از CC_ANYCOLOR Or CC_FULLOPEN Or CC_PREVENTFULLOPEN Or CC_RGBINIT استفاده بنمائید که باز کردن دیالوگ باکس هم درونش وجود دارد.

lpCustColors نشانگری است به آرایه (16) ای که حاوی مقادیر قرمز سبز آبی  برای جعبه رنگ در دیالوگ باکس است .اگر کاربر در این رنگ ها  تغییراتی بدهد سیستم آرایه را به مقادیر جدیدی به روز رسانی خواهد کرد برای نگهداری این به روز رسانی و  استفاده از آن در تابع بایستی حافظه Static را برای این آرایه تخصیص بدهید مثل Static CustomColors(16) As Long . برای ساختن COLORREF از ماکرو RGB استفاده بنمائید. 

لینک زیر هوک کردن دیالوگ باکس البته پیشنهاد نمیشود و درون آن پنجره هم CHILD یا زیر پنجره هایی وجود دارد و توصیه شده از GETPARENT استفاده بنمائید.

 چرخش در زنجیره ی هوک  commdlg-lpofnhookproc

Lpofnhookproc; UINT_PTR Lpofnhookproc( HWND unnamedParam1, UINT unnamedParam2, WPARAM unnamedParam3, LPARAM unnamedParam4 )

رویه HOOK میتواند تابع PostMessage را برای ارسال پیام 

WM_COMMAND با مقدار IDCANCEL به رویه دیالوگ باکس فرابخواند.ارسال IDCANCEK این پنجره را می بندد و باعث می شود تابع FALSE را برگرداند.

اگر پیام WM_CTLCOLORDLG به پنجره ارسال شود و همچین پیامی داشته باشد آن بایستی یک هندل BRUSH معتبری برای رنگ کردن  پیش زمینه دیالوگ باکس را برگشت دهد. 

WM_CTLCOLORDLG : 

wParam

A handle to the device context for the dialog box.

lParam

A handle to the dialog box.

Public Function DlgProc(ByVal hwnd As longPtr,ByVal Umsg As Long, ByVal wParam As LongPtr,Byval lParam As LongPtr)

Select Case Umsg
 Case WM_INITDIALOG
SetDlgItemText(hwnd, IDC_FROM, "Start address")
SetDlgItemText(hwnd, IDC_TO, "Destination address")
Case WM_COMMAND
Select Case Left(wparam, )

.

End Select
Case WM_CTLCOLORDLG
.
End Select
.
End Select

DlgProc=False
End Function

Public WindowProc(ByVal hWindow As LongPtr,ByVal uMsg As Long ,ByVal wParam As LongPtr,ByVal lParam As LongPtr)
Select Case uMsg
case WM_CLOSE DestroyWindow(hWindow)
case WM_DESTROY
PostQuitMessage(0)
End Select
Ret=DefWindowProc(hWindow, uMsg, wParam, lParam)
WindowProc=False
End Function

یک اپلیکیشن می تواند قبل از بستن پنجره پیامی را توسط کامپیوتر ارسال کند ( Prompt ) ، توسط فرآیند پیام WM_CLOSE و فراخوانی تابع DestroyWindow تنها اگر کاربر انتخاب را تائید کند. (یعنی اگر کاربر IDCANCEL را بفشارد تابع DestroyWindow با پیام WM_CLOSE که به پنجره می فرستد منجر به بستن آن خواهد شد.)

بصورت دیفالت تابع DefWindowProc تابع DestroyWindow برای بستن پنجره فرا می خواند ( Call ) ... برای تایع بالا گفته شده

Public lpPrevWindProc As LongPtr

GWL_WNDPROC=(-4)

در HOOK برای DLG می توان از   SetWindowLongPtr   استفاده کرد و به fnWindProc آدرس داد و در آنجا پیام هایی را به پنجره ارسال کرد.

Function fnWindProcWrapper(ByVal hWnd As LongPtr, _ ByVal uMessage As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) _ As Long
' [Add your code here]
CallWindowProc lpPrevWindProc, hWnd, uMessage, wParam, lParam

End Function 

پنجره اکسس در اینجا hook شده ولی توصیه نمیشود چون اگر پنجره ای دیگر باز شود اگر نتوانید هندل آنها را بدست آورید به آنها ارسال خواهد شد و ممکن است سیستم هنگ کند و مجبور به End Process از پنجره Task Manager شوید.

Function HookWindProc()

MsgBox "Hook WinProc"

lpPrevWindProc = SetWindowLongPtr(Application.hWndAccessApp, GWL_WNDPROC, AddressOf fnWindProc)

End Function

مثال دیگر از WINDOWPROC : 

تابع زیر در ویندوز 32 بیت برای 64 باید از دیتا تایپ LONGPTR یا LONGLONG و قبل از FUNCTION نیز PTRSAFE بکار برده شود در نظر داشته باشید استعمال این توابع توصیه نمی شود چون واقعا UNSAFE می شود.

Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcA" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long


Public pVBProc As Long
' pointer to Window procedure
' The above variable defaults to 0 automatically

Public Function WindowProc (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' Call the default window procedure and return its result.
WindowProc = (hWnd, uMsg, wParam, lParam)
End Function
کد زیر را در هر کجا که مایل هستید قرار دهید

Dim retval As Long
' return value
If pVBProc = 0 Then
pVBProc = SetWindowLong(Form1.hWnd, GWL_WNDPROC,AddressOf WindowProc)
Else
retval=SetWindowLong(Form1.hWnd, GWL_WNDPROC, pVBProc)
pVBProc = 0
End If 

گرفتن HANDLE پنجره هایی که داخل پنجره اصلی قرار دارند

Declare Function EnumChildWindows Lib "user32" (byval hWndParent as Long, byval lpEnumFunc as Long, byval lParam as Long) as Long
Declare Function GetParent Lib "user32" (byval hwnd as Long) as Long


public Function VB_WndEnumProc(byval hwnd as Long, byval lParam as Long) as Long

'onerror resume next

Debug.Print hwnd & ";" & lParam
'Loop
WndEnumProc = 1

End Function

CENTER MESSAGEBOX :

البته ممکن است کد زیر خطای نوشتاری داشته باشد ولی در کل سنتر کردن بدین نحو است که به VBA ترجمه شده ... البته فرم باید در حالت POPUP باشد. در صورت تست تصویر مربوطه در زیر پست قرار داده میشود .

Public hhk As Long
Private Type Rect
x As long
y As Long
End Type

Public Function CBTMessageBox(ByVal hwnd As Long,ByVal lpText As String,ByVal lpCaption As String,uType As Lonh)
hhk=SetWindowsHookEx(WH_CBT, AddressOf CBTProc,0, GetCurrentThreadId())
CBTMessageBox=MessageBox(hwnd, lpText,lpCaption,uType)
End Function

Public Function CBTProc(ByVal nCode As Long,ByVal wParam As Long,lParam As Long)

Dim hParentWnd As Long
Dim hChildWnd As Long
'msgbox is "child"
Dim rParent,rChild,rDesktop As Rect
Dim pCenter, pStart As POINTAPI
Dim nWidth, nHeight As Long

'window handle is wParam

if nCode = HCBT_ACTIVATE Then
'set window handles
hParentWnd = GetForegroundWindow()
hChildWnd = wParam

if ((hParentWnd <> 0) And (hChildWnd <> 0) And (GetWindowRect(GetDesktopWindow(), &rDesktop) <>0) And (GetWindowRect(hParentWnd, &rParent) <>0) And (GetWindowRect(hChildWnd, &rChild) <>))  Then


'calculate message box dimensions nWidth = (rChild.right - rChild.left) nHeight = (rChild.bottom - rChild.top) 'calculate parent window center point pCenter.x = rParent.left+((rParent.right - rParent.left)/2)
pCenter.y = rParent.top+((rParent.bottom - rParent.top)/2)
'calculate message box starting point pStart.x = (pCenter.x - (nWidth/2)) pStart.y = (pCenter.y - (nHeight/2))


'adjust if message box is off desktop if(pStart.x < 0) Then pStart.x = 0
if(pStart.y < 0) ThenpStart.y = 0
if(pStart.x + nWidth > rDesktop.right) Then
pStart.x = rDesktop.right - nWidth
End If
if(pStart.y + nHeight > rDesktop.bottom) Then
pStart.y = rDesktop.bottom - nHeight
End If

'move message box MoveWindow(hChildWnd,pStart.x, pStart.y,nWidth,nHeight,FALSE)
'exit CBT hook UnhookWindowsHookEx(hhk)

Else
CallNextHookEx(hhk, nCode, wParam, lParam)
End if
End if
CBTProc=False
End Function

فرآیند پیام ارسال شده به پنجره WindowProc

Subclassing Controls

WindowProc callback function

Declare PtrSafe Function CallWindowProcA Lib "user32" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long

Declare PtrSafe Function SetWindowLongPtrA Lib "user32" (ByVal hwnd As LongPtr, ByVal nIndex As Long,ByVal dwNewLong As LongPtr) As Long

(Public Const GWL_WNDPROC = (-4

Global oldwndproc As LongPtr

Global wndHW As LongPtr

: Form_Load

wndHw=Me.Hwnd

(oldwndproc = SetWindowLongPtrA(Me.hwnd, GWL_WNDPROC, AddressOf WndProc

: Form_Unload

SetWindowLongPtrA wndHw, GWL_WNDPROC, oldwndproc

Public Function WndProc(ByVal lhwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long

If uMsg = 516 Then 'WM_RBUTTONDOWNU           

        'Debug.Print "Intercepted WM_CONTEXTMENU at " & Now                        

       " MsgBox "Mouse Right Button Was Clicked                       

          WndProc=-1                      

ElseIf uMsg = WM_KEYDOWN Then        

           MsgBox wParam                    

             WndProc = True                    

     Else ' Send all other messages to the default message handler     

        (WndProc = CallWindowProcA(oldwndproc, lhwnd, uMsg, wParam, lParam

     End If

End Function

Public Const WM_KEYDOWN = &H100

Public Const WM_KEYUP = &H101

Public Const WM_CHAR = &H102

Public Const VK_RETURN = &HD

Public Const VK_UP = &H26

Public Const VK_DOWN = &H28

Public Const VK_HOME = &H24

Public Const VK_LEFT = &H25

Public Const VK_PRIOR = &H21

Public Const VK_LBUTTON = &H1  ' Left mouse button

Public Const VK_RBUTTON = &H2  ' Right mouse button

Public Const VK_MBUTTON = &H4  ' Middle mouse button (three-button mouse)

Public Const SC_SIZE = &HF000&

Public Const SC_MOVE = &HF010&

Public Const SC_MINIMIZE = &HF020&

Public Const SC_MAXIMIZE = &HF030&

Public Const SC_NEXTWINDOW = &HF040&

Public Const SC_PREVWINDOW = &HF050&

Public Const SC_CLOSE = &HF060&

Const WM_NCLBUTTONDOWN As Integer = 161
        Const WM_SYSCOMMAND As Integer = 274
        Const HTCAPTION As Integer = 2
        Const SC_MOVE As Integer = 61456

        If (Msg = WM_SYSCOMMAND) And (WParam = SC_MOVE) Then
            Return
        End If

        If (Msg = WM_NCLBUTTONDOWN) And (WParam = HTCAPTION) Then
            Return
        If (Msg = WM_RBUTTONDOWN) And (WParam = WM_RBUTTONDOWN) Then
            Return
        End If

    

وقتی دابل کلیک روی قسمت تایتل بار انجام میشود یا بعبارتی  قسمت کپشن پنجره عمل ماکسیمایز پنجره انجام خواهد گرفت

If umsg = WM_NCLBUTTONDBLCLK And wParam = 2 Then Exit Function

SYsMenu عمل نکردن منوهای تایتل بار یا 

If umsg = WM_SYSCOMMAND And ((wParam = SC_CLOSE) Or (wParam = SC_MINIMIZE) Or (wParam = SC_MAXIMIZE)) Then

Exit Function

مثال دیگر :

    wm-ncdestroy   &H82

If Msg = WM_NCDESTROY Then 

SetWindowLong hWnd,GWL_WNDPROC,OldWindowProc

End If 

wm-contextmenu  &H7B

If Msg <> WM_CONTEXTMENU Then

NoPopupWindowProc = CallWindowProc(OldWindowProc,hWnd

,Msg,wParam,lParam)

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

 اگر از HOOK  استفاده شود و آیدی WH_MOUSE یا WH_MOUSE_LL

If Wparam=WM_NCLBUTTONDBLCLK Then 

     MouseHookProc=NoneZero

End If

WM_RBUTTONDOWN   wm-rbuttondown   &H204

(20×16)×1.6+4=516 ( DECIMAL )

516÷16=32  

516-(32×16)=4

(516÷16)×10=320

320÷16=20

List Of Windows Message  SendMessageList