نمایش بالن راهنما در EDIT CONTROL

EM_SHOWBALLOONTIP

displays a balloon tip associated with an edit control

Parameters

 : wParam

Not used; must be zero

lParam

این پارامتر یک نشانگر به ساختار EDITBALLONTIP ( ممبر یا عضوهای ساختار در ادامه آمده ) که حاوی اطلاعات درباره ی بالن راهنمای جهت نمایش است .

A pointer to an EDITBALLOONTIP structure that contains information about the balloon tip to display.



Type EDITBALLOONTIP
cbStruct As Long
pszTitle As String
pszText As String
ttiIcon As Integer
End Type

ttiIcon

TTI_ERROR  Use the error icon
TTI_INFOUse the information icon
TTI_NONEUse no icon
TTI_WARNINGUse the warning icon

Tooltip iconsconst
TTI_NONE = 0
TTI_INFO = 1
TTI_WARNING = 2
TTI_ERROR = 3
TTI_INFO_LARGE = 4
TTI_WARNING_LARGE = 5
TTI_ERROR_LARGE = 6

• عدم ظهور BALLOONTIP یا بالن راهنما در Subclass کردن EDIT CONTROL

Function NoBalloonWndProc(ByVal hwnd As Long,ByVal uMsg As Long,ByVal wParam As 

(Long,Byval lParam As Long

Select Case uMsg

  case EM_SHOWBALLOONTIP

     NoBalloonWndProc=FALSE

End Select 

NoBalloonWndProc=CallWindowProc(g_Edit,hwnd,uMsg,wParam,lParam

(

تنظیم نشانه ی متن در EDIT CONTROL

ارسال توسط تابع SendMessageA  : 

SendMessageA hwndEdit,EM_SETCUEBANNER,0,ByVal 

"User Name" 

ECM_FIRST =&H1500 

The following messages need Unicode strings

(EM_SETCUEBANNER=(ECM_FIRST + 1

(EM_GETCUEBANNER=(ECM_FIRST + 2

(EM_SHOWBALLOONTIP=(ECM_FIRST + 3

(EM_HIDEBALLOONTIP=(ECM_FIRST + 4

EM_SETHILITE=(ECM_FIRST+5);>=Vista, not documented

EM_GETHILITE=(ECM_FIRST+6);>=Vista, not documented

EM_SETCUEBANNER

Parameters

 : wParam

اگر این پارامتر در تابع بالا  غیرصفر باشدحتی اگر فوکس بگیرد نمایش داده میشود اگر صفر باشد زمانی که در آن ( ادیت کنترل) کلیک شود(  نشانه ی متن ) محو میشود.

TRUE if the cue banner should show even when the edit control has focus; otherwise, FALSE. FALSE is the default behavior the cue banner disappears when the 

.user clicks in the control

  : lParam

A pointer to a Unicode string that contains the text to 

.display as the textual cue

دراکسس در قسمت پراپرتی Format تکست باکس @ و بعد SemiColon و تکست موردنظر در داخل دابل کوتیشن ها 

تنظیم رنگ پس زمینه ی EDIT CONTROL

EM_SETBKGNDCOLOR

The EM_SETBKGNDCOLOR message sets the background color for a rich edit control.

wParam

Specifies whether to use the system color. If this parameter is a nonzero value, the background is set to the window background system color. Otherwise, the 

.background is set to the specified color

lParam

A COLORREF structure specifying the color if wParam 

.is zero. To generate a COLORREF, use the RGB macro

تنظیم حاشیه ها در EDIT CONTROL

: wParam 

EC_LEFTMARGIN

EC_RIGHTMARGIN

 : lParam

The LOWORD specifies the new width of the left margin, in pixels. This value is ignored if wParam does not include EC_LEFTMARGIN

The HIWORD specifies the new width of the right margin, in pixels. This value is ignored if wParam does not include EC_RIGHTMARGIN.

EM_SETRECT

wParam

.parameter is not used and must be zero

lParam

A pointer to a RECT structure that specifies the new dimensions of the rectangle. If this parameter is NULL, 

.the formatting rectangle is set to its default values

RECT rc

'Get the current control rectangle

(SendMessage(hWndRichEdit,EM_GETRECT,0,ByVal rc

rc.left += 20 'increase the left margin

rc.top += 20 'increase the top margin

rc.right -= 20 'decrease the right margin

rc.bottom -= 20 'decrease the bottom margin (rectangle) ' Set the rectangle

(SendMessage(hWndRichEdit,EM_SETRECT,0,ByVal rc

EM-SETMARGINS

WM_CTLCOLORDLG

win32api/reference/Message/WM_CTLCOLORDLG.htm

WM_CTLCOLORDLG
Static wBrush
If wBrush<>0 Then
(hBM=LoadImage(0,"tile.bmp",0,0,0,0x2010
(wBrush=CreatePatternBrush(hBM

Function=wBrush

FrameRect

Const SM_CXFRAME=32

Const SM_CYFRAME=33

Const SM_CYSIZE 31

The height of a button in a window caption or title bar' 

.in pixels

framerect

setrect

fillrect

()Sub Button2_on 

Dim fWidth As Long

Dim fHeight As Long

Dim RndCol As Long

Dim hBrush As Long 

Dim Ret As Long

fWidth=GetSystemMetrics(SM_CXFRAME)*2

(fHeight=GetSystemMetrics(SM_CYFRAME)*2+GetSystemMetrics(SM_CYSIZE

-Ret=SetRect(rct,5,5,GetWidth-fWidth-5, GetHeight

(fHeight-5

hBrush=CreateHatchBrush (HS_DIAGCROSS, vbBlue) 'Draw with blue DIAGCROSS for VB

(Ret=FrameRect(hfDC,rct,hBrush

(Ret=DeleteObject(hWhiteBrush

End Sub

WM_LBUTTONDOWN

using-brushes

case WM_LBUTTONDOWN

Store the mouse coordinates in a POINT structure'

ptlHit=MAKEPOINTS((POINTS FAR *)lParam

Create a rectangular region with dimensions and' 

coordinates that correspond to those of the grid 

window

,hrgnCell=CreateRectRgn(rctGrid.left, rctGrid.top

(rctGrid.right, rctGrid.bottom

Retrieve a window DC for the grid window'

(hdc=GetWindowDC(hwndGrid

Select the region into the DC'

(SelectObject(hdc, hrgnCell

Test for a button click in the grid-window rectangle'

if (PtInRegion(hrgnCell, ptlHit.x, ptlHit.y)) Then

CreateHatchBrush/ CreatePatternBrush

hatch-brush

((hBrush=CreateSolidBrush (RGB(0, 0, 255

Associate the brush with the display device context'

SelectObject  hdc, hBrush

Draw a rectangle with blue background'

Rectangle hdc, 400,40,800,400

Create a hatch brush that draws horizontal red line'

,hBrush=CreateHatchBrush(HatchStyleHorizontal

((RGB(255, 0, 0

Set the background color to yellow'

(SetBkColor hdc, RGB(255, 255, 0

createpatternbrush

HBRUSH (CreatePatternBrush ( HBITMAP hbm

برگرفته از فروم های خارجی 

 Hatch Styles'

HS_HORIZONTAL= 0

HS_VERTICAL= 1

HS_FDIAGONAL= 2

HS_BDIAGONAL =3

HS_CROSS =4

HS_DIAGCROSS =5

()Sub OnPaint

Dim Brush

CreatePatternBrush 

(Brush,HS_HORIZONTAL,RGB(232,166,153

Dim ps As PAINTSTRUCT

Dim rct As RECT

GetClientRect hwnd,rct

(dc=BeginPaint(hwnd,ps

SelectObject dc,Brush

Rectangle hdc,left,top,right,bottom'

Rectangle dc,rct?

(SetBkColor dc,RGB(232,166,153

DrawText dc,"Brush Demo",10,rct,DT_CENTER Or DT_VCENTER Or DT_SINGLELINE

EndPaint hwnd,ps

Private hbr

(Function CreatePatternBrushFromFile(pszFile

hbr=0

(hbm=LoadImage(0,pszFile,IMAGE_BITMAP,0,0,LR_LOADFROMFILE

if (hbm) Then 

(hbr=CreatePatternBrush(hbm

DeleteObject hbm

End if

CreatePatternBrushFromFile=hbr

End Function

Function PaintContent(ByVal hwnd As Long,ByRef pps As 

(PAINTSTRUCT  

BeginPath pps.hdc

Ellipse pps.hdc,0,0,200,100

EndPath pps.hdc

(hbrOld=SelectObject(pps.hdc,hbr

FillPath pps.hdc

SelectObject pps.hdc,hbrOld

End Function

---

SWP_NOSIZE = 0x0001

SWP_NOMOVE = 0x0002

SWP_NOZORDER = 0x0004

SWP_FRAMECHANGED = 0x0020

SWP_SHOWWINDOW = 0x0040

(GWL_STYLE = (-16

'Window Style 

WS_CLIPCHILDREN=0x02000000

WS_CLIPSIBLINGS=0x04000000

hBrush=CreateHatchBrush(HS_DIAGCROSS,ColorTranslator.ToWin32(Color.Red)

,SetWindowSubclass(textBox1.Handle

(AddressOf WindowSubClass,0,0

SetWindowPos(textBox1.Handle,0,0,0, 200,40,SWP_NOZORDER Or SWP_NOMOVE Or 

(SWP_SHOWWINDOW Or SWP_FRAMECHANGED

For main form resizing long'

(nStyle = GetWindowLong(this.Handle, GWL_STYLE

SetWindowLong(this.Handle,GWL_STYLE, nStyle And 

(WS_CLIPCHILDREN

,WindowSubClass(hWnd,uMsg,wParam

(lParam,uIdSubclass,dwRefData

Select Case  uMsg

Case WM_NCPAINT

(hDC=GetWindowDC(hWnd

Dim rct As RECT 

()rect = new RECT'

(GetClientRect(hWnd, out rect

rct.right += 20 * 2

rct.bottom += 20 * 2

if  hBrush<>0 Then 

FillRect hDC,rct,hBrush

ReleaseDC hWnd, hDC

Exit Function

case WM_NCCALCSIZE

if (wParam == (IntPtr)0'

Dim pRect As RECT

,pRect =(RECT)Marshal.PtrToStructure(lParam'

((typeof(RECT'

(Call CopyMemory(VarPtr(rct)+4,ByVal lParam+4,4

pRect.left += 10

pRect.top += 10

pRect.bottom -= 10

pRect.right -= 10

(Marshal.StructureToPtr(pRect, lParam,false'

(Call CopyMemory(lparam,VarPtr(rct),4

Exit Function

End Select

DefSubclassProc(hWnd, uMsg, wParam, lParam)

EDIT CONTROL اعلان ( Notification) / محدودیت تکست / ارسال تکست Edit به کپشن پنجره اصلی

EN_CHANGE 

wParam

The LOWORD contains the identifier of the edit control. The HIWORD specifies the notification code.

lParam

A handle to the edit control.

'  Edit styles const'

ES_LEFT = 0x0000

ES_CENTER = 0x0001

ES_RIGHT = 0x0002

ES_MULTILINE = 0x0004

ES_UPPERCASE = 0x0008

ES_LOWERCASE = 0x0010

ES_PASSWORD = 0x0020

ES_AUTOVSCROLL = 0x0040

ES_AUTOHSCROLL = 0x0080

ES_NOHIDESEL = 0x0100

ES_OEMCONVERT = 0x0400

ES_READONLY = 0x0800

ES_WANTRETURN = 0x1000

ES_NUMBER = 0x2000

  Edit notifications const' 

EN_SETFOCUS = 0x0100

EN_KILLFOCUS = 0x0200

EN_CHANGE = 0x0300

EN_UPDATE = 0x0400

EN_ERRSPACE = 0x0500

EN_MAXTEXT = 0x0501

EN_HSCROLL = 0x0601 

EN_VSCROLL = 0x0602

EN_ALIGN_LTR_EC = 0x0700

EN_ALIGN_RTL_EC = 0x0701

  Edit messages const'

EM_GETSEL = 0x00B0

EM_SETSEL = 0x00B1

EM_GETRECT = 0x00B2

EM_SETRECT = 0x00B3

EM_SETRECTNP = 0x00B4

EM_SCROLL = 0x00B5

EM_LINESCROLL = 0x00B6

EM_SCROLLCARET = 0x00B7

EM_GETMODIFY = 0x00B8

EM_SETMODIFY = 0x00B9

EM_GETLINECOUNT = 0x00BA

EM_LINEINDEX = 0x00BB

EM_SETHANDLE = 0x00BC

EM_GETHANDLE = 0x00BD

EM_GETTHUMB = 0x00BE

EM_LINELENGTH = 0x00C1

EM_REPLACESEL = 0x00C2

EM_GETLINE = 0x00C4

EM_LIMITTEXT = 0x00C5

EM_CANUNDO = 0x00C6

EM_UNDO = 0x00C7

EM_FMTLINES = 0x00C8

EM_LINEFROMCHAR = 0x00C9

EM_SETTABSTOPS = 0x00CB EM_SETPASSWORDCHAR = 0x00CC EM_EMPTYUNDOBUFFER = 0x00CD EM_GETFIRSTVISIBLELINE = 0x00CE EM_SETREADONLY = 0x00CF EM_SETWORDBREAKPROC = 0x00D0 EM_GETWORDBREAKPROC = 0x00D1 EM_GETPASSWORDCHAR = 0x00D2 EM_SETMARGINS = 0x00D3

EM_GETMARGINS = 0x00D4

EM_SETLIMITTEXT = EM_LIMITTEXT EM_GETLIMITTEXT = 0x00D5

EM_POSFROMCHAR = 0x00D6

EM_CHARFROMPOS = 0x00D7

EM_SETIMESTATUS = 0x00D8

EM_GETIMESTATUS = 0x00D9

EM_SETCUEBANNER = 0x1501

EM_GETCUEBANNER = 0x1502

EM_LIMITTEXT message 

.Sets the text limit of an edit control

wParam

The maximum number of TCHARs the user can enter. For ANSI text, this is the number of bytes; for Unicode text, this is the number of characters. This number does

.  not include the terminating null character

lParam

.This parameter is not used

) LRESULT WINAPI SendDlgItemMessage
_In_ HWND   hDlg,
_In_ int    nIDDlgItem,
_In_ UINT   Msg,
_In_ WPARAM wParam,
_In_ LPARAM lParam
;(

در InputBox  زیر با کلاس 32770#  که تست شده  در کنترل Edit آن با آیدی 4900 نمی توان بیشتر از 10 کاراکتر واردنمود

Case WM_SHOWWINDOW     

          SendDlgItemMessageA hwnd, 4900, EM_LIMITTEXT, 0, 10

PushButton

MOUSEMOVE / XPOS

WParwm : LBUTTON Or RBUTTON

lParam

Lo مختصات x کرسر را مشخص میکند . مختصات مرتبط با گوشه چپ بالایی از منطقه Client

The low-order word specifies the x-coordinate of the cursor. The coordinate is relative to the upper-left corner of the client area

ho مختصات y کرسر را مشخص میکند . مختصات  مرتبط با گوشه چپ بالایی منطقه Client

The high-order word specifies the y-coordinate of the cursor. The coordinate is relative to the upper-left corner of the client area

در کل مختصات x و y  گوشه چپ بالایی منطقه Client را مشخص می نماید. 

---

Case WM_MOUSEMOVE

         Dim rw As RECT

         Dim rc As RECT

         Dim pp As POINTAPI

         GetWindowRect BtnOk, rw

         pp.x = rw.left

         pp.y = rw.top

         ClientToScreen BtnOk, pp

         GetCursorPos pp

         If Not PtInRect(rw, pp) Then'

         ' MsgBox "rt'

         'End If'

         SetWindowTextA hwnd, pp.x & "," & pp.y & "...." & rw.left & "," & rw.top

---

اگر ازGetClientRect استفاده کنید مختصات left و Topرا صفر میدهد.

dim rw As RECT

GetWindowRect hwndBtnOk,rw

dim pp as POINTAPI

(pp.x = LoWord(lParam

        ( pp.y = HiWord(lParam

          MoveWindow hwndBtnOk, pp.x, pp.y, (rw.right - rw.left), (rw.bottom - rw.top), 1

The &H prefix denotes a number represented in hexadecimal (base 16) notation.

Hexadecimal digits, like decimal, start at 0, but go up to 

.(F (16

e.g. 0 1 2 3 4 5 6 7 8 9 A B C D E F, 10 11 12 13 14 15 16 17 18 19 1A 1B etc.

In C-based languages hexadecimal numbers are prefixed with 0x, eg. 0x10000. This is directly equal to 

H10000 in VB&

Hex To Decimal

NCCALCSIZE ( محاسبه ی اندازه در Non Client )

اولین  مستطیل یا Rectangle حاوی مختصات جدید پنجره که جابجا یا تغییر سایز شده است طبق داکیومنت زیر 

When the window procedure receives

 the WM_NCCALCSIZE message, the first rectangle contains the new coordinates of a window that has been moved or resized, that is, it is the proposed new window coordinates. The second contains the coordinates of the window before it was moved or resized. The third contains the coordinates of the window's client area before the window was moved or resized

افزایش عرض یا طول مستطیل ( Rectangle )

InflateRect lprc,dx,dy

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

InvalidateRect hWnd,lpRect,bErase

Also Read   offsetrect

WM_NCCALCSIZE'

(private WmNCCalcSize(ByRef m Ss Message 

Get Window Rect RECT'

Dim formRect As RECT

GetWindowRect m.HWnd,formRect

Check WPARAM'

 if m.WParam<>0 Then 

When TRUE, LPARAM Points to a'

NCCALCSIZE_PARAMS structure'

Dim nccsp As NCCALCSIZE_PARAMS

We're adjusting the size of the client area 'here. Right' 

now, the client area is the whole form

Adding to the Top, Bottom, Left, and Right will size the '

client area.

nccsp.rgrc0.top= formRect.top+30

 Thirty pixel top border'
nccsp.rgrc0.bottom=formRect.bottom-4
Four pixel bottom (resize) border'
nccsp.rgrc0.left=formRect.left+4
Four pixel left (resize) border'

Else 'FALSE
When FALSE,LPARAM Points to a RECT structure'
Dim clnRect As RECT
'Like before, we're adjusting the rectangle...
'Adding to the Top, Bottom, Left, and Right will size the client area. 

(CopyMemory clnRect,Byval lParam,Len(lParam
clnRect.top+=30
Thirty-pixel top border'
clnRect.bottom-=4
Four-pixel bottom (resize) border'
clnRect.left+=4
Four-pixel left (resize) border'
clnRect.right-=4
Four-pixel right (resize) border'
CopyMemory lParam,clnRect,Len

 Ret=0

()Private Sub InvalidateNC

 'refresh or invalidate don't work for the nonclient-area.
 'this sub forces a refresh for NC.    

SetWindowPos(Me.Handle,0,0,0,0,0,SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE Or
SWP_FRAMECHANGED)
End Sub 'invalidateNC

---

WM_NCCALCSIZE return flags
Global Const WVR_ALIGNTOP = &H0010
Global Const WVR_ALIGNLEFT = &H0020
Global Const WVR_ALIGNBOTTOM = &H0040
Global Const WVR_ALIGNRIGHT = &H0080
Global Const WVR_HREDRAW = &H0100
Global Const WVR_VREDRAW = &H0200
Global Const WVR_REDRAW = (WVR_HREDRAW Or WVR_VREDRAW)
Global Const WVR_VALIDRECTS = &H0400

WM_NCCALCSIZE parameter structure'
Type NCCALCSIZE_PARAMS
rgrc As Long
lppos As Long
End Type

Global Const MA_NOACTIVATEANDEAT = 4

Type WINDOWPOS
hwndInsertAfter As Long
hwnd As Long
x As Long
y As Long
cx As Long
cy As Long
flags As Long
End Type

Dim nccs  As NCCALCSIZE_PARAMS
Dim WndPos  As WINDOWPOS
MAGICNUMBER=23

Case WM_NCCALCSIZE


' Adjust the client area size calculation to allow for our tabstrip

 If (wParam <> 0) Then
'nccs->NCCALCSIZE Structure
(CopyMemory nccs,ByVal lParam,Len(nccs

(CopyMemory WndPos,ByVal nccs.lppos,Len(WndPos

  (With nccs.rgrc(0
     Left=nccsPos.x+2.
     Top=nccsPos.y+MAGICNUMBER.
     Right=(nccsPos.x+nccsPos.cX)-2.
     Bottom=nccsPos.y+nccsPos.cY)-2.
End With


(Set nccs.rgrc(1)=nccs.rgrc(0

(CopyMemory ByVal lParam,nccs,Len(nccs

 WndProc=WVR_VALIDRECTS

 
Else

WndProc =CallWindowProc(mlpfnOldWindowProc

(hWnd,uMsg,wParam,lParam,

End If

Case WM_NCPAINT

  GetWindowRect hWnd,WndRect

  GetDCEx(hWnd,wparan,DCX_WINDOW or'

DCX_INTERSECTRGN'

  ( lhDC = GetWindiwDC(hWnd

....  BitBlt
  ReleaseDC hWnd, lhDC

WndProc =CallWindowProc(mlpfnOldWindowProc

(hWnd,uMsg,wParam,lParam

I was about to reply that I had been trying GetWindowDC and GetDCEx also until it occured to me that of course the coordinates are different... it works now Thanks so much

---

You can respond to the WM_NCCALCSIZEmessage, modify WndProc's default behaviour to remove the invisible border.

As this document and this documentexplain, when wParam > 0, On request wParam.Rgrc[0] contains the new coordinates of the window and when the procedure returns, Response wParam.Rgrc[0] contains the coordinates of the new client rectangle.

:The golang code sample



params.Rgrc(0).Top=params.Rgrc(2).Top params.Rgrc(0).Left=params.Rgrc(0).Left + 1
params.Rgrc(0).Bottom=params.Rgrc(0).Bottom-1
params.Rgrc(0).Right=params.Rgrc(0).Right-1
return 0x0300

Case WM_NCLBUTTONDOWN
            'pt = PointToClient(New Point(m.LParam.ToInt32()))
            'pt.Offset(I.BorderWidthLeft, I.BorderWidthTop)
       

---

منبع خارجی 

    

HITTEST

Type MARGINS

cxLeftWidth As Long

cxRightWidth As Long

cyTopHeight As Long

cyBottomHeight As Long 

End Type

Extends the window frame into the client area'

DwmExtendFrameIntoClientArea(hWnd, ByRef 

(MARGINS 

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

if (m.Msg=&H83 And WParam=1) Then

Dim nccsp As NCCALCSIZE_PARAMS

nccsp.rect0.Top+=30;

nccsp.rect0.Bottom+= -8;

nccsp.rect0.Left+= 8;

nccsp.rect0.Right += -8;

Ret=0

( else if m.Msg=&H84 And (Ret=0

(Ret=HitTestNCA(HWnd,WParam, LParam

else

(base.WndProc(ref m

End if 

(private HitTestNCA(hwnd,wparam,lparam

HTNOWHERE=0;

int HTCLIENT=1;

int HTCAPTION=2;

int HTMINBUTTON=8;

int HTMAXBUTTON=9;

int HTLEFT=10;

int HTRIGHT=11;

int HTTOP=12;

int HTTOPLEFT=13;

int HTTOPRIGHT=14

int HTBOTTOM=15;

int HTBOTTOMLEFT=16;

int HTBOTTOMRIGHT=17; 

'Getting the point where the mouse clicked... 

Dim p As POINT

(p.x=LoWord(lparam

(p.y=HiWord(lparam

'The ClientToScreen function converts 'the client-area'

coordinates of a specified 'point to screen coordinates

ClientToScreen hwnd,pt'

'The PtInRect function determines 'whether the'

specified point lies within 'the specified rectangle. A point is within 'a rectangle if it lies on the left or top side 'or is within all four sides. A point on the 'right or bottom side is considered 'outside the rectangle

(Ret=PtInRect(rc,nccsp.rect0'

Rectangle hdc,left,top,right,bottom'

(topleft=Rectangle(hdc,0, 0, 8, 8

if (topleft.Contains(p)) Then

(return=IntPtr(HTTOPLEFT

(topright=Rectangle(hdc,Width-8,0,8,8

if (topright.Contains(p)) Then

(Ret=IntPtr(HTTOPRIGHT

(botleft=Rectangle(hdc,0,Height-8,8,8

if (botleft.Contains(p)) Then 

(Ret=IntPtr(HTBOTTOMLEFT

(botright=Rectangle(hdc,Width-8,Height-8,8, 8

if (botright.Contains(p)) Then

(Ret=IntPtr(HTBOTTOMRIGHT

(top=Rectangle(hdc,0,0,Width,8

if (top.Contains(p)) Then

(Ret=IntPtr(HTTOP

(cap=Rectangle(hdc,0,8,Width,38-8

if (cap.Contains(p)) Then

(Ret=IntPtr(HTCAPTION

(left=Rectangle(hdc,0,0,8,Height

if (left.Contains(p)) Then

(Ret=IntPtr(HTLEFT

(right=Rectangle(hdc,Width-8,0,8,Height

if (right.Contains(p)) Then

(Ret=IntPtr(HTRIGHT

(bottom=Rectangle(hdc,0,Height-8,Width, 8

if (bottom.Contains(p)) Then

(Ret=IntPtr(HTBOTTOM

WM_MOUSEACTIVATE

.wParam: Handle to the active top-level parent window

LOWORD (lParam): Hit test value where the mouse is clicked. If you clicked the work area, the HTCLIENT 

.value is passed

HIWORD (lParam): The ID of the mouse message that caused this message. Depending on the return value of this message, mouse messages are either queued 

.or discarded

 : MA_ACTIVATE
Activates the window and does not discard mouse messages

: MA_ACTIVATEANDEAT
.Activates the window and discards mouse messages
: MA_NOACTIVATE
Does not activate Windows and does not discard mouse messages

 : MA_NOACTIVATEANDEAT
It does not activate the window nor discard the mouse message

The following example prints the letter "C" at a specific location on the screen, which can be moved with the left mouse button. As soon as the button is pressed, the position of the character changes, but it does not process mouse messages when it is changed from inactive to active

(WndProc(hWnd,Msg,wParam,lParam

Dim hdc As Long

Dim ps As PAINTSTRUCT

Dim Ret As Long

static x, y

Select Case Msg

case WM_MOUSEACTIVATE

Ret=MA_ACTIVATEANDEAT

case WM_LBUTTONDOWN

(x=LOWORD (lParam

(y=HIWORD (lParam

InvalidateRect  hWnd,0,TRUE

Ret=0

case WM_PAINT

(hdc=BeginPaint(hWnd,ps

TextOut hdc,x,y,"C",1

EndPaint hWnd, & ps

Ret=0

case WM_DESTROY

PostQuitMessage 0

Ret=0

((Ret=DefWindowProc(hWnd,Msg,wParam, lParam

---

 Process messages'
Public Function NewWindowProc(ByVal hwnd As Long,ByVal msg  As Long,ByVal wParam As Long,ByVal 

(lParam As Long
As  Long
Const WM_NCDESTROY=&H82

If we're being destroyed'
 restore the original WindowProc'
If msg=WM_NCDESTROY Then
SetWindowLong hwnd,GWL_WNDPROC,  OldWindowProc
End If
 See if a control was clicked'
If msg=WM_MOUSEACTIVATE Then
Form1.MouseClicked
NewWindowProc=CallWindowProc(OldWindowProc,hwnd,msg,wParam,lParam) End Function


()Public Sub MouseClicked
Dim pt As POINTAPI

See where the mouse is'
GetCursorPos pt
Convert into client coordinates'
ScreenToClient hwnd,pt
Draw a big X on the form where the mouse is'
Cls
(Line (pt.X - 50, pt.Y - 50)-(pt.X + 50, pt.Y + 50

(Line (pt.X + 50, pt.Y - 50)-(pt.X - 50, pt.Y + 50

End Sub 

---

Type tagNCCALCSIZE_PARAMS
RECT] rgrc[]'
rgrc0 As RECT
rgrc1 As RECT
rgrc2 As RECT
lppos
End Type

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

WM_NCLBUTTONDOWN

 allow to drag & move userform via control  Label1)
      

Private Declare Function ReleaseCapture Lib "user32" () As Long
 
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2

Dim hWndForm As Long

Private Sub UserForm_Initialize()
  hWndForm = FindWindow("ThunderDFrame", Me.Caption)
End Sub

Private Sub lb1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If Button = xlPrimaryButton Then
    Call ReleaseCapture
    Call SendMessage(hWndForm, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&)
  End If
End Sub

پیام ها

%MAX_TITLE_BUTTONS=8

%B_EDGE=2

 GLOBAL szPropName As String * 255? Or Byte

TYPE CaptionButton

uCmd AS LONG 'command to send when clicked

nRightBorder AS LONG 'Pixels between this button and buttons to the right

hBmp AS LONG 'Bitmap to display

fPressed AS LONG 'Private

END TYPE 

TYPE CustomCaption buttons(%MAX_TITLE_BUTTONS) AS CaptionButton

nNumButtons AS LONG

fMouseDown AS LONG

wpOldProc AS LONG

iActiveButton AS LONG

END TYPE

FUNCTION GetCustomCaption(hwnd) AS  Long

'CustomCaption

FUNCTION=GetProp(hwnd,szPropName) END FUNCTION

FUNCTION MakShort(BYVAL n AS LONG) AS LONG

IF n<=32768 THEN

MakeShort=n:EXIT FUNCTION

MakeShort=-1 *(65535-n) 

End Function

Sub RedrawNC(hwnd) As Long

SetWindowPos hwnd,0,0,0,0,0, SWP_NOMOVE OR SWP_NOSIZE OR SWP_NOZORDER OR SWP_NOACTIVATE OR SWP_DRAWFRAME) 

END SUB

FUNCTION CalcTopEdge(hwnd) AS LONG DIM dwStyle AS Long

dwStyle=GetWindowLong(hwnd,GWL_STYLE)

IF(dwStyle AND  WS_THICKFRAME)

THEN 

FUNCTION=GetSystemMetrics(SM_CYSIZEFRAME)

ELSE

FUNCTION=GetSystemMetrics(SM_CYFIXEDFRAME)

END IF

END FUNCTION

FUNCTION CalcRightEdge(hwnd) AS LONG

DIM dwStyle AS Long

dwStyle=GetWindowLong(hwnd,GWL_STYLE)

IF(dwStyle AND WS_THICKFRAME) THEN

FUNCTION=GetSystemMetrics(SM_CXSIZEFRAME)

ELSE

FUNCTION=GetSystemMetrics(SM_CXFIXEDFRAME)

END IF

END FUNCTION 

GetRightEdgeOffset(ctp * CustomCaption,hwnd) AS LONG

DIM dwStyle As Long

DIM dwExStyle AS Long

DIM nButSize AS LONG

DIM nSysButSize AS LONG

dwStyle=GetWindowLong(hwnd,GWL_STYLE)

dwExStyle=GetWindowLong(hwnd,GWL_EXSTYLE)

nButSize = 0 

nSysButSize=GetSystemMetrics(SM_CXSIZE)-B_EDGE

IF(dwStyle AND WS_SYSMENU) THEN nButSize=nButSize+nSysButSize+B_EDGE

END IF

IF (dwStyle AND (WS_MINIMIZEBOX OR WS_MAXIMIZEBOX) ) THEN

nButSize=nButSize+B_EDGE+nSysButSize * 2 

End if 

FUNCTION=nButSize+CalcRightEdge(hwnd)

GetButtonRect(ctp*CustomCaption, hwnd,idx,rct RECT,fWindowRelative AS LONG)

DIM i AS LONG,re_start AS LONG 

DIM cxBut AS LONG,cyBut AS LONG

DIM xLeft AS LONG,yTop AS LONG

cxBut=GetSystemMetrics(SM_CXSIZE) cyBut=GetSystemMetrics(SM_CYSIZE)

' right-edge starting point of inserted buttons

re_start=GetRightEdgeOffset(ctp,hwnd) 

GetWindowRect hwnd,rct

IF fWindowRelative=True THEN

OffsetRect rct,-1 * rct.Left, -1*rct.Top 

END IF

'Find the correct button - but take into 'account all other buttons. 

LOCAL nRightBorder AS LONG

FOR i = 0 To idx

re_start=re_start+nRightBorder+cxBut -B_EDGE

NEXT

rct.nLeft=rct.nRight-re_start

rct.nTop=rct.nTop+CalcTopEdge(hwnd)+ B_EDGE

rct.nRight=rct.nLeft+cxBut-B_EDGE

rct.nBottom=rct.nTop+cyBut-B_EDGE * 2 END SUB

FUNCTION Caption_NCHitTest(ctp AS CustomCaption PTR, hwnd,wParam, lParam) AS LONG

DIM rct AS RECT

DIM pt AS POINTAPI

DIM i AS LONG

DIM ret AS LONG

pt.x=LOWRD(lParam)

pt.y=HIWRD(lParam)

ret=CallWindowProc(ctp.wpOldProc,hwnd,WM_NCHITTEST,wParam,lParam)

'If the mouse is in the caption, then check to 'see if it is over one of our buttons 

IF (ret=HTCAPTION) THEN

FOR i=0 TO ctp.nNumButtons-1 

GetButtonRect ctp,hwnd,i,rct,FALSE

InflateRect rct,0,B_EDGE

'If the mouse is in any custom button, then 'We need to override the default behaviour.

IF PtInRect(rct,pt.x,pt.y) THEN

Caption_NcHitTest=HTBORDER

END IF

NEXT

END IF

Caption_NcHitTest=ret

END FUNCTION 

FUNCTION Caption_NCPaint(ctp AS CustomCaption,hwnd, hrgn) AS LONG 

DIM rct AS RECT,rct1 AS RECT

DIM fRegionOwner AS LONG

DIM i AS LONG

DIM hdc AS Long

DIM uButType AS LONG

DIM x AS LONG,y AS LONG

DIM hrgn1 AS Long

LOCAL nNumButtons AS LONG 

fRegionOwner=FALSE

GetWindowRect hwnd,rct

x=rct.left

y =rct.top

'Create a region which covers the whole window. This'

must be in screen coordinates'

IF hrgn=1 OR hrgn=0 THEN

(hrgn=CreateRectRgnIndirect(rct

fRegionOwner=TRUE

END IF

FOR i = 0 TO ctp.nNumButtons-1

Get button rectangle in screen coords '

GetButtonRect ctp,hwnd,i,rct1,FALSE 

(hrgn1=CreateRectRgnIndirect(rct1

Cut out a button-shaped hole'

CombineRgn hrgn,hrgn,hrgn,RGN_XOR 

DeleteObject hrgn1

NEXT 

(hdc=GetWindowDC(hwnd

Draw buttons in a loop'
FOR i = 0 TO ctp.nNumButtons-1
Get Button rect in window coords '
GetButtonRect ctp,hwnd,i,rct1,TRUE
uButType=DFCS_BUTTONPUSH
IF ctp.buttons(i).fPressed=True THEN DrawFrameControl hdc,rct,DFC_BUTTON, uButType OR DFCS_PUSHED
ELSE
DrawFrameControl hdc,rct,DFC_BUTTON, uButType
END IF
InflateRect rct1,-2,-2
rct1.Right=rct1.nRight-2
rct1.Bottom=rct1.Bottom-2
IF ctp.buttons(i).fPressed=True THEN OffsetRect rct1,1,1
END IF
NEXT
ReleaseDC hwnd,hdc
IF fRegionOwner=True THEN

DeleteObject hrg

Caption_NCPaint=0

END FUNCTION 

FUNCTION Caption_NCLButtonDown(ctp AS CustomCaption, hwnd,msg, wParam, lParam) AS Long
 'LRESULT
DIM i AS LONG
DIM rct AS RECT
DIM pt AS POINTAPI
pt.x=LOWRD(lParam)
pt.y=HIWRD(lParam)
 'If mouse has been clicked in caption
IF wParam=HTCAPTION THEN
FOR i=0 TO ctp.nNumButtons-1
GetButtonRect ctp,hwnd,i,rct,FALSE
InflateRect rct,0,2
'if clicked in a custom button
IF PtInRect(rct, pt.x,pt.y)=True THEN ctp.iActiveButton=i
ctp.buttons(i).fPressed= TRUE
ctp.fMouseDown=TRUE
SetCapture hwnd
RedrawNC hwnd
FUNCTION= 0:EXIT FUNCTION
END IF
NEXT
END IF
Caption_NCLButtonDown= CallWindowProc(ctp.wpOldProc,hwnd,msg,wParam,lParam)
END FUNCTION

FUNCTION Caption_LButtonUp(ctp AS CustomCaption, hwnd,wParam,lParam) AS LONG
'LRESULT
DIM rct AS RECT
DIM pt AS POINTAPI
DIM uCmd AS LONG
pt.x=LOWRD(lParam)
pt.y= HIWRD(lParam)
ClientToScreen hwnd,pt
IF ctp.fMouseDown=True THEN
ReleaseCapture
GetButtonRect(ctp,hwnd, ctp.iActiveButton,rct,FALSE)
InflateRect rct, 0,2
'if clicked in a custom button
IF PtInRect(rct, pt.x, pt.y)=True THEN
uCmd=ctp.buttons(ctp.iActiveButton).uCmd
SendMessage hwnd,WM_COMMAND, uCmd,MAKDWD(pt.x,pt.y)
END IF ctp.buttons(ctp.iActiveButton).fPressed=FALSE
ctp.fMouseDown=FALSE
RedrawNC hwnd
FUNCTION=0
EXIT FUNCTION
END IF
FUNCTION = CallWindowProc(ctp.wpOldProc,hwnd, WM_LBUTTONUP,wParam,lParam)
END FUNCTION 

FUNCTION Caption_MouseMove(ctp AS CustomCaption,hwnd, wParam, lParam) AS LONG
'LRESULT
DIM rct AS RECT
DIM pt AS POINTAPI
DIM fPressed AS LONG
pt.x=LOWRD(lParam)
pt.y=HIWRD(lParam)
ClientToScreen hwnd,pt
IF ctp.fMouseDown=True THEN
GetButtonRect ctp,hwnd,ctp.iActiveButton,rct,FALSE
InflateRect rct,0,2
fPressed=PtInRect(rct, pt.x,pt.y)
IF fPressed <> ctp.buttons(ctp.iActiveButton).fPressed THEN ctp.buttons(ctp.iActiveButton).fPressed= ctp.buttons(ctp.iActiveButton).fPressed XOR 1
RedrawNC hwnd
END IF
Caption_MouseMove=0:EXIT FUNCTION
END IF
Caption_MouseMove = CallWindowProc(ctp.wpOldProc,hwnd, WM_MOUSEMOVE,wParam,lParam)
END FUNCTION 

FUNCTION Caption_LButtonUp(ctp AS CustomCaption, hwnd,wParam,lParam) AS LONG
'LRESULT
DIM rct AS RECT
DIM pt AS POINTAPI
DIM uCmd AS LONG
pt.x=LOWRD(lParam)
pt.y= HIWRD(lParam)
ClientToScreen hwnd,pt
IF ctp.fMouseDown=True THEN
ReleaseCapture
GetButtonRect(ctp,hwnd, ctp.iActiveButton,rct,FALSE)
InflateRect rct, 0,2
'if clicked in a custom button
IF PtInRect(rct, pt.x, pt.y)=True THEN
uCmd=ctp.buttons(ctp.iActiveButton).uCmd
SendMessage hwnd,WM_COMMAND, uCmd,MAKDWD(pt.x,pt.y)
END IF ctp.buttons(ctp.iActiveButton).fPressed=FALSE
ctp.fMouseDown=FALSE
RedrawNC hwnd
FUNCTION=0
EXIT FUNCTION
END IF
FUNCTION = CallWindowProc(ctp.wpOldProc,hwnd, WM_LBUTTONUP,wParam,lParam)
END FUNCTION 

WM_NCHITTEST

مختصات صفحه               Screen Coordinate

برای تعیین اینکه چه بخشی از پنجره با یک مختصات صفحه خاص مطابقت دارد به عنوان مثال ، هنگامی که مکان نما حرکت می کند ، وقتی دکمه ماوس را فشار داده یا آزاد می شود 

این پیام از طریق تابع WindowProc خودش دریافت می شود.

در صورتیکه ماوس تسخیر نشود ، پیام به پنجره ای که  زیر مکان نما است ارسال می شود. در غیر این صورت ، این پیام به پنجره ای که ماوس را تسخیر کرده است ، ارسال می شود.

مقدار برگشتی تابع DefWindowProc یکی از مقادیر زیر است که نشانگر موقعیت نقطه داغ مکان نما است.

رنگ کنترل رسمی ( Custom Control) در SubClaasing

ساب کلاس کردن کنترل ترسیمی  ( تنها یک کنترل ) 

Type  cz As SIZE

cx As Long ' Width

cy As Long  ' Height

End Type 

Type CustCtrl

'Foreground text colour

crForeGnd As Long 

'Background text colour

crBackGnd As Long 

'The font

hFont As Long 

'The control's window handle

hwnd As Long 

End Type 

Painting the control

Whenever windows wants us to update the contents of our window (the client area), a WM_PAINT message will be sent. So, whenever the WM_PAINT message is received, we need to call our control’s painting routine.

case WM_PAINT

 CustCtrl_OnPaint ccp,wParam, lParam

(CustCtrl_OnPaint(ccp As CustCtrl,wParam,lParam

Dim  hdc As Long

Dim ps As PAINTSTRUCTHANDLE

Dim hOldFont As Long

Dim szText As String*200

Dim rc As RECT

Get a device context for this window'

(hdc=BeginPaint(ccp.hwnd,ps

Set the font we are going to use'

(hOldFont=SelectObject(hdc,ccp.hFont

Set the text colours'

SetTextColor hdc,ccp.crForeGnd

SetBkColor  hdc,ccp.crBackGnd

Find the text to draw'

(GetWindowText ccp.hwnd,szText, Len(szText

Work out where to draw'

GetClientRect ccp.hwnd,rc

computes the width and height of the '

.specified string of text'

GetTextExtentPoint32 hdc,szText, len(szText),sz

Center the text'

x=(rc.right-sz.cx)/2

y=(rc.bottom-sz.cy)/2

Draw the text'

ETO_OPAQUE'

The current background color should be used to fill'

the rectangle'

ExtTextOut hdc,x,y,ETO_OPAQUE,rc,szText,len(szText),0

Restore the old font when we have finished'

SelectObject hdc,hOldFont

Release the device context'

EndPaint ccp.hwnd,ps

return 0

---

The GWL_USERDATA area

Every window in the system has a 32bit integer which can be set to any value. This 4 byte storage area is enough to store a pointer to a structure. We set this integer using SetWindowLong, and retrieve the integer using GetWindowLong. Using this technique, our function will look like this:

(GetCustCtrl(hwnd
return=GetWindowLong(hwnd,GWL_USERDATA

(SetCustCtrl(ByVal hwnd As Long,ByRef ccp As CustCtrl

SetWindowLong hwnd,GWL_USERDATA,ccp

This method is usually used when subclassing a control

---

Memory allocated by HeapAlloc is not movable. The address returned by HeapAlloc is valid until the memory block is freed or reallocated; the memory 

.block does not need to be locked

To free a block of memory allocated byHeapAlloc, use 

.the HeapFree function

---

Our custom control will change colour whenever the user clicks the mouse on it. Therefore the next message handler will be for the 

.WM_LBUTTONDOWNmessage

case WM_LBUTTONDOWN

CustCtrl_OnLButtonDown ccp, wParam, lParam


CustCtrl_OnLButtonDown(ByRef ccp As 

(CustCtrl,wParam,lParam
(col=RGB(rnd()*256,rnd()*256,rnd()*256 

Change the foreground colour'
ccp.crForeGnd=col
Use the inverse of the foreground colour'

(ccp.crBackGnd=((col) And &Hffffff
Now redraw the control'
InvalidateRect ccp.hwnd,0,0
UpdateWindow ccp.hwnd
return 0

WM_MOUSEACTIVATE=&H21

'Activates the window, and does not discard the mouse'

.message
MA_ACTIVATE =1

case WM_MOUSEACTIVATE
    SetFocus hwnd
    return MA_ACTIVATE

قلاب کردن پنجره HOOK و دسترسی به کلاس های آن از طریق Subclass کردن

در WIN32 : 

Private Type CWPSTRUCT

lParam As Long

wParam As Long

message As Long

hwnd As Long

End Type

End Type 

Private Const SWP_FRAMECHANGED=&H20

Private Const SWP_NOSIZE=&H1

Private Const SWP_NOZORDER=&H4

Private Const WH_CALLWNDPROC=4

(Private Const GWL_WNDPROC=(-4

Private Const WM_GETFONT=&H31

Private Const WM_CREATE=&H1

Private Const WM_CTLCOLORBTN=&H135

Private Const WM_CTLCOLORDLG=&H136

Private Const WM_CTLCOLORSTATIC=&H138

Private Const WM_CTLCOLOREDIT=&H133

Private Const WM_DESTROY=&H2

Private Const WM_SHOWWINDOW=&H18

Private Const WM_COMMAND=&H111

Private Const BN_CLICKED=0

Private Const IDOK=1

 

Private Const EM_SETPASSWORDCHAR =&HCC

Private INPUTBOX_HOOK As Long

Private INPUTBOX_HWND As Long

Private INPUTBOX_PASSCHAR As String

Private INPUTBOX_FONT As String

Private INPUTBOX_SHOWING As Boolean

Private INPUTBOX_OK As Boolean

Public Function InputBoxEx(ByVal Prompt As String,Optional ByVal Title As String,Optional ByVal FontName As String,Optional ByVal FontSize As Long, Optional ByVal PasswordChar As String,Optional ByVal CancelError As Boolean = False) As String

"INPUTBOX_FONT="MS Sans Serif

INPUTBOX_FONTSIZE=8

INPUTBOX_PASSCHAR=PasswordChar

If Len(FontName) Then INPUTBOX_FONT=FontName

If FontSize>0 Then INPUTBOX_FONTSIZE=FontSize

INPUTBOX_SHOWING = True

INPUTBOX_HOOK=SetWindowsHookEx(WH_CALLWNDPROC,AddressOf 

(HookWindow,0,GetCurrentThreadID

(InputBoxEx=InputBox(Prompt,Title,Context

INPUTBOX_SHOWING=False

 Remove The Hook'

(UnhookWindowsHookEx(INPUTBOX_HOOK

If Not INPUTBOX_OK And CancelError Then Err.Raise vbObjectError + 1, , "User Pressed " & Chr(34) & "Cancel" & Chr(34)

End Function

Private Function HookWindow(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Dim tCWP As CWPSTRUCT

This is where you need to Hook the Inputbox'

(CopyMemory tCWP, ByVal lParam, Len(tCWP

If tCWP.message=WM_CREATE Then

     If ClassName ="#32770" Then

         If INPUTBOX_SHOWING Then

INPUTBOX_HWND=SetWindowLong(tCWP.hwnd,GWL_WNDPROC,AddressOf 

(InputBoxProc

          End If

     End If

End If HookWindow=CallNextHookEx(INPUTBOX_HOOK,nCode,wParam,ByVal lParam)

End Function

Private Function InputBoxProc(ByVal hwnd As Long,ByVal Msg As Long, ByVal wParam As Long,ByVal lParam As Long) As Long

Select Case Msg

    Case WM_COMMAND

        '..Check to see if the OK Button was Pressed'

       lNotify=Val("&H" & Left$(Right$("00000000" & Hex$(wParam), 8), 4))

       lID = Val("&H" & Right$(Right$("00000000" & Hex$(wParam), 8), 4))

       If lNotify = BN_CLICKED Then

          (INPUTBOX_OK = (lID = IDOK

       End If

Case WM_SHOWWINDOW

      GetWindowRect(hwnd, tRECT

     SetWindowPos hwnd,0, tRECT.Left,tRECT.Top,0,0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_FRAMECHANGED)

Case WM_CTLCOLORDLG,WM_CTLCOLORSTATIC,WM_CTLCOLORBTN,WM_CTLCOLOREDIT

.

.

.

If Msg=WM_CTLCOLORSTATIC Then
Set the Font'
lFont=CreateFont(((INPUTBOX_FONTSIZE/72)*96),0,0,0,0,0,0,0,0,0,0,0,0, 

(INPUTBOX_FONT
SelectObject wParam,lFont
End If

tLB.lbColor=INPUTBOX_BACKCOLOR

(InputBoxProc = CreateBrushIndirect(tLB

 Case WM_DESTROY

    Remove the Inputbox Subclassing'

Call SetWindowLong(hwnd,GWL_WNDPROC, INPUTBOX_HWND)

End Select

InputBoxProc=CallWindowProc(INPUTBOX_HWND,hwnd,Msg,wParam,ByVal lParam)

End Function

قلاب کردن InputBox برای ارسال پیام ویندوزی به آن HOOK /SUBCLASS

تست نشده ولی جواب خواهد داد توابع برای استفاده در Win32 است در Win64 نحوه ی اظهار توابع فرق میکند که در لینک توابع API  در [ پیوندها ] ،  نحوه ی صحیح آن در سایت خارجی درج شده.

Option Explicit 

Necessary constants  for hooking '

Private Const HCBT_ACTIVATE=5

Public Const WH_CBT=5 

Constants for password masking '

Public Const EM_SETPASSWORDCHAR= &HCC 

 Working variables that require global scope in hooking'

module 

Private hHook As Long 

 The API declarations we need Private'

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 

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

Declare Function SendMessage Lib "user32" Alias

 SendMessageA" (ByVal hwnd As Long, ByVal wMsg"

As Long, ByVal wParam As Long, lParam As Any) As Long

Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long

Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long 

 Wrapper for the normal InputBox function'

Public Function vbInputBox(Prompt As String, Optional Title As String, Optional Default As String, Optional Xpos As Single, Optional YPos As Single, Optional Helpfile As String, Optional Context As Long) As String 

Optional Buttons As VbMsgBoxStyle = vbOKOnly,'

Optional Title As String, Optional HelpFile As String,' 

Optional Context As Long) As Long ,'

hHook=SetWindowsHookEx(WH_CBT, AddressOf 

(CBTProc,GetModuleHandle(vbNullString), 0

vbInputBox=InputBox(Prompt, Title, Default, Xpos, 

(YPos, Helpfile, Context)

 End Function

Function Private Function CBTProc(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Dim hwndEditControl As Long 

If lMsg=HCBT_ACTIVATE And ClassName="#32770" Then

("","hwndEditControl=FindWindowEx(wParam,0,"Edit

 get the edit control'

If hwndEditControl Then

Do your stuff here to modify the window'

SendMessage hwndEditControl,

EM_SETPASSWORDCHAR, Asc("*"), 0,

Immediately unhook'

UnhookWindowsHookEx hHook

End If

'allow operation to continue'

CBTProc = 0

End Function

---

مثال دیگر از فروم خارجی 

Private Declare Function CallNextHookEx Lib "user32

ByVal hHook As Long,ByVal ncode As Long, ByVal)

wParam As Long, lParam As Any) As Long

Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long

Private 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

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

Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _ ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long 

'Constants to be used in our API functions 

Private Const EM_SETPASSWORDCHAR =&HCC

Private Const WH_CBT=5

Private Const HCBT_ACTIVATE=5

Private Const HC_ACTION=0

Private hHook As Long 

Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Dim RetVal

If lngCode<HC_ACTION Then

(NewProc=CallNextHookEx(hHook,lngCode,wParam,lParam

Exit Function

End

If lngCode=HCBT_ACTIVATE Then

A window has been activated'

If ClassName="#32770" Then

Class name of the Inputbox'

 This changes the edit control'

SendDlgItemMessage wParam,&H1324, EM_SETPASSWORDCHAR,Asc("*"),&H0

End If

End If

CallNextHookEx hHook,lngCode,wParam, lParam

End Function

Function InputBoxDK(Prompt,Title) As String

Dim lngModHwnd As Long,lngThreadID As Long

lngThreadID=GetCurrentThreadId lngModHwnd 

(GetModuleHandle(vbNullString

hHook=SetWindowsHookEx(WH_CBT, AddressOf 

(NewProc,lngModHwnd,lngThreadID

(InputBoxDK=InputBox(Prompt,Title

UnhookWindowsHookEx hHook

End Function

GWL_USERDATA

When you send a WM_CLOSE message to a window, it tries to close the window as if the X button were pressed.You cannot know whether the application was closed externally or by clicking the X button

But there is an easy alternative. When you are closing the window externally using WM_CLOSE, you can initialize its 32-bit user data value using the SetWindowLong function before sending the message. In the target application (being closed) you will query this user data using GetWindowLong function and execute your code accordingly.

The user data value is set to 0 by default. You can set it to any non-zero value before sending the WM_CLOSE 

.message

Set the user data value of the target window to -1'

(originally 0)'

WIN32'

SetWindowLong CurrApp,GWL_USERDATA,-1

send closing messgae'

CurrApp is a Handle to the window

&SendMessage CurrApp,WM_CLOSE, 0,ByVal 0

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

    If GetWindowLong(hwnd, GWL_USERDATA) = 0 Then

        MsgBox "Closing from X."

    Else '(if -1)

        MsgBox "Closing externally using WM_CLOSE."

    End If

End Sub

گرفتن عرض بوردر ادیت کنترل

SM_CXBORDER=4

'The width of a window border, in pixels. This is equivalent to the SM_CXEDGE value for windows with the 3-D look.

SM_CYBORDER=6   in pixles

SM_CYCAPTION=4  in pixles

SM_CXEDGE=45,SM_CYEDGE=46

'The width And Height of a 3-D border, in pixels. This metric is the 3-D counterpart of SM_CXBORDER.

SM_CXSIZE=30, SM_CYSIZE=31

The width And Height of a button in a window caption'

.or title bar, in pixels

An edit control sends notification codes to its parent window in the 

.form of WM_COMMANDmessages

در کنترل HIWORD پارامترهای آرگومان wparam میشود notification code و LOWORD آن آیدی کنترل و lParam هم هندل کنترل میشود hwndControl

force the edit control to update its non-client area '

SetWindowPos hwndControl,0,0,0,0,0, SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE Or SWP_NOZORDER

POSTMESSAGE

بررسی وجود باتن MAXIMIZE در پرنت ویندو WIN32

Const GWL_EXSTYLE = -20
Const GWL_HINSTANCE = -6
Const GWL_HWNDPARENT = -8
Const GWL_ID = -12
Const GWL_STYLE = -16
Const GWL_USERDATA = -21
Const GWL_WNDPROC = -4
Const DWL_DLGPROC = 4
Const DWL_MSGRESULT = 0
Const DWL_USER = 8

در ویندوز ۳۲ بیتی  : 

Public Declare Function GetWindowLong Lib "user32.dll" Alias GetWindowLongA" (ByVal hWnd 

As Long,ByVal nIndex As Long) As Long 

Public Const GWL_STYLE=-16

Public Const WS_MAXIMIZEBOX= &H10000

()Private Sub Command1_Click

Dim styles As Long

 receives window styles of Form1'

Get the window styles of Form1'

(styles=GetWindowLong(Me.hWnd,GWL_STYLE

Determine if a maximize box exists or not'

If (styles And WS_MAXIMIZEBOX)= WS_MAXIMIZEBOX Then

".Debug.Print "The form window has a maximize box

Else

Debug.Print "The form window does not have a 

".maximize box

End If

End Sub

انجام پروژه های کوچک

لطفا درخواست پروژه های ( فقط اکسس )  خود را به جی میل [e-mail] ارسال کرده تا بررسی و قیمت ارائه گردد