کلینیک فوق تخصصی اکسس ( کاربرد vba در اکسس )

کلینیک فوق تخصصی اکسس ( کاربرد vba در اکسس )

به اشتراک گذاری اطلاعات کسب شده در اکسس از سایت آفیس و سایت های تخصصی خارجی
کلینیک فوق تخصصی اکسس ( کاربرد vba در اکسس )

کلینیک فوق تخصصی اکسس ( کاربرد vba در اکسس )

به اشتراک گذاری اطلاعات کسب شده در اکسس از سایت آفیس و سایت های تخصصی خارجی

پیام WM_SETCURSOR برای تغییررنگ Custom Button


 




 getdlgctrlid : Retrieves the identifier of the 

.specified control




بر گرفته از فروم خارجی  ( بررسی  موقعیت ماوس در باتن موردنظر )


1-find your button rectangle

GetWindowRect BtnHwnd,BtnRect

2-transform form client coordinate in screen coordinate
ClientToScreen BtnRect,pt
(those 2 points in OnInitDialog or equivalent)
3-in OnMouseMove function check if mouse point is inside BtnRect (use PtInRect(BtnRect,pt) and if it is then do what u want to do.The mouse point u can found it this way:Dim pt As POINT
(pt.x = LOWORD(lParam
(pt.y = HIWORD(lParam


WM_SETCURSOR. Do not change anything, just detect if wParam is HWND of your button. If it is, then set a 
flag (some BOOL) and InvalidateRect(..) your button. 
#define WM_SETCURSOR                    0x0020

تست شده طبق توصیه ی دوست خارجی 
Case WM_SETCURSOR
      Dim cc As RECT
      (hdc = GetWindowDC(can
      GetClientRect can, cc ' Necessary
can is handle of Cancel Button'       
      If wParam = can Then
      ((FillRect hdc, cc, CreateSolidBrush(RGB(255, 0, 0
      ReleaseDC can, hdc
      Else
InvalidateRect' 
      InvalidateRect can, cc, False
      End If


Hook کردن MsgBox و Subclass کردن تغییر حالت باتن ها به BS_OWNERDRAW  در ENUMCHILDPROC و گرفتن  آیدی های باتن فرضا IDYES=6 و IDNO=7 و IDCANCEL=2 با GetDlgCtrlID که در مثال زیر در ناحیه کنترل Static در آخرش آیدی ها پرینت شده.
آیدی ها درمتغید تعریف شده بنام GetBtn  ذخیره شده و با تابع Split  در اکسس جدا شده ودر لوپ گذاشته شده این متد فقط با پیام DRAWITEN انجام میشود و پیام CTLCOLORBTN جواب نخواهد داد.

Case WM_DRAWITEM
  
 Dim pDIS As DRAWITEMSTRUCT
   Dim state
   Dim p As RECT
   Dim pdc As LongPtr
   Dim OldBr As LongPtr
 


   ("," ,SplitBtn = Split(GetBtn
     (For i = 0 To UBound(SplitBtn
      (CopyMemory pDIS, ByVal lParam, Len(pDIS
      DeleteObject OldBr
      
     (( BtnHwnd = GetDlgItem(lhwnd, SplitBtn(i
      p = pDIS.rcItem
      pdc = pDIS.hdc
      (hdc = GetWindowDC(pdc
      pDIS.hwndItem = BtnHwnd
      GetClientRect pDIS.hwndItem, p
      ,OldBr=SelectObject(hdc
((CreateSolidBrush(RGB(100, 0, 135
      RoundRect hdc, p.Left, p.Top, p.Right, p.Bottom, 16, 16
      ReleaseDC BtnHwnd, hdc
      DeleteObject OldBr
      (CopyMemory ByVal lParam, pDIS, Len(pDIS
          Next


 Case WM_SETCURSOR
      Dim cc As RECT
      Dim txt
      
(" ,",SplitBtn = Split(GetBtn
    (For j = 0 To UBound(SplitBtn
DeleteObject OldBr   
((BtnHwnd = GetDlgItem(lhwnd, SplitBtn(j   
(txt = GetText(BtnHwnd    
GetClientRect BtnHwnd, cc    
(hdc = GetWindowDC(BtnHwnd    
GetClientRect BtnHwnd, cc    
If wParam = BtnHwnd Then
            cc.Left = cc.Left + 2.5     
            cc.Top = cc.Top + 2.5     
            cc.Right = cc.Right - 2.5     
            cc.Bottom = cc.Bottom - 2.5     
 (( FillRect hdc, cc, CreateSolidBrush(RGB(255, 0, 0
  DrawText hdc, txt, Len(txt), cc, DT_CENTER            ReleaseDC BtnHwnd, hdc
DeleteObject OldBr 
       Else
InvalidateRect BtnHwnd, cc, False
ReleaseDC BtnHwnd, hdc
DeleteObject OldBr
      End If  
      Next
      
SetBkMode hdc,0'



پیام WM_PAINT جهت رنگ Client و WM_DRAWITEM برای باتن ساخته شده بجای باتن CANCEL


تست شده 


The WM_PAINT message is sent when the system or another application makes a request to paint a portion 

  of an application's window


The PAINTSTRUCT structure contains information that can be used to paint the.client area of a window

حاوی اطلاعاتی برای استفاده در نقاشی ناحیه ی Client پنجره.



Case WM_PAINT

Dim ps As PAINTSTRUCT

    ( hdc = BeginPaint(lhwnd, ps

     Dim rrc As RECT

     GetClientRect lhwnd, rrc 

  (( FillRect hdc, rrc, CreateSolidBrush(RGB(100, 0, 100

     SetTextColor hdc, vbRed

     TextOutA hdc, 10, 10, "sa", 2

     EndPaint lhwnd, ps

     ReleaseDC lhwnd, hdc


البته غیر از پیام زیر میشود با پیام WM_CTLCOLORBTN  هم  رنگ باتن  را تغییر داد که lParam میشود هندل باتن و wParam هم هندل DC میشود


Case WM_DRAWITEM

   Dim pDIS As DRAWITEMSTRUCT

   Dim state

   (CopyMemory pDIS, ByVal lParam, Len(pDIS

  ( hdc = GetDC(pDIS.hdc

   Dim p As RECT

   p = pDIS.rcItem

   state = pDIS.itemState

  GetClientRect can, p

   If pDIS.CtlID = 2 Then

   If state = 272 Then       

  RoundRect hdc, p.Left, p.Top, p.Right, p.Bottom, 16, 16  

ReleaseDC can, hdc  

  Else         

  RoundRect hdc, p.Left, p.Top, p.Right, p.Bottom, 4, 4       

  ReleaseDC can, hdc      

 End If     

   End If

   (CopyMemory ByVal lParam, pDIS,Len(pDIS



زمان کلیک روی باتن کنسل  مکث عمل RounRect را نمایش داده و پنجره بسته میشود.


If state = 785 Then  '272
  RoundRect hdc, p.Left, p.Top, p.Right, p.Bottom, 16, 16
  Sleep 400
  ReleaseDC can, hdc

If (pDIS.itemState And???
ODS_SELECTED)=ODS_SELECTED Then




طبق داکیومنت آفیس  (WM_CTLCOLORBTN) :

در موارد بالا حتما باید BS_OWNERDRAW تنظیم شود برای کل باتن ها که هندل میشود هندل Dlg و برای باتن خاص هندل همان باتن فقط ،   setwindowlongptra را در WIN64 ببینید.
See For Button Control button-styles
See For Static Control static-control-styles
wParam
An HDC that specifies the handle to the display context for the button
lParam
)An HWND that specifies the handle to the button
getdlgitem : Retrieves a handle to a control in the 
(specified dialog box

hdc=wParam '
Case WM_CTLCOLORBTN
if lparam=GetDlgItem(hwnd,IDCANCEL) then
.
End if
Exit Function



The idea is to add your own Windows message handler, you can do this using 
.SetWindowsHookEx function
Don't forget : Before terminating, an application must call the UnhookWindowsHookEx function to free 
system resources associated with the hook

پیام WM_NOTIFY ( زمانیکه واقعه ای اتفاق می افتد )



Custom Draw Item State '
CDIS_SELECTED =&H1
            CDIS_GRAYED =&H2
            CDIS_DISABLED =&H4
            CDIS_CHECKED = &H8
            CDIS_FOCUS = &H10
            CDIS_DEFAULT =&H20
            CDIS_HOT = &H40
            CDIS_MARKED =&H80
            CDIS_INDETERMINATE =&H100


CDIS_HOT : ("The item is currently under the pointer 

("hot




Type NMHDR
hwndFrom As Long  ' Window handle of control sending message
idFrom As Long ' Identifier of control sending message
code As Long  ' Specifies the notification code
End Type

Type NMCUSTOMDRAWINFO
    hdr As NMHDR
    dwDrawStage As Long
    hdc As LongPtr
    rc As RECT
    dwItemSpec As Long
    iItemState As Long
    lItemLParam As Long
End Type

Const WM_NOTIFY& = &H4E


Case WM_NOTIFY

Dim some_item As NMHDR

CopyMemory some_item,Byval
(lparam,Len(Some_item

 
if some_item.idFrom=IDOK And some_item.code=NM_CUSTOMDRAW Then 
 Dim item As NMCUSTOMDRAWINFO


(CopyMemory item,ByVal lParam,Len(item

(if (item.uItemState=CDIS_HOT
'Our mouse is over the button
'Select our color when the mouse hovers our button 
if (hotbrush=0) Then 
(hotbrush=CreateSolidBrush(RGB(255, 230,255
((pen=CreatePen(PS_INSIDEFRAME,0, RGB(0, 0, 0
(old_pen=SelectObject(item.hdc,pen
(old_brush=SelectObject(item.hdc,hotbrush
(RoundRect(item.hdc,item.rc.left,item.rc.top,item.rc.right,item.rc.bottom,5,5
(CopyMemory ByVal lParam,item,Len(item
SelectObject item.hdc,old_pen
(SelectObject item.hdc,old_brush
DeleteObject pen
End If
CopyMemory ByVal 
(lParam,Some_item,Len(Some_item


WM_MOUSEMOVE در Custom Draw Control



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


Dim r As RECT
(HWND h=GetDlgItem(hwndDlg,IDC_YOURCTLID
GetWindowRect h, r ' get window rect of control relative to screen
POINT pt={r.left,r.top } 'new point object using rect x, y
Above means ->>>??? pt.x=r.left:pt.y=r.top '
ScreenToClient hwndDlg,pt ' convert screen co-ords to
 client based points
example if I wanted to move said control'
-MoveWindow h,pt.x,pt.y+15,r.right-r.left, r.bottom
(r.top,TRUE
 r.right - r.left, r.bottom - r.top to keep control at its '
current size


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

(void CMyButton::OnTimer(UINT nIDEvent

()DWORD GetMessagePos'
Point p(GetMessagePos
Dim p As PONIAPI And p=GetMessagePos ??? '
'BOOL ScreenToClient(HWND hWnd,LPPOINT lpPoint'
ScreenToClient hBtn ,p

(Get the bounds of the control (just the client area '
 CRect rect
(BOOL GetClientRect(HWND hWnd,LPRECT lpRect'
GetClientRect hBtn,rect

 Check the mouse is inside the control '
(BOOL PtInRect(const RECT *lprc,POINT pt'
if PtInRect(rect,p)<>0 Then
Else
 ...if not then stop looking '
m_bOverControl=FALSE
(BOOL KillTimer(HWND hWnd,UINT_PTR uIDEvent'
KillTimer lhwnd,m_nTimerID
 ...and redraw the control '
  InvalidateRect ? Or Redraw 

CButton::OnTimer(nIDEvent ??? '

رسم ۳ باتن در TitleBar

X,y طبق POINTAPI در lParam 

(x = CLng(lParam) And &HFFFF& 'LoWord(lParam

  (y = CLng(lParam) \ 65535  ' LoWord(lParam


در پیام WM_NCPAINT


Private  tBtn As RECT

Dim i As Integer

Dim C As Integer

C=10

Gap=0

For i=0 To 2

GetClientRect lhwnd,tBtn

With tBtn

(Bottom=GetSystemMetrics(SM_CYCAPTION.

Left=.Right-c-Gap.

Right=.Right+18.

Top=.Top+4.

End With

C=C+28

Gap=2

Next





کپی شده از فروم های خارجی چنانچه در MsgBox  تست شود تصویر گذاشته خواهد شد 


Public Const SM_CXSIZE = 30

Public Const SM_CYSIZE = 31

Public Const SM_CXFRAME = 32

Public Const SM_CYFRAME = 33


Dim closeRect As RECT
(hDC=GetWindowDC(lhwnd
closeRect.left=rc.right-rc.left-20
(closeRect.top=GetSystemMetrics(SM_CYFRAME
closeRect.right=rc.right-rc.left-5
(closeRect.bottom=GetSystemMetrics(SM_CYSIZE
DrawFrameContro
hDC,closeRect,DFC_CAPTION,DFCS_CAPTIONCLOSE
 ???m_rcClose=closeRect
ReleaseDC dc

////////////////////////


Private Const DHT_CLOSE As Long=20
Private DHT_CAPTION As Long=2
Dim m_LastHit As Long
Dim m_ButtonDown As Long
Dim m_rcClose As RECT 

Public Const HTCLIENT=1    ' in a client area
Public Const HTCAPTION=2 ' in a title bar
Public Const HTCLOSE=20   ' in a close button
Public HTMAXBUTTON=9 ' in a Maximize Button
Public HTMINBUTTON=8 ' in a Minimize Button

(Private Sub OnNcActivate(bActive As Boolean
()Call OnNcPaint
OnNcActivate=TRUE
End Sub

()Private Sub OnNcPaint
.
.
.
DrawFrameControl hDC,closeRect,DFC_CAPTION,DFCS_CAPTIONCLOSE
m_rcClose = closeRect
ReleaseDC hDC
End Sub 

(Private Sub HitTest(pt As POINAPI
CRect rect=m_rcClose'
(if rect.PtInRect(pt' 
(if PtInRect(m_rcClose,pt
HitTest=DHT_CLOSE
else
HitTest=DHT_CAPTION
End If




(OnNcLButtonDown(UINT nHitTest, CPoint point

CPoint pt=point

ScreenToClient pt

pt.y += GetSystemMetrics(SM_CYCAPTION) +
GetSystemMetrics(SM_CYFRAME);
pt.x += 5

hitTest=HitTest(pt)

Select Case hitTest

case DHT_CLOSE

CWindowDC dc(this)
DrawFrameControl dc.m_hDC,
m_rcClose,
DFC_CAPTION,
DFCS_CAPTIONCLOSE +DFCS_PUSHED)
m_LastHit=hitTest
m_ButtonDown=hitTest
SetCapture lhwnd
End Select



روش های زیر فقط برای باتن در صورتیکه Resize انجام نشود تست شده. 

بنده آدم بی سوادی هستم  ولی بخاطر اینکه به این مرحله با کمک فروم های خارجی رسیدم احساس رضایت میکنم  بنابراین کمک کوچکیست برای بقیه ی افراد تا زمانشون از دست نره ... روش زیر طبق تصاویر کاملا تست شده اگر مشکلی در کدها بود لطفا مهندسان کامپیوتر در نظرها درست آن را برای بقیه به اشتراک بگذارند از این قبیل کدها در VBA کم هست یا روش های سخت تری هست.

برداشتن منوهای سیستمی در NonClient Region  ا ز طریق Hook و Subclass Specified Window 

SetWindowLongPtr wnd(#32770), GWL_STYLE,
 GetWindowLong(wnd, GWL_STYLE) And Not WS_SYSMENU

تست شده برای کلوز باتن ایجاد شده 
Case WM_NCLBUTTONDOWN
Dim ptp As POINTAPI
    GetCursorPos ptp
 Get Position of Left Window In Screen'
     GetWindowRect lhwnd, wRect

Dim p1 As POINTAPI  ' Top & Left
     Dim p2 As POINTAPI  ' Right & Bottom
     
     p1.x = wRect.Left + tCloseRect.Left ' Left
     p1.y = wRect.Top + tCloseRect.Top   ' Top
     
     p2.x = wRect.Left + tCloseRect.Right ' Right
     p2.y = wRect.Top + tCloseRect.Bottom ' Bottom

 _  If ptp.x > wRect.Left + tCloseRect.Left And ptp.x < wRect.Left + tCloseRect.Right 
     And ptp.y > wRect.Top + tCloseRect.Top And ptp.y < wRect.Top + tCloseRect.Bottom Then
(hdc = GetWindowDC(lhwnd
      DrawFrameControl hdc, tCloseRect, DFC_BUTTON, DFCS_PUSHED
      ReleaseDC lhwnd, hdc
      SendMessageA lhwnd, WM_CLOSE, 0, 0'
     End If

مثال دیگر روی MsgBox در پیام   WM_NCLBUTTONDOWN   و تعریف tcloseRect,Btn در آغاز کدنویسی Btn در پیام Create یا ShowWindow و  Destroy به False تنظیم شود متغیرهای ذکر شده گلوبال هستند .
x1,y1 در اینجا طبق خط اول این تاپیک منظور x و  y که از lParam که نشانگر کرسر هست در پیام استفاده شده .

در کدهای زیر زمان فشردن باتن چپ ماوس در ناحیه NonClient و در X,y گرفته شده باتن به حالت Pushed و بعد از مکث کنی به حالت اول برمی گردد.

در کد زیر از GetWindowRect برای گرفتن Left پنجره از دسکتاپ استفاده شده که به POINT داده میشود .اگر  GetClientRect استفاده کنید Left را صفر میدهد پس حواستون جمع باشه.

_  If x1 > wrect.Left + tCloseRect.Left And x1 < wrect.Left + tCloseRect.Right 
      And y1 > wrect.Top + tCloseRect.Top And y1 < wrect.Top + tCloseRect.Bottom Then
      btn = True
      &SendMessageA lhwnd, WM_NCPAINT, 0&, 0
      btn = False
      Sleep 150
      &SendMessageA lhwnd, WM_NCPAINT, 0&, 0
      End If
     Exit Function
در پیام WM_NCPAINT 

If btn = True Then
      DrawFrameControl hdc, tCloseRect, DFC_BUTTON, DFCS_PUSHED
      ElseIf btn = False Then
      DrawFrameControl hdc, tCloseRect, DFC_BUTTON, DFCS_BUTTONPUSH   ' DFCS_PUSHED
      End If


 در مثال زیر در صورت کلیک در باتن کلوزحالت به Pushed  تغییر کرده بعد از مکث دوبار به حالت ButtonPush تغییر و بعد از مکث خیلی کوتاه پنجره بسته میشود. همانطور که میبینید عملکرد باتن طبق پیامی که به پنجره ارسال میشود انجام میگیرد یعنی NC_PAINT.

_  If x1 > wrect.Left + tCloseRect.Left And x1 < wrect.Left + tCloseRect.Right
      And y1 > wrect.Top + tCloseRect.Top And y1 < wrect.Top + tCloseRect.Bottom Then
      btn = True
      &SendMessageA lhwnd, WM_NCPAINT, 0&, 0
      btn = False
      Sleep 150
     & SendMessageA lhwnd, WM_NCPAINT, 0&, 0
      Sleep 20
     & SendMessageA lhwnd, WM_CLOSE, 0&, 0
      End If






Gradient Button ( باتن با سطح شیب دار) / DrawCloseButton ( رسم باتن کلوز )



Dim rc As RECT
rc.left = 0
rc.top = 0
rc.right = 260
rc.bottom = 80
Dim hpen
draw gradient button'
Dim i As Integer
i=0
Do
((hpen=CreatePen(PS_SOLID,4,RGB(150-i,0,0
SelectObject hdc, hpen
Rectangle hdc, 0, 0 + i, 262, 1 + i
DeleteObject hpen
(SetBkColor hdc,RGB(130,0,0
(SetTextColor hdc, RGB(255,255,255
TextOut hdc,90,27,"Hello World",11
i=i+1
Loop Until i<80

PS_SOLID=0
PS_DASH=1
PS_DOT=2
PS_DASHDOT=3
PS_DASHDOTDOT=4
PS_INSIDEFRAME=6
PS_GEOMETRIC=65536
PS_ENDCAP_FLAT=512
PS_ENDCAP_MASK=3840
PS_JOIN_BEVEL=4096
PS_JOIN_MITER=8192



(DrawCloseButton(HDC hdc
RECT rc
rc.left=0
rc.top=0
rc.right=30
rc.bottom=30
((br=CreateSolidBrush(RGB(0, 0, 0
FillRect hdc,rc,br
(SetBkColor hdc, RGB(0, 0, 0
(SetTextColor hdc,RGB(255, 255, 255
(TextOut hdc,10,8,"X",1

WM_NCHITTEST





Private Const HTBOTTOMRIGHT = 17

Dim rc1 As RECT
Dim rc2 As RECT

Select Case wMsg

Case WM_SIZE
GetClientRect hwnd, rc2
If PtInRect(rc2,rc1.Left,rc1.Top) Then
InvalidateRect hwnd, rc1,True
Else
PostMessage hwnd, WM_PAINT, 0, 0
End If

Case WM_PAINT

GetClientRect hwnd, rc1
(rc1.Left=rc1.Right-GetSystemMetrics(SM_CXSIZE
(rc1.Top=rc1.Bottom - GetSystemMetrics(SM_CYSIZE
DrawFrameControl FrmDC,rc1, DFC_SCROLL,DFCS_SCROLLSIZEGRIP

Case WM_NCHITTEST
GetWindowRect hwnd, rc2
(rc2.Left=rc2.Right -GetSystemMetrics(SM_CXSIZE
(rc2.Top=rc2.Bottom- GetSystemMetrics(SM_CYSIZE

If PtInRect rc2,WordLo(lParam),WordHi(lParam)) Then
WndProc = HTBOTTOMRIGHT
End If 


Private Function WordHi(LongIn As Long) As Integer
(CopyMem(WordHi, ByVal (VarPtr(LongIn) + 2), 2
End Function

Private Function WordLo(LongIn As Long) As Integer
(CopyMem(WordLo, ByVal VarPtr(LongIn), 2
End Function


DFC_CAPTION = 1
            DFC_MENU = 2
            DFC_SCROLL = 3
            DFC_BUTTON = 4
            DFCS_CAPTIONCLOSE =&H0
            DFCS_CAPTIONMIN =&H1
            DFCS_CAPTIONMAX = &H2
            DFCS_CAPTIONRESTORE =&H3
            DFCS_CAPTIONHELP =&H4
            DFCS_MENUARROW =&H0
            DFCS_MENUCHECK =&H1
            DFCS_MENUBULLET =&H2
            DFCS_SCROLLUP = &H0
            DFCS_SCROLLDOWN =&H1
            DFCS_SCROLLLEFT =&H2
            DFCS_SCROLLRIGHT =&H3
            DFCS_SCROLLCOMBOBOX =&H5
            DFCS_BUTTONCHECK =&H0
            DFCS_BUTTONRADIO =&H4
            DFCS_BUTTON3STATE =&H8
            DFCS_BUTTONPUSH =&H10
 DFCS_PUSHED =&H200
            DFCS_CHECKE =&H400


R=ClientRect

(rgn=CreateRoundRectRgn(R.Left, R.Top, R.Right
(R.Bottom, 20, 20,

InflateRect r, - 4, - 4

SetWindowRgn Handle,rgn,True Invalidate

Draw TitleBr



Private tCloseRect As RECT
Private tUpdatedCloseButtonRect As RECT
Private bCloseButtonPressed As Boolean
----------------------------------------------
 : WNDPROC

GetClientRect hwnd, tClientRect

Select Case Msg 
Case WM_NCLBUTTONDOWN
SetWindowPos hwnd,HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE + SWP_NOMOVE 

Case WM_ACTIVATE
If wParam = 0 Then 
SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE + SWP_NOMOVE SetWindowLong hwnd,
(GWL_STYLE, (GetWindowLong(hwnd, GWL_STYLE,
(And Not WS_SYSMENU
(Call DrawTitleBar(hwnd, lTitleBarColor
InvalidateRect hwnd, tClientRect, 0 

Case WM_EXITSIZEMOVE
(Call DrawTitleBar(hwnd, lTitleBarColor
InvalidateRect hwnd, tClientRect, 0

Case WM_NCPAINT 
If bDrawn = False Then bDrawn = True Call DrawTitleBar(hwnd, lTitleBarColor) Exit Function 

Case WM_SYSCOMMAND
GetHiLoword CLng(lParam), loword, hiword
tPt.x = loword
tPt.y = hiword
Dim lngPtr As LongPtr
(CopyMemory lngPtr,tPt, LenB(tPt
If PtInRect(tUpdatedCloseButtonRect, lngPtr) Then 
(Call DrawTitleBar(hwnd, lTitleBarColor, True
Do
DoEvents
Loop Until GetAsyncKeyState(vbKeyLButton) = 0 
GetCursorPos tPt
(CopyMemory lngPtr, tPt, LenB(tPt
If PtInRect(tUpdatedCloseButtonRect, lngPtr) Then 
If bCloseButtonPressed Then Sleep 200
Unload oForm 
End If 
End If 
If bCloseButtonPressed Then 
(Call DrawTitleBar(hwnd, lTitleBarColor
InvalidateRect hwnd, tClientRect, 0 
End If

Case WM_DESTROY
bCloseButtonPressed = False


: DrawTitleBar 

Dim tLb As LOGBRUSH
Dim tPs As PAINTSTRUCT

(Call BeginPaint(hwnd, tPs
(hdc=GetWindowDC(hwnd
tLb.lbColor=CaptionColor
(hBrush=CreateBrushIndirect(tLb
GetWindowRect hwnd, tFormRect


bCloseButtonPressed = PressedCloseButton
If Not PressedCloseButton Then
DrawFrameControl hdc,tCloseRect, DFC_CAPTION, DFCS_CAPTIONCLOSE
Else
DrawFrameControl hdc, tCloseRect, DFC_CAPTION, DFCS_CAPTIONCLOSE + DFCS_PUSHED
End If

SetBkMode hdc,1
SetTextColor hdc, lFontColor 
(Call CreateFont(hdc
TextOut hdc, 4, 4, sCaptionText, Len(sCaptionText
GetClientRect hwnd, tCloseRect
With tCloseRect
(Bottom = GetSystemMetrics(SM_CYCAPTION.
Left = .Right - 20.
Right = .Right +3.
Top = .Top + 4.
End With
With tCloseRect 
p1.x = .Left - 2: p1.y = .Top - 2 
p2.x = .Right: p2.y = .Bottom - GetSystemMetrics(SM_CYCAPTION) - 2 End With 
ClientToScreen hwnd, p1
ClientToScreen hwnd, p2
With tUpdatedCloseButtonRect 
.Left = p1.x: .Top = p1
(y - GetSystemMetrics(SM_CYCAPTION
Right = p2.x: .Bottom = p2.y.
End With 
ReleaseDC hwnd, hdc 
(Call EndPaint(hwnd, tPs

Private Sub GetHiLoword(lParam As Long, ByRef 
(loword As Long, ByRef hiword As Long
loword = lParam And &HFFFF& 
hiword = lParam \ &H10000 And &HFFFF&
End Sub

Draw NonClient Area



Type NCCALCSIZE_PARAMS
rgrc(3) As RECT 
lppos As WINDOWPOS
End Type 

Type WINDOWPOS
hwndInsertAfter As LongPtr
hwndAs LongPtr 
x As Long
y As Long
cx As Long
cy As Long 
uflags As Long
End Type

'uflags 
SWP_NOSIZE=&H1
SWP_NOMOVE=&H2
SWP_NOZORDER=&H4
SWP_NOREDRAW=&H8
SWP_SHOWWINDOW=&H40
SWP_HIDEWINDOW=&H80

case WM_NCCALCSIZE
Dim ncParams As NCCALCSIZE_PARAMS
 (LPNCCALCSIZE_PARAMS) lParam' 

ncParams.rgrc(0).top +=4
ncParams.rgrc(0).left +=4
ncParams.rgrc(0).bottom -=4
ncParams.rgrc(0).right -=4
return 0


Case WM_NCPAINT
Dim rc As RECT
GetWindowRect hWnd,rc
region=0
if (wParam=1) Then
region=CreateRectRgn(rect.left, rect.top, rect.right,,
(rect.bottom
else
(copy=CreateRectRgn(0, 0, 0, 0
if (CombineRgn(copy,wParam,0, RGN_COPY))  Then 
region=copy
else
(DeleteObject(copy
End if 
End if 

dc=GetDCEx(hWnd,region, DCX_WINDOW+DCX_CACHE+DCX_INTERSECTRGN+DCX_LOCKWINDOWUPDATE)

if  Not (dc  Or region) Then
DeleteObject region
End if 
((pen=CreatePen(PS_INSIDEFRAME, 4, RGB(255, 0, 0
(old=SelectObject(dc, pen
width=rect.right-rect.left
height=rect.bottom-rect.top
Rectangle dc, 0, 0, width,height 
SelectObject dc, old
ReleaseDC hWnd, dc
DeleteObject pen
return 0
End If

case WM_NCACTIVATE 
(RedrawWindow(hWnd,0,0,RDW_UPDATENOW
return 0





(rgn=CreateRectRgn(0,0,0,0
(int s=GetWindowRgn(Hwnd, rgn
if wparam=0 '
()topRgn=CreateRectRgn(0, 10,GetSize().GetWidth
(()GetSize().GetHeight
(newRgn=CreateRectRgn(0,0,0,0
(CombineRgn newRgn,rgn,topRgn,RGN_AND
(s = SetWindowRgn(GetHwnd(), newRgn, true

case WM_NCCALCSIZE
(if (wParam=TRUE
NCCALCSIZE_PARAMS *pncsp = reinterpret_cast<NCCALCSIZE_PARAMS*>(lParam);
pncsp.rgrc(0).left=pncsp.rgrc(0).left+5
pncsp.rgrc(0).top=pncsp.rgrc(0).top+5
pncsp.rgrc(0).right=pncsp.rgrc(0).right-5
pncsp.rgrc(0).bottom=pncsp.rgrc(0).bottom-5

(MSWDefWindowProc(message, wParam, lParam
r=WVR_REDRAW

 else
(MSWDefWindowProc(message, wParam, lParam
r = 0
End if 




WVR_ALIGNTOP=&H10
WVR_ALIGNLEFT=&H20
WVR_ALIGNBOTTOM=&H40
WVR_ALIGNRIGHT=&H80
WVR_HREDRAW=&H100
WVR_VREDRAW=&H200
WVR_REDRAW=&H300






you set the size of the non-client area by handling the WM_NCCALCSIZE message. But don't do this unless you plan to do all of the non-client drawing as well by handling WM_NCPAINT

case WM_NCCALCSIZE
lRet = 0
const int cxBorder = 2
const int cyBorder = 2 
(InflateRect((LPRECT)lParam,-cxBorder, -cyBorder
case WM_NCCALCSIZE
 '{ LPNCCALCSIZE_PARAMS pncc ='(LPNCCALCSIZE_PARAMS)lParam 
pncc.rgrc(0)is the new rectangle '
pncc.rgrc(1) is the old rectangle' 
pncc.rgrc(2) is the client rectangle' 
lRet=DefWindowProc(hwnd, 
(WM_NCCALCSIZE,wParam,lParam
pncc.rgrc(0).top +=ExtraCaptionHeight


WM_NCCALCSIZE=&H83



case WM_NCPAINT

HRGN)wParam)

hdic=GetDCEx(hwnd,(HRGN)wParam,DCX_WINDOW+DCX_CACHE+DCX_INTERSECTRGN)
GetWindowRect hwnd,rect
((b=CreateSolidBrush(RGB(180,180,180
SelectObject hdic,b
((pe=CreatePen(PS_SOLID, 1, RGB(90, 90, 90
SelectObject hdic,pe
-Rectangle hdic,0,0,(rect.right-rect.left),(rect.bottom
((rect.top
DeleteObject pe
DeleteObject b

ReleaseDC hwnd,hdic
RedrawWindow 
(hwnd,rect,(HRGN)wParam,RDW_UPDATENOW
return 0


RDW_ALLCHILDREN = 128
RDW_ERASE = 4
RDW_ERASENOW = 512
RDW_FRAME = 1024
RDW_INTERNALPAINT = 2
RDW_INVALIDATE =1
RDW_NOCHILDREN = 64
RDW_NOERASE = 32
RDW_NOFRAME = 2048
RDW_NOINTERNALPAINT = 16
RDW_UPDATENOW = 256
RDW_VALIDATE = 8

اطلاعات TitleBar و پیام Tool Tip Tracking


اعضاء این ساختار :  Member



wparam باید صفر باشد و lparam هم یک نشانگر به ساختار TITLEBARINFOEX ، قبل از ارسال از طریق پیام باید عضو cbSize آن تنظیم شود!


  



                                                                          Dim info As INFOTITLEEX 


(info.cbSize=Len(info

,SendMessage(hwnd, WM_GETTITLEBARINFOEX,0

(info



if (info.rgstate(5) & (STATE_SYSTEM_INVISIBLE  Or STATE_SYSTEM_OFFSCREEN Or 

((STATE_SYSTEM_UNAVAILABLE

return FALSE

ppt->x = info.rgrect(5).left + (info.rgrect(5).right - info.rgrect(5).left) / 2

 ppt->y= info.rgrect(5).top + (info.rgrect(5).bottom - info.rgrect(5).top) / 2


,,SendMessage(g_hwndTT, TTM_TRACKPOSITION, 0

(MAKELPARAM(pt.x, pt.y



TTM_TRACKPOSITION 'Sets the position of a tracking tooltip.

TTM_TRACKACTIVATE 'Activates or deactivates a 

.tracking tooltip

(wParam=True/False ,lparam :Pointer to a TOOLINFO structure that identifies the tool to which this message applies. The hwnd and uId members identify the tool, and the cbSize member specifies the size of the 

.structure. All other members are ignored


TTM_SETDELAYTIME=&H403
TTM_TRACKACTIVATE=&H411 TTM_TRACKPOSITION=&H412
TTM_SETTIPBKCOLOR=&H413
TTM_SETTIPTEXTCOLOR=&H414




Public Function LoWord(dwValue As Long) As Integer
CopyMemory LoWord, dwValue, 2
End Function

Public Function MAKELONG(wLow As Long, wHigh As

 Long) As Long

*MAKELONG = LoWord(wLow) Or (&H10000

((LoWord(wHigh

End Function

Public Function MAKELPARAM(wLow As Long, wHigh As Long) As Long 'Combines two integers into a long integer

(MAKELPARAM=MAKELONG(wLow, wHigh
End Function

رسم قاب کنترل - ایجاد سوراخ hole


BOOL DrawFrameControl( HDC , LPRECT , UINT , UINT );


:Arguman 3 


DFC_BUTTON    Standard button

DFC_CAPTION   Title bar
DFC_MENUMenu bar
DFC_POPUPMENUPopup menu item.
DFC_SCROLL


If Type Is Button ,  Draw Frame Control State As Follows


DFCS_BUTTON3STATE Three-state button
DFCS_BUTTONCHECK  Check box
DFCS_BUTTONPUSH    Push button
DFCS_BUTTONRADIO   Radio button


If uType is DFC_CAPTION, uState can be one of the 

.following values


DFCS_CAPTIONCLOSE             Close button
DFCS_CAPTIONHELP                 Help button
DFCS_CAPTIONMAX                  Maximizebutton
DFCS_CAPTIONMIN                    Minimizebutton
DFCS_CAPTIONRESTORE      Restore button

مه آلودگی یا تاری پشت پنجره

hRgnBlur

The region within the client area where the blur behind will be applied. A NULL value will apply the blur behind the entire client area







Gdi32




R=ClientRect
rgn=CreateRoundRectRgn(R.Left, R.Top, R.Right
(R.Bottom, 20, 20,
(SetWindowRgn(Handle, rgn, True
???InvalidateRect

----------#########------------------

Const DC_ACTIVE=1
Const DC_NOTACTIVE=2
Const DC_ICON=4
Const DC_TEXT=8
Const DFC_BUTTON=4
Const DFC_POPUPMENU=5
Const DFCS_BUTTON3STATE=16
Const DT_CENTER=1
Const DC_GRADIENT=32
Const SM_FULLSCREEN=65535

SetRect R,0,0, Me.Width,30
DrawCaption Me.Handle,GetWindowDC(Me.Handle),R,DC_ACTIVE Or DC_ICON Or DC_TEXT Or DC_GRADIENT)

SetRect R, 0, 29, Me.Width, 30
DrawEdge GetWindowDC(Me.Handle),R,EDGE_ETCHED,BF_RECT

SetRect R,0,0, Me.Width,30
DrawFocusRect GetWindowDC(Me.Handle),R

SetRect R,0,0,Me.Width,30
DrawFrameControl GetWindowDC(Me.Handle),R,DFC_BUTTON
(DFCS_BUTTON3STATE,

SetRect R,0,0,Me.Width,30
DrawText GetDC(Me.Handle),"Hello World !",Len("Hello World !"),R,DT_CENTER)


#######--------######--------------


hBitmap = LoadImage
GetObject hBitmap,Len(BitmapInf),BitmapInf
(hDC=GetDC(hDlg
(hMemDCSrc=CreateCompatibleDC(hDC 
(hMemDCDst=CreateCompatibleDC(hDC
(hNewBitmap=CreateCompatibleBitmap(hDC,BitmapInf.bmWidth,BitmapInf.bmHeight

(hBitmap=SelectObject(hMemDCSrc,hBitmap
hNewBitmap=SelectObject(hMemDCDst, hNewBitmap

("hTheme=OpenThemeData(hDlg,"Button
'draw the button background
rc.top = 0
rc.left = 0
rc.right=BitmapInf.bmWidth
rc.bottom=BitmapInf.bmHeight
DrawThemeBackground hTheme,hMemDCDst,BP_PUSHBUTTON,
?PBS_NORMAL,rc,NULL 
FillRect hMemDCDst,rc,CreateSolidBrush '
((RGB(255,255,255)
CloseThemeData hTheme
SetWindowTheme GetDlgItem(hDlg, rcCtrl,"",NULL 

 draw the bitmap ignoring background colour' 

TransparentBlt hMemDCDst,0,0,BitmapInf.bmWidth,BitmapInf.bmHeight,hMemDCSrc,0,0,BitmapInf.bmWidth,width
BitmapInf.bmHeight,
(GetSysColor(COLOR_3DFACE 

BitBlt hDC,0,0,BitmapInf.bmWidth,BitmapInf.bmHeight,hMemDCDst,0,0,SRCCOPY




SM_CYCAPTION=4
SM_CYMENUSIZE=55
The width of a button in a window caption or title bar ' 
.in'pixels
SM_CXSIZE=30
The height of a button in a window caption or title bar '
.in pixels
SM_CYSIZE=31
(GetSystemMetrics(nIndex

intptrWindowTheme=openThemeData(CloseWindowButton.Handle,"Window") drawThemeBackground(intptrWindowTheme,GetHdc,ThemeWindowParts.WP_CLOSEBUTTON,CloseButtonState,New RECT(New Rectangle(0, 0,CloseWindowButton.Width, CloseWindowButton.Height)),IntPtr.Zero

 : Close Button Style 
CBS_DISABLED, CBS_HOT, CBS_NORMAL
CBS_PUSHED,

enum {
  CBS_NORMAL = 1,
  CBS_HOT = 2,
  CBS_PUSHED = 3,
  CBS_DISABLED = 4
};

WP:Window Part 



using System; 
 
namespace Microsoft.Samples 
    public class Constants 
    { 
        public const int AUTOSUGGEST = 0x10000000,  
            AUTOSUGGEST_OFF = 0x20000000,  
            AUTOAPPEND = 0x40000000,  
            AUTOAPPEND_OFF = (unchecked((int)0x80000000)); 
 
        public const int ARW_BOTTOMLEFT = 0x0000, 
            ARW_BOTTOMRIGHT = 0x0001, 
            ARW_TOPLEFT = 0x0002, 
            ARW_LEFT = 0x0000, 
            ARW_TOPRIGHT = 0x0003, 
            ARW_RIGHT = 0x0000, 
            ARW_HIDE = 0x0008, 
            ARW_UP = 0x0004, 
            ARW_DOWN = 0x0004, 
            ACM_OPENA = (0x0400+100), 
            ACM_OPENW = (0x0400+103), 
            ADVF_NODATA = 1
            ADVF_ONLYONCE = 2
            ADVF_PRIMEFIRST = 4;            public const int BCM_GETIDEALSIZE = 0x1601,              BI_RGB = 0,              BS_PATTERN = 3,              BITSPIXEL = 12,              BDR_RAISEDOUTER = 0x0001,              BDR_SUNKENOUTER = 0x0002,              BDR_RAISEDINNER = 0x0004,              BDR_SUNKENINNER = 0x0008,              BDR_RAISED = 0x0005,              BDR_SUNKEN = 0x000a,              BF_LEFT = 0x0001,              BF_TOP = 0x0002,              BF_RIGHT = 0x0004,              BF_BOTTOM = 0x0008,              BF_ADJUST = 0x2000,              BF_FLAT = 0x4000,              BF_MIDDLE = 0x0800,              BFFM_INITIALIZED = 1,              BFFM_SELCHANGED = 2,              BFFM_SETSELECTION = 0x400+103,              BFFM_ENABLEOK = 0x400+101,              BS_PUSHBUTTON = 0x00000000,              BS_DEFPUSHBUTTON = 0x00000001,              BS_MULTILINE = 0x00002000,              BS_PUSHLIKE = 0x00001000,              BS_OWNERDRAW = 0x0000000B,              BS_RADIOBUTTON = 0x00000004,              BS_3STATE = 0x00000005,              BS_GROUPBOX = 0x00000007,              BS_LEFT = 0x00000100,              BS_RIGHT = 0x00000200,              BS_CENTER = 0x00000300,              BS_TOP = 0x00000400,              BS_BOTTOM = 0x00000800,              BS_VCENTER = 0x00000C00,              BS_RIGHTBUTTON = 0x00000020,              BN_CLICKED = 0,              BM_SETCHECK = 0x00F1,              BM_SETSTATE = 0x00F3,              BM_CLICK    = 0x00F5;            public const int CDERR_DIALOGFAILURE = 0xFFFF,              CDERR_STRUCTSIZE = 0x0001,              CDERR_INITIALIZATION = 0x0002,              CDERR_NOTEMPLATE = 0x0003,              CDERR_NOHINSTANCE = 0x0004,              CDERR_LOADSTRFAILURE = 0x0005,              CDERR_FINDRESFAILURE = 0x0006,              CDERR_LOADRESFAILURE = 0x0007,              CDERR_LOCKRESFAILURE = 0x0008,              CDERR_MEMALLOCFAILURE = 0x0009,              CDERR_MEMLOCKFAILURE = 0x000A,              CDERR_NOHOOK = 0x000B,              CDERR_REGISTERMSGFAIL = 0x000C,              CFERR_NOFONTS = 0x2001,              CFERR_MAXLESSTHANMIN = 0x2002,              CC_RGBINIT = 0x00000001,              CC_FULLOPEN = 0x00000002,              CC_PREVENTFULLOPEN = 0x00000004,              CC_SHOWHELP = 0x00000008,              CC_ENABLEHOOK = 0x00000010,              CC_SOLIDCOLOR = 0x00000080,              CC_ANYCOLOR = 0x00000100,              CF_SCREENFONTS = 0x00000001,              CF_SHOWHELP = 0x00000004,              CF_ENABLEHOOK = 0x00000008,              CF_INITTOLOGFONTSTRUCT = 0x00000040,              CF_EFFECTS = 0x00000100,              CF_APPLY = 0x00000200,              CF_SCRIPTSONLY = 0x00000400,              CF_NOVECTORFONTS = 0x00000800,              CF_NOSIMULATIONS = 0x00001000,              CF_LIMITSIZE = 0x00002000,              CF_FIXEDPITCHONLY = 0x00004000,              CF_FORCEFONTEXIST = 0x00010000,              CF_TTONLY = 0x00040000,              CF_SELECTSCRIPT = 0x00400000,              CF_NOVERTFONTS = 0x01000000,              CP_WINANSI = 1004;                    public const int cmb4 = 0x0473,              CS_DBLCLKS = 0x0008,              CS_DROPSHADOW = 0x00020000,              CF_TEXT = 1,              CF_BITMAP = 2,              CF_METAFILEPICT = 3,              CF_SYLK = 4,              CF_DIF = 5,              CF_TIFF = 6,              CF_OEMTEXT = 7,              CF_DIB = 8,              CF_PALETTE = 9,              CF_PENDATA = 10,              CF_RIFF = 11,              CF_WAVE = 12,              CF_UNICODETEXT = 13,              CF_ENHMETAFILE = 14,              CF_HDROP = 15,              CF_LOCALE = 16,              CLSCTX_INPROC_SERVER    = 0x1,              CLSCTX_LOCAL_SERVER     = 0x4,              CW_USEDEFAULT = (unchecked((int)0x80000000)),              CWP_SKIPINVISIBLE = 0x0001,              COLOR_WINDOW = 5,              CB_ERR = (-1),              CBN_SELCHANGE = 1,              CBN_DBLCLK = 2,              CBN_EDITCHANGE = 5,              CBN_EDITUPDATE = 6,              CBN_DROPDOWN = 7,              CBN_CLOSEUP  = 8,              CBN_SELENDOK = 9,              CBS_SIMPLE = 0x0001,              CBS_DROPDOWN = 0x0002,              CBS_DROPDOWNLIST = 0x0003,              CBS_OWNERDRAWFIXED = 0x0010,              CBS_OWNERDRAWVARIABLE = 0x0020,              CBS_AUTOHSCROLL = 0x0040,              CBS_HASSTRINGS = 0x0200,              CBS_NOINTEGRALHEIGHT = 0x0400,              CB_GETEDITSEL = 0x0140,              CB_LIMITTEXT = 0x0141,              CB_SETEDITSEL = 0x0142,              CB_ADDSTRING = 0x0143,              CB_DELETESTRING = 0x0144,              CB_GETCURSEL = 0x0147,              CB_INSERTSTRING = 0x014A,              CB_RESETCONTENT = 0x014B,              CB_FINDSTRING = 0x014C,              CB_SETCURSEL = 0x014E,              CB_SHOWDROPDOWN = 0x014F,              CB_GETITEMDATA = 0x0150,              CB_SETITEMHEIGHT = 0x0153,              CB_GETITEMHEIGHT = 0x0154,              CB_GETDROPPEDSTATE = 0x0157,              CB_FINDSTRINGEXACT = 0x0158,              CB_SETDROPPEDWIDTH = 0x0160,              CDRF_DODEFAULT = 0x00000000,              CDRF_NEWFONT = 0x00000002,              CDRF_SKIPDEFAULT = 0x00000004,              CDRF_NOTIFYPOSTPAINT = 0x00000010,              CDRF_NOTIFYITEMDRAW = 0x00000020,              CDRF_NOTIFYSUBITEMDRAW = CDRF_NOTIFYITEMDRAW,              CDDS_PREPAINT = 0x00000001,              CDDS_POSTPAINT = 0x00000002,              CDDS_ITEM = 0x00010000,              CDDS_SUBITEM = 0x00020000,              CDDS_ITEMPREPAINT = (0x00010000|0x00000001),              CDDS_ITEMPOSTPAINT = (0x00010000|0x00000002),              CDIS_SELECTED = 0x0001,              CDIS_GRAYED = 0x0002,              CDIS_DISABLED = 0x0004,              CDIS_CHECKED = 0x0008,              CDIS_FOCUS = 0x0010,              CDIS_DEFAULT = 0x0020,              CDIS_HOT = 0x0040,              CDIS_MARKED = 0x0080,              CDIS_INDETERMINATE = 0x0100,              CDIS_SHOWKEYBOARDCUES = 0x0200,              CLR_NONE = unchecked((int)0xFFFFFFFF),              CLR_DEFAULT = unchecked((int)0xFF000000),              CCS_NORESIZE = 0x00000004,              CCS_NOPARENTALIGN = 0x00000008,              CCS_NODIVIDER = 0x00000040,              CBEM_INSERTITEMA = (0x0400+1),              CBEM_GETITEMA = (0x0400+4),              CBEM_SETITEMA = (0x0400+5),              CBEM_INSERTITEMW = (0x0400+11),              CBEM_SETITEMW = (0x0400+12),              CBEM_GETITEMW = (0x0400+13),              CBEN_ENDEDITA = ((0-800)-5),              CBEN_ENDEDITW = ((0-800)-6),              CONNECT_E_NOCONNECTION = unchecked((int)0x80040200),              CONNECT_E_CANNOTCONNECT = unchecked((int)0x80040202),              CTRLINFO_EATS_RETURN    = 1,              CTRLINFO_EATS_ESCAPE    = 2,              CSIDL_DESKTOP                    = 0x0000,        // <desktop>              CSIDL_INTERNET                   = 0x0001,        // Internet Explorer (icon on desktop)              CSIDL_PROGRAMS                   = 0x0002,        // Start Menu\Programs              CSIDL_PERSONAL                   = 0x0005,        // My Documents              CSIDL_FAVORITES                  = 0x0006,        // <user name>\Favorites              CSIDL_STARTUP                    = 0x0007,        // Start Menu\Programs\Startup              CSIDL_RECENT                     = 0x0008,        // <user name>\Recent              CSIDL_SENDTO                     = 0x0009,        // <user name>\SendTo              CSIDL_STARTMENU                  = 0x000b,        // <user name>\Start Menu              CSIDL_DESKTOPDIRECTORY           = 0x0010,        // <user name>\Desktop              CSIDL_TEMPLATES                  = 0x0015,              CSIDL_APPDATA                    = 0x001a,        // <user name>\Application Data              CSIDL_LOCAL_APPDATA              = 0x001c,        // <user name>\Local Settings\Applicaiton Data (non roaming)              CSIDL_INTERNET_CACHE             = 0x0020,              CSIDL_COOKIES                    = 0x0021,              CSIDL_HISTORY                    = 0x0022,              CSIDL_COMMON_APPDATA             = 0x0023,        // All Users\Application Data              CSIDL_SYSTEM                     = 0x0025,        // GetSystemDirectory()              CSIDL_PROGRAM_FILES              = 0x0026,        // C:\Program Files              CSIDL_PROGRAM_FILES_COMMON       = 0x002b;        // C:\Program Files\Common            public const int DUPLICATE = 0x06,              DISPID_UNKNOWN = (-1),              DISPID_PROPERTYPUT = (-3),              DISPATCH_METHOD = 0x1,              DISPATCH_PROPERTYGET = 0x2,              DISPATCH_PROPERTYPUT = 0x4,              DV_E_DVASPECT = unchecked((int)0x8004006B),              DISP_E_MEMBERNOTFOUND = unchecked((int)0x80020003),              DISP_E_PARAMNOTFOUND = unchecked((int)0x80020004),              DISP_E_EXCEPTION = unchecked((int)0x80020009),              DEFAULT_GUI_FONT = 17,              DIB_RGB_COLORS = 0,              DRAGDROP_E_NOTREGISTERED = unchecked((int)0x80040100),              DRAGDROP_E_ALREADYREGISTERED = unchecked((int)0x80040101),              DUPLICATE_SAME_ACCESS = 0x00000002,              DFC_CAPTION = 1,              DFC_MENU = 2,              DFC_SCROLL = 3,              DFC_BUTTON = 4,              DFCS_CAPTIONCLOSE = 0x0000,              DFCS_CAPTIONMIN = 0x0001,              DFCS_CAPTIONMAX = 0x0002,              DFCS_CAPTIONRESTORE = 0x0003,              DFCS_CAPTIONHELP = 0x0004,              DFCS_MENUARROW = 0x0000,              DFCS_MENUCHECK = 0x0001,              DFCS_MENUBULLET = 0x0002,              DFCS_SCROLLUP = 0x0000,              DFCS_SCROLLDOWN = 0x0001,              DFCS_SCROLLLEFT = 0x0002,              DFCS_SCROLLRIGHT = 0x0003,              DFCS_SCROLLCOMBOBOX = 0x0005,              DFCS_BUTTONCHECK = 0x0000,              DFCS_BUTTONRADIO = 0x0004,              DFCS_BUTTON3STATE = 0x0008,              DFCS_BUTTONPUSH = 0x0010,              DFCS_INACTIVE = 0x0100,              DFCS_PUSHED = 0x0200,              DFCS_CHECKED = 0x0400,              DFCS_FLAT = 0x4000,              DT_LEFT = 0x00000000,              DT_RIGHT = 0x00000002,              DT_VCENTER = 0x00000004,              DT_SINGLELINE = 0x00000020,              DT_NOCLIP = 0x00000100,              DT_CALCRECT = 0x00000400,              DT_NOPREFIX = 0x00000800,              DT_EDITCONTROL = 0x00002000,              DT_EXPANDTABS  = 0x00000040,              DT_END_ELLIPSIS = 0x00008000,              DT_RTLREADING = 0x00020000,              DT_WORDBREAK = 0x00000010,              DCX_WINDOW = 0x00000001,              DCX_CACHE = 0x00000002,              DCX_LOCKWINDOWUPDATE = 0x00000400,              DI_NORMAL = 0x0003,              DLGC_WANTARROWS = 0x0001, 

Form Closing Timer ( تایمر بسته شدن فرم )




Timeinterval را در رویداد Open فرم می توانید روی 1000 میلی تنظیم کنید .

Overflow در VBE


راه حل برطرف شدن استفاده از تابع CLNG است .







Side Bar ( سابفرم بازشو بصورت عرضی !!!... منبع جستجو در وب سایت خارجی سال 2004 animated popup )



TOGGLE BUTTON :  TRUE/FALSE


X تعداد تکرار است که حتما باید باشد فرضا  عرض سابفرم 2.4583 اینچ باشد که در ویوی فرم  اگر پراپرتی عرض سابفرم را بگیریم میشود 3540 به  واحد twips ( یعنی عدد پراپرتی عرض در  حالت دیزاین سابفرم که به اینچ داده را در 1440 ضرب کردیم  ،  گردش کنیم یا عدد صحیح آنرا در نظر بگیریم میشود 3540 به واحد twips ) حال باید بگوئیم چند واحد چند واحد به عرض سابفرم اضافه شود یا کسر شود ( تا زمانیکه کامل به عرض خود برسد یا صفر شود ) فرضا میخواهید زمانیکه که Toggle فشرده میشود 295 واحد ( twips ) به عرض قبلی اضافه شود و همینطور ادامه پیدا کند 295 واحد 295 واحد تا بعرض 3540 برسد لازمست که لوپی ایجاد شود و بگوئیم این لوپ چند بار انجام شود عدد 3540 تقسیم بر 295 میشود عدد 12 پس لوپ ما باید 12 بار تکرار شود از این رو در زیر متغیر X تعریف شده شما میتوانید نام متغیر را تغییر دهید. Timer اینجا نقشش مکث یا Pause است وگرنه در حالت لوپ X شما تغییرات را سریع می بینید و به یکباره ، ولی زمان استفاده از Timer با توجه به مکث در هر پارت شما تغییرات اضافه شدن عرض تا کامل شدن یا کسر شدن از عرض تا زمان به صفر رسیدن را با چشمان تیزبین خود خواهید دید مثل عکس پایین تر از عکس بیان خارجی عملکرد.


در رویداد کلیک Toggleباتن طبق تصویر  زیرین توسط دوستان خارجی چرا از پراپرتی Left سابفرم استفاده شده؟ چون  عرض گرفتن سابفرم به سمت راست آن است نه چپ یعنی زمانیکه شما به سابفرم عرض میدهید Left آن تغییر نمیکند از این رو زمانیکه شما میخواهید به عرضی که صفر است عدد بدهید باید بگوئید پراپرتی Left هم تغییر کند ... فرضا عرض سابفرم را صفر کرده اید و به  منتهی علیه سمت راست فرم اصلی برده اید اگر Left را منفی نکنید ( واحد به واحد )  چنانچه امتحان بنمائید به سمت راست عرض می گیرد در صورتیکه شما میخواهید سابفرم به سمت چپ بازشود لذا در حالیکه سابفرم طبق لوپ X عرض می گیرد آنهم واحد به واحد باید کاری کنید که Left آن هم به سمپ چپ فرم اصلی متمایل شود .... یعنی اگر Toggle فشرده شد مثبت 295 واحد به عرض سابفرم اضافه شود و از آنطرف منفی 295 واحد از عدد پراپرتی Left آن کسر گردد تا به سمت چپ کشیده شود و اگر Toggle به حالت اول برگردد عرض آن منفی 295 واحد شود و در اینجا به عدد پراپرتی Left آن مثبت 295 واحد اضافه شود.


حال که به نحوه ی عملکرد آن دست یافتید می توانید سابفرم بازشو ( با همراهی تابع Timer )  را برای خود یا دوستانتان تهیه کرده و یک مهارت به مهارت های دیگرتان اضافه کنید. کار سختی نبود یکم فکر کردن لازمه البته تسلط به عملکرد پراپرتیها در رسیدن به هدف Major Priority است. گذاشتن توضیحات کامل و تصاویر و منابع کار درستی نیست چون اینها کاری تجاری هستند و افراد می توانند از طریق همین دانسته ها کسب درآمد کنند ولی چون منابع خارجی هستند و از خودمان نیست  و آنها هم به اشتراک گذاشته اند لذا از نظر شرعی کاملا حلال است.



(Sub timeout(duration_ms As Double
Start_Time = Timer
Do
DoEvents
Loop Until (Timer - Start_Time) >= duration_ms
End Sub


()Private Sub Toggle4_Click




 Inside OnLoad Event Set The Width Of Subform to Zero  And the Left  Property Of Subform To the Left  
.Property Of Toggle Button Plus Its Width 

If Use ToggleButton would be better otherwise in case of using Command Button You Shall Declare A Variable As Boolean So That Manage Whether Button  
 Pressed

 You Can Use MouseDown  Event Of the MainForm to return back the subform if the toggle button was true, if  you did it you must define a boolean variable and set to true also in Toggle Click Event Write if the specified variable was true then toggle set to False And the end of the  code set it ( Variable ) to false


WH_CBT ( قلاب یا گرفتن پنجره : برای ارسال پیام ازطریق پنجره به زیر پنجره ها Child Window:کنترل پیام های پنجره Window Message)


Tested SuccesFully..... 64 BIT


HOOK/SUBCLASS THE WINDOW







CustomMeSsageBox


(Public Const GWL_WNDPROC = (-4

Public Const HCBT_CREATEWND = 3

Public Const HCBT_DESTROYWND = 4

Public Const HCBT_ACTIVATE = 5


Public Const WM_INITDIALOG = &H110

Public Const WM_COMMAND = &H111

Public Const WM_SYSCOMMAND = &H112






case WM_PAINT
(hdc=BeginPaint(hWnd,ps
((whitebrush=CreateSolidBrush(RGB(0, 0, 0
' Erases the background 
SendMessage(hWnd,WM_ERASEBKGND,
(GetDC(hWnd),0,
(GetClientRect(hWnd,rc
(FillRect(GetDC(hWnd),rc,whitebrush
Can Use DrawEdge' 
 Draw the icon in the client area' 
DrawIcon hdc, 10,20,ByVal  hIcon1' 
(EndPaint(hWnd,ps



You need to handle WM_CTLCOLORDLG. You should return a brush handle. For example, to make the background white:

case WM_CTLCOLORDLG:
    return (INT_PTR)GetStockObject(WHITE_BRUSH);






' Not Tested In VBA Just Following
Code Copied Here

HDC hdcMem

LPDRAWITEMSTRUCT lpdis

Select Case message

case WM_INITDIALOG

'hbm1 and hbm2 are defined globally.

hbm1 = LoadBitmap((HANDLE) hinst, "OwnBit1")

hbm2 = LoadBitmap((HANDLE) hinst, "OwnBit2")

return TRUE

case WM_DRAWITEM

lpdis=(LPDRAWITEMSTRUCT) lParam

hdcMem = CreateCompatibleDC(lpdis.hDC)

if (lpdis->itemState & ODS_SELECTED)

'if selected

SelectObject(hdcMem,hbm2)

else

SelectObject(hdcMem,hbm1)

'Destination

StretchBlt lpdis.hDC,lpdis.rcItem.left,lpdis.rcItem.top,lpdis.rcItem.right-lpdis.rcItem.left,lpdis.rcItem.bottom-lpdis.rcItem.top,hdcMem,0,0,32,32,SRCCOPY

DeleteDC hdcMem

return TRUE

End If

case WM_COMMAND

if (wParam= IDOK Or wParam=IDCANCEL) Then

EndDialog hDlg, TRUE

return TRUE

End If

if (HIWORD(wParam)=BN_CLICKED) Then

Select Case  (LOWORD(wParam))

  case IDB_OWNERDRAW

End Select

End If

case WM_DESTROY

DeleteObject hbm1

DeleteObject hbm2

End Select

return FALSE
' Not Tested
case WM_CREATE
hdc = GetDC(hwnd)
'xPixel = GetDeviceCaps(hdc, ASPECTX) 'yPixel = GetDeviceCaps(hdc, ASPECTY) ReleaseDC hwnd, hdc
SetTimer hwnd,ID_TIMER,50,NULL return 0

case WM_SIZE

xCenter=(cxClient=LOWORD(lParam))/2 yCenter=(cyClient=HIWORD(lParam))/2

cxRadius=cyRadius=min(cxClient, cyClient)/16
cxMove=max(1, cxRadius/2)
cyMove = max(1, cyRadius / 2)

cxTotal=2 * (cxRadius + cxMove)
cyTotal=2 * (cyRadius + cyMove)



case WM_TIMER
hdc = GetDC(hwnd)
hdcMem = CreateCompatibleDC(hdc); SelectObject hdcMem, hBitmap)
BitBlt hdc,xCenter-cxTotal/2, yCenter -cyTotal/2,cxTotal,cyTotal,hdcMem,0,0, SRCCOPY)
ReleaseDC hwnd, hdc
DeleteDC hdcMem




Timers and Animation animation



BackGround Color question-146319

Button Color





(Like dis.CtlId=IDOK (1

case WM_DRAWITEM



(Dim dis As DRAWITEMSTRUCT (lParam
Dim rc As RECT 

get the size of the button'
GetClientRect dis.hwndItem,rc

' set text background to match button’s background'
(SetBkColor dis.hDC,RGB(255,0,0
(SetTextColor dis.hDC,RGB(255,255,255
DrawText 
(dis.hDC,"BTN",Len("BTN")-1,rc,DT_CENTER+DT_VCENTER+DT_SINGLELINE
BTNProc=TRUE



case WM_CTLCOLORBTN

Dim rc As RECT
Dim brush As Long
(background_color = RGB(255,0,0
hdc=wParam
button_handle=lParam
(GetClientRect button_handle,rc
SetBkColor hdc,background_color
(SetTextColor hdc,RGB(255,255,255
(DrawText(hdc,"BTN",Len("BTN")-1,rc,DT_CENTER+DT_VCENTER+DT_SINGLELINE
(brush = CreateSolidBrush(background_color
BTNProc=brush


Static / Edit Window


case WM_CTLCOLORSTATIC
hdcStatic=wParam
(SetTextColor hdcStatic,RGB(0,0,255
(SetBkColor hdcStatic,RGB(250,250,0
(return=CreateSolidBrush(RGB(250,250,0

case WM_CTLCOLOREDIT
hdcStatic=wParam
(SetTextColor hdcStatic,RGB(0,0,255
(SetBkColor hdcStatic,RGB(0,230,0
((return=CreateSolidBrush(RGB(0,230,0





CColorButton:DrawFilledRect(CDC *DC, CRect R, 
(COLORREF color
 
( B=CreateSolidBrush(color
 FillRect Dc,R, B
 

 

 
 CColorButton:DrawLine(CDC *DC, CRect EndPoints,
(COLORREF color,
 
 
( newPen=CreatePen(PS_SOLID, 1, color
( oldPen=SelectObject(DC,newPen
( MoveTo DC,EndPoints.left,EndPoints.top
(LineTo DC,EndPoints.right,EndPoints.bottom
SelectObject DC,oldPen
Pen.DeleteObject newPen



(CRect:ControlRect (ButtonRect<<<<<---
CColorButton:DrawButtonText(CDC *DC, CRect R
(const char *Buf, COLORREF TextColor,
 
(prevColor=SetTextColor(DC,TextColor
SetBkMode DC,TRANSPARENT
DrawText DC,Buf,len(Buf),R,DT_CENTER+DT_VCENTER+DT_SINGLELINE
SetTextColor DC,prevColor



سفارشی سازی MessageBox



Customizing MessageBox



(INT CBTMessageBox(hwnd,lpText, lpCaption,uType
hhk=SetWindowsHookEx(WH_CBT, Addressof CBTProc, 0, GetCurrentThreadId
CBTMessageBox=MessageBox(hwnd, lpText, lpCaption, uType)


(CBTProc(nCode,wParam,lParam
 
"hChildWnd; // msgbox is "child
 window handle is wParam '
if nCode=HCBT_ACTIVATE
 set window handles '
hChildWnd=wParam
 to get the text of the Yes button' 
(if (GetDlgItem(hChildWnd,IDYES)=0)
(CBTProc=SetDlgItemText(hChildWnd,IDYES,s
End if

(if (GetDlgItem(hChildWnd,IDOK)=0)
(CBTProc=SetDlgItemText(hChildWnd,IDOK,s
End if 
 exit CBT hook '
(UnhookWindowsHookEx(hhk
 otherwise, continue with any possible chained hooks '
else
(CallNextHookEx(hhk, nCode, wParam, lParam
CBTProc=0
End If 

: Source 

 : utype 






Dim DM As DRAWITEMSTRUCT
(CopyMemory DM,lparam,Len(DM

Window Message'
Public Const WM_DRAWITEM= &H2B
Owner draw control types'
Const ODT_MENU = 1
Const ODT_LISTBOX = 2
Const ODT_COMBOBOX = 3
Const ODT_BUTTON = 4

' Owner draw actions'
Const ODA_DRAWENTIRE = &H1
Const ODA_SELECT = &H2
Const ODA_FOCUS = &H4

' Owner draw state'
Const ODS_SELECTED = &H1
Const ODS_GRAYED = &H2
Const ODS_DISABLED = &H4
Const ODS_CHECKED = &H8
Const ODS_FOCUS = &H10
 MEASUREITEMSTRUCT for ownerdraw'
Type MEASUREITEMSTRUCT
        CtlType As Long
        CtlID As Long
        itemID As Long
        itemWidth As Long
        itemHeight As Long
        itemData As LongPtr
End Type

 DRAWITEMSTRUCT for ownerdraw'
Type DRAWITEMSTRUCT
        CtlType As Long
        CtlID As Long
        itemID As Long
        itemAction As Long
        itemState As Long
        hwndItem As LongPtr
        hdc As LongPtr
        rcItem As RECT
        itemData As LongPtr
End Type

System Classes


DrawCaption  hwnd,hdc,rc,uflag
http:// uflag : DC_ACTIVE DC_ICON DC_TEXT

Public Const DC_ACTIVE = &H1
Public Const DC_NOTACTIVE = &H2
Public Const DC_ICON = &H4
Public Const DC_TEXT = &H8


 


Public Function HookProc(ByVal nCode As Long,ByVal wParam As LongPtr,ByVal lParam As LongPtr) As Longptr

if nCode>=0 Then
Dim tCWP As CWPSTRUCT
(CopyMemory tCWP,ByVal lParam,Len(tCWP
if tCWP.message=WM_CREATE Then
If tCWP.hwnd==#32770 Then
lprewnd=SetWindowLongPtrA(tCWP.hwnd,GWL_CALL
(WNDPROC,AddressOf SubDlgBox
End If
End if
Else
CallWndProc= CallNextHookEx(0,nCode,wParam,ByVal
(lParam
End If
End Function



Public Function CallWndProc(ByVal hwnd As LongPtr,Msg As Long,Byval wParam As Longptr,ByVal lParam As LongPtr) As Longptr

Select Case Msg
Case WM_DESTROY
SetWindowLongPtrA hwnd,GWL_CALLWNDPROC,lprewnd
End Select CallWndProc=CallWindowProcA(lprewnd,hwnd,,Msg,w
(Param,lParam
End Function


' Button SubClassed procedure

FUNCTION ButtonProc(BYVAL hWnd AS LONG, BYVAL wMsg AS LONG,BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG
SELECT CASE wMsg
CASE %WM_LBUTTONDBLCLK
forward this for rapid button '
clicking... '
Call SendMessage(hWnd,%WM_LBUTTONDOWN,wParam
(lParam,
ButtonProc=0 : EXIT FUNCTION
CASE %WM_ERASEBKGND
ButtonProc=1: EXIT FUNCTION
END SELECT
ButtonProc=CallWindowProc(glpButtonProc
(hWnd, wMsg, wParam, lParam,
END FUNCTION












Public Function SubMsgBox(ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long

Select Case Msg
     Case WM_DESTROY
     Remove the MsgBox Subclassing'
Call SetWindowLong(hwnd,GWL_WNDPROC
(lPrevWnd,
End Select
SubMsgBox = CallWindowProc(lPrevWnd,hwnd,Msg
(wParam, ByVal lParam,
End Function



Private Function HookWindow(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Dim tCWP As CWPSTRUCT  CopyMemory tCWP
(ByVal lParam, Len(tCWP,
If tCWP.message=WM_CREATE Then
If sClass="#32770" Then
Subclass the Messagebox as it's created'
lPrevWnd=SetWindowLong(tCWP.hwnd
(GWL_WNDPROC,AddressOf SubMsgBox,
End If
End If
HookWindow=CallNextHookEx(lHook, nCode
(wParam, ByVal lParam,
End Function


Public Function MsgBoxEx(ByVal Prompt As String, Optional ByVal Buttons As Long = vbOKOnly, Optional ByVal Title As String) As Long
Dim lReturn As Long
lHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookWindow, App.hInstance
(App.ThreadID,
(lReturn=MsgBox(Prompt, Buttons, Title
(Call UnhookWindowsHookEx(lHook
MsgBoxEx = lReturn
End Function