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

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

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

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

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

رسم ۳ باتن در 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






نظرات 0 + ارسال نظر
برای نمایش آواتار خود در این وبلاگ در سایت Gravatar.com ثبت نام کنید. (راهنما)
ایمیل شما بعد از ثبت نمایش داده نخواهد شد