انتخاب رنگ استفاده از 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