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 استفاده کرد.
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
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
مثال دیگر از 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