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

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

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

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

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

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

پیام 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'