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

drawcaption

win32/gdi/painting-and-drawing-functions

Addingplusimageplusinplusapluswin32plusdialog

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

drawitemstruct

(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

drawfocusrect

fillrect

drawedge

drawiconex

roundrect

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

createpen

---

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

---

win32/gdi/using-rectangles

سنگ آهن

سفارشی سازی 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 

MessageBox-with-Custom-Button-Captions

 : 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

Window Class Attributes

سفارشی سازی رنگ عنوان و باتن ها

Re: Customizing the titlebar color and buttons

MENUITEMINFOA DrawIcon