کلینیک فوق تخصصی اکسس ( کاربرد vba در اکسس )
به اشتراک گذاری اطلاعات کسب شده در اکسس از سایت آفیس و سایت های تخصصی خارجی
کلینیک فوق تخصصی اکسس ( کاربرد vba در اکسس )
به اشتراک گذاری اطلاعات کسب شده در اکسس از سایت آفیس و سایت های تخصصی خارجیدرباره من
This topic is a little part of programming in access , We have reached to this goal just with efforts and more exercises also studying the Microsoft Office Documents and their various forums
ادامه...
بازیابی یا گرفتن متن داخل کنترل Edit در جعبه InputBox ( کلاس 32770# )
لطفا در صورتِ "استفاده" حتما در نظر سنجی شرکت و فاتحه ای برای پدر مرحومم قرائت بفرمائید.
فروش مطالب ارزنده زیر به غیر ممنوع و اشکال شرعی دارد ( پیوند دادن منعی ندارد ) لطفا رعایت نمائید !!!
مطالب زیر صرفا به اشتراک گذاشتنِ تجربیات ، و در سایت های خارجی نیز کم و بیش بدان اشاره شده است.(گردآوری از سایت های خارجی جهت مطالعه عموم )
Case WM_NCLBUTTONDBLCLK '&HA3 Client درمنظقه بیرون
SetWindowTextA hWnd, "Dbl Clicked"
WM_NCRBUTTONDOWN 'constant : &HA4 Client درمنطقه بیرون
Using SetWindowTextA
EXIT FUNCTION
تبدیل متن فارسی به کدهای یونیکد برای استفاده ، در پیوندها با عنوان "کاراکتر فارسی" قرار داده شده که می توانید از آن بهره ببرید.البته کد Space را نمی دهد و کد آن 0020 است.
تنظیم و بازیابی تکست درتکست باکس ادیت کنترل :
با تابع SetWindowText می توان متنی به کنترل ویرایش ارسال کرد
یک برنامه می تواند متن کنترل ویرایش را با استفاده از توابع SetWindowText یا SetDlgItemText و یا با ارسال پیام WM_SETTEXT ، تنظیم نماید. طبق این گفته با SetWindowText می توان متن به کنترل ویرایش ارسال نمود.
SetWindowTextA wparam(hwnd),"Hi Mr/Mrs"
An application installs the hook procedure by specifying the WH_CBT hook type and a pointer to the hook procedure in a call to the SetWindowsHookEx function.
برای بازیابی تمام متن داخل کنترل ویرایش اول از تابع GetWindowTextLength یا پیام WM_GETTEXTLENGTH برای تعیین اندازه بافر مورد نیاز برای نگهداری تکست استفاده بنمائید.بعد با استفاده از تابع GetWindowText یا GetDlgItemText یا پیام WM_GETTEXT برای گرفتن یا بازیابی متن اقدام نمائید.
EM_GETTEXT :
Rich Edit: If the text to be copied exceeds 64K, use either the EM_STREAMOUT or EM_GETSELTEXT message
تغییر فونت مورد استفاده در کنترل ویرایش ( Edit ) :
یک برنامه توانایی تغییر فونت را با استفاده از ارسال پیام WM_SETFONT دارد.اکثر برنامه ها این کار را در زمان فرآیند پیام WM_INITDIALOG انجام می دهند.تغییر فونت اندازه کنترل ویراش را عوض نمی کند ؛
محدودیت کاربر در ورود متن :
بعنوان مثالی از کاربرد EM_SETLIMITTEX (Edit Message) و ( EN_MACTEXT ( Edit Notification ، فرض کنید برنامه بایستی کاربر را به ورود بیشتر از 4 کاراکتر در کنترل ویرایش محدود کند . برنامه از EM_SETLIMITTEXT برای مشخص نمودن محدودیت 4 کاراکتر استفاده می نماید.اگر کاربر سعی به وارد کردن پنجمین کاراکتر نماید دستگاه کد اعلان EM_MAXTEXT را به برنامه ارسال می نماید.
پیمایش متن در کنترل ویرایش :
ایجاد Style مورد نظر یعنی WS_VSCROLL با حذف کنترل ویرایش با استفاده از DestroyWindow و جایگزینی آن با ایجاد این کنترل در مختصات قبلی ( CreateWindowEx )
Dim p1,p2 As POINTAPI
Dim EditRect As Rect
hFont=SendMessageA(hEdit,WM_GETFONT,0,0)
GetWindowRect hEdit,EditRect
DestroyWindow hEdit
With EditRect
p1.x=.Left : p1.y=.Top
p2.x=.Right :p2.y=.Bottom
ScreenToClient EditRect,p1
ScreenToClient EditRect,p2
.Left=p1.x : .Top=p1.y
.Rigth=p2.x : .Botton=p2.y
End With ' Edit Control Types and Style
برای اضافه کردن Scroll bar افقی از استایل WS_HSCROLL و اسکرول بار عمودی از WS_VSCROLL استفاده بنمائید.یک کنترل ویرایش با اسکرول بارها پیام های اسکرول بار خودش را انجام می دهد یا پروسس می کند.
سیستم سه پیام که برنامه می تواند به کنترل ویر ایش دارای Scroll bar ها ارسال کند را فراهم می نماید.پیام EM_LINESCROLL می تواند بصورت هم افقی و هم عمودی در کنترل ویرایش چند خطه ( MUTILINE ) پیمایش کند ( در خطوط جابجا شود ) . پارامتر lParam شماره تعداد؟ خطوط برای پیمایش عمودی که از خط جاری شروع می شود را مشخص می کند و پارامتر wParam تعداد کاراکترها برای پیمایش افقی ، شروع از کاراکتر جاری را مشخص می نماید. کنترل ادیت پیام دانش تشخیص پیمایش افقی ، اگر استایل EM_CENTER یا EM_RIGHT داشته باشد را ندارد.
پیام EM_LINESCROLL فقط در کنترهای ویرایش چند خطه کاربرد دارد.
پیام EM_SCROLL کنترل ادیت را عمودی پیمایش می کند.پارامتر wParam عمل پیمایش را مشخص می نماید.پیام EM_SCROLL فقط در کنترهای ادیت چند خطه کاربرد دارد. EM_SCROLL همان اثر پیام WM_VSCROLL دارد.
پیام EM_SCROLLCARET چیست ؟
SendMessage RichEdit1.handle, WM_VSCROLL, SB_BOTTOM, 0
تغییر مستطیل قالب بندی Formatting Rectangle :
قابلیت روئت متن کنترل ویرایش توسط ابعاد مستطیل پنجره و مستطیل قالب بندی خودش کنترل می شود. مستطیل پنجره ، .... حاوی کنترل ویرایش است . مستطیل قالب بندی ساختاری است که توسط سیستم برای قالب بندی مان نمایش داده شده در مستطیل پنجره نگهداری می شود.هنگامی که یک کنترل ویرایش برای اولین بار نمایش داده می شود ، دو مستطیل روی صفحه یکسان هستند.یک برنامه می تواند مستطیل قالب بندی را بزرگتر از مستطیل پنجره کند ( در نتیجه دید متن کنترل ویرایش را محدود می کند ) یا کوچک ت از مستطیل پنجره ( درنتیجه فضای سفید اضافی در اطراف متن ایجاد می نماید.)
یک برنامه می تواند مختصات مستطیل قالب بندی کنترل ویرایش را با ارسال پیام EM_SETRECT تنظیم بنماید. پیام EM_SETRECT همچنین بطور خودجوش متن کنترل ویرایش را دوباره ترسیم می نماید.برای تعیین مختصات مستطیل قالب بندی بدون ترسیم مجدد متن کنترل ، یک برنامه می تواند یک پیام EM_SETRECTNP برای کنترل ارسال نماید.برای بازیابی یا گرفتن مختصات مستطیل قالب بندی ، یک برنامه می تواند یک پیام EM_GETRECT به کنترل ارسال نماید. این پیام ها فقط برای کنترل های ویرایش چند خطی کاربرد دارد.
EM_GETLINE :
یک خط از متن کنترل ویرایش را کپی کرده و داخل بافر مشخص شده قرار می دهد. پارامتر wParam درکنترل ویرایش چندخطه یا MultiLine ایندکس لاین است که Zero Base است یعنی ایندکس اولین خط صفر است و اعداد ترتیبی است و برای خط تکی یا SingleL ine از این پارامتر صرفنظر می شود و صفر را قرار می دهید . پارامتر lParam یک بافر است ، برای سیستم Ansi تعداد به Byte نمایش داده میشود و برای unicode تعداد کاراکترهای کپی شده.
برای تنظیم رنگ BackGround برای یک کنترل ویرایش از پیام EM_SETBKGNDCOLOR استفاده بنمائید.
EM_SETCUEBANNER : '&H1501
تنظیم یک تکست محوشو در ادیت کنترل.
نشانه متنی یا Tip که توسط کنترل ویرایش نمایش داده می شود را تنظیم می نماید تا از کاربر اطلاعاتی را درخواست بنماید. در wparam یکی از دو کلمه False یا True استفاده می شود و در پارامتر lparam یک String .
در پارامتر wParam اگر True قرار دهید banner یا نشانه هر وقت که کنترلِ ویرایش فوکس میگیرد می بایست نمایش داده شود.False پیش فرض است و زمانیکه کاربر در کنترل کلیک میکند محو می شود. البته از SendMessageW فقط استفاده کنید چون unicode string هم ارسال می کند مثلا کاراکترهای فارسی که می بایست از Chrw و کد Html مربوطه هر کاراکتر استفاده کنید و حتما داخل StrPtr برای ارسال کدهای Unicode مثل زبان شیرین فارسی !!!
StrPtr : This is often used when passing in UNICODE strings.
EM_LIMITTEXT : '&HC5 محدودیت دروارد کردن کاراکتر
SendMessageA hEdit, &HC5, 5, 0 'lparam not be used
EM_SETPASSWORDCHAR : ' &HCC 'تنظیم نمایش کاراکتردلخواه بجای کاراکترورودی
SendMessageA hEdit, &HCC, Asc("*"), 0 'EM_SETPASSWORDCHAR
تغییر رنگ کنترل Static یا Prompt پنجره با کلاس 32770# :( در اکسس 2016 )
در Caption یا Title پنجره متنی حاوی Num و Typing را ملاحظه می نمائید . با SubClass کردن کنترل ویرایش و استفاده از پیغام با کد دسیمال 258 یا WM_CHAR و با استفاده از تابع SetWindowTextA اینکار صورت گرفته.جلوی Num جواب پیام WM_GETTEXT است که با تابع SendMessageA ارسال شده ( تعداد کاراکترهای کپی شده به متغیر بافر ) و جلوی Typing نیز کد اسکی کاراکتر که wparam است قید می شود البته در اینجا از ((Chr(Clng(wparam استفاده شده برای مشخص کردن کاراکتر، الیته یونیکد را پشتیبانی نمی کند.
Case WM_CTLCOLORSTATIC ',WM_CTLCOLORDLG
'Set the Colors
SetBkMode wParam, 1
SetTextColor wParam, RGB(255, 10, 100)
Dim lfont
lfont = CreateFont(22, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, "Time New Roman")
SelectObject wParam, lfont
InputBoxProcEx = CreateSolidBrush(RGB(80, 0, 180))
Exit Function
پس با توابع API می توان کاراکترها در کنترل Edit که ماسک شده اند ( یا پوشیده شده زیر کاراکتر دیگر مثل " * ") را گرفته یا بازیابی کرد. "هک"
تغییر رنگ در کنترل ویرایش :
Case WM_CREATE
hBrush=CreateSolidBrush(RGB(255,255,255))
CASE &H133 'WM_CTLCOLOREDIT 307
SetTextColor wParam,cl ' RGB(100,0,250)
InputBoxProc=hBrush
Exit Function ' It Needs
Case WM_DESTROY
DeleteObject hBrush
Sample : InputBoxEx "Hi am here to do somthing !!!","Title",vbRed,"Arial"
CHARFORMATA Structure :
حاوی اطلاعات درباره قالب بندی کاراکتر در یک کنترل rich edit
Type CHARFORMATA
cbSize As Long
dwMask As Long
yHeight As Long
yOffset As Long
crTextColor As Long
End Type
SendMessageA hEdit, EM_SETSEL, start_pos, end_pos
Dim cf As CHARFORMATA
With cf
.cbSize=LenB(cf)
.dwMask=CFM_COLOR
.crTextColor=RGB(255,0,0)
End With
SendMessageA hEdit , EM_SETCHARFORMAT, SCF_SELECTION, cf
yHeight : Character height, in twips (1/1440 of an inch or 1/20 of a printer's point).
طبق جدول لینک بالا ، پارامتر lParam در کنترل هندلی است به پنجره آن البته نوتیفیکیشن یا اعلان نیز می فرستد چه زمان فوکس گرفتن ، تغییر و به روز رسانی ، در EN_CHANGE پیام هایی که دریافت شده را ملاحظه بفرمائید.
' If lparam=hRichEdit Then
SendMessageA hEdit, EM_GETCHARFORMAT,SCF_SELECTION,cf_old
cf_old.dwMask=CFM_COLOR
SendMessageA hEdit,EM_SETSEL, -1, -1
SendMessageA hEdit,EM_SETCHARFORMAT, SCF_SELECTION,cf)
SendMessageA hEdit,EM_REPLACESEL, FALSE,text
SendMessageA hEdit,EM_SETSEL, -1, -1
SendMessageA hEdit, EM_SETCHARFORMAT,SCF_SELECTION,cf_old
Debug.Print SendMessageA(lParam, 177, 0, 1) '1
Debug.Print SendMessageA(lParam, 176, 0, 0) '65536=1 اگر دو کاراکترانتخاب شده باشد عدد *2 می شود
?196608/3 =65536 'سه کاراکتر انتخاب شده
Contains information about character formatting in a rich edit control. CHARFORMAT2 is a Microsoft Rich Edit 2.0 extension of the CHARFORMAT structure. Microsoft Rich Edit 2.0 allows you to use either structure with the EM_GETCHARFORMAT and EM_SETCHARFORMAT messages.
BALLOONTIP : em-showballoontip
Type EDITBALLOONTIP
cbStruct As Long 'LenB
pszTitle As String
pszText As String
ttiIcon As Long
END TYPE
EN_CHANGE & EN_UPDATE : &H300,&H400
wParam : قسمت loword حاوی شناسه کنترل ویرایش است و قسمت hiword آن مشخص کننده کد اعلان یا notification code است.
lParam : هندلی به کنترل ویرایش
پیام EN_CHANGE زمان استفاده از استایل ES_MULTILINE ارسال نمی شود و متن از طریق پیام WM_SETTEXT ارسال می گردد.
پیام EN_UPDATE زمانی ارسال می شود که کنترل ویرایش میخواد خودش را Redraw یا ترسیم بنماید . این کد اعلان بعد از اینکه کنترل متن را قالب بندی یا Formatted کرد ، اما قبل از نمایش متن ارسال می گردد. این امکان تغییر اندازه پنجره کنترل ویرایش را در صورت لزوم فراهم می کند. پنجره والدِ ( Parent Window ) کنترل ویرایش این کد اعلان را از طریق یک پیام WM_COMMAND دریافت می نماید
Select Case uMsg
Case WM_COMMAND
If Hiword(wParam)=EN_CHANGE Then 'Hex(wparam \ &H10000)
SetWindowTextA hwnd,"EN_CHANGE"
End If
End Select
در زیر کدهای اعلان کنترل ویرایش با شناسه 4900 گرفته شده که در نهایت باتن ok فشرده شده و صفر یعنی بسته شدن پنجره
4900...100 ' const EN_SETFOCUS = &H100
4900...400
4900...300
4900...400
4900...300
4900...400
4900...300
4900...400
4900...300
4900...400
4900...300
4900...400
4900...300
4900...400
4900...300
4900...400
4900...300
4900...501 'const EN_MAXTEXT = &H501
4900...400
4900...300
4900...400
4900...300
4900...400
4900...300
4900...400
4900...300
4900...400
4900...300
4900...400
4900...300
4900...400
4900...300
4900...400
4900...300
1...0 'Push Ok Button
4900...200 ' const EN_KillFOCUS = &H200
بعنوان پیش فرض تابع DefWindowProc رنگ های پیش فرض سیستم را برای کنترل ویرایش انتخاب می کند. کنترل های ویرایش فقط خواندنی یا غیرفعال پیام WM_CTLCOLOREDIT را ارسال نمی نمایند بجای آن ، آنها پیام WM_CTLCOLORSTATIC را ارسال می نمایند.
Case WM_INITDIALOG
RED RGB(127, 0, 0) GREEN RGB( 0,127, 0) BLUE RGB( 0, 0,127) LIGHTRED RGB(255, 0, 0) LIGHTGREEN RGB( 0,255, 0) LIGHTBLUE RGB( 0, 0,255) BLACK RGB( 0, 0, 0) WHITE RGB(255,255,255) GRAY RGB(192,192,192)
ارسال پیام به کنترل ویرایش در subClass کردن پنجره InputBox و قرار دادن در WM_SETCURSOR پارامتر wParam هندلی است به کنترل
Case WM_SETCURSOR '32
SetWindowLongPtr wStatic, GWL_STYLE, GetWindowLongPtr(wStatic, GWL_STYLE) And WS_TABSTOP
'id=4900 is for Edit Control in window Calss #32770 .... use StrPtr To Transfer Unidoe string
If wParam = OkBtn Then 'Use GetDlgIten
SendMessageA hEdit,WM_SETTEXT, 0, ByVal StrPtr() 'lParam as any WM_TEXT:&HC
ElseIf wParam = CancelBtn Then
SendMessageA hEdit, WM_SETTEXT, 0, ByVal 'lParam as any
ElseIf wParam = wStatic Then
SendMessageA hEdit,WM_SETTEXT, 0, ByVal 'lParam as any
Else
SendMessageA hEdit,WM_SETTEXT, 0, ByVal 'lParam as any
End If
When you move or click the mouse over a static child window, the child window traps the WM_NCHITTEST message and returns a value of HTTRANSPARENT to Windows
WindowFromPoint :
The return value is a handle to the window that contains the point. If no window exists at the given point, the return value is NULL. If the point is over a static text control, the return value is a handle to the window under the static text control.
if you change any of the frame styles, you must call SetWindowPos with the SWP_FRAMECHANGED flag for the cache to be updated properly
موقعیت باتن Cancel در Screen :
GetWindowRect hhcl, btnr
With btnr
p1.x = .Left: p1.y = .Top
p2.x = .Right: p2.y = .Bottom
ScreenToClient hhwnd, p1
ScreenToClient hhwnd, p2
.Left = p1.x: .Right = p2.x
.Top = p1.y: .Bottom = p2.y
padding = (.Bottom - .Top) + 5
End With
ساخت لینک در ناحیه Static :
بدست آوردن موقعیت ناحیه Static با ID 4901 ( طبق روش بالا ) و تخریب پنجره با DestroyWindow و سپس ساخت کنترل جدید با نام SysLink و ID جدید
syslink-control-reference-structures
طبق داکیومنت دو پیام اعلان با کنترل SysLink در ارتباطند یکی برای Mouse با کد 2- و دیگری برای KeyBoard با کد 4- یعنی NM_RETURN
There are two notification messages associated with the SysLink control—one for the mouse (NM_CLICK (syslink)), and one for the keyboard (NM_RETURN).
طبق داکیومنت ساختار NMLINK حاوی اطلاعات اعلان یا نوتیفیکیشن است . این ساختار را با پیام های NM_CLICK یا NM_RETURN ارسال کنید.
The NMLINK Contains notification information. Send this structure with the NM_CLICK or NM_RETURN messages.
HTNML Code :
StrLink="<a href="https://www.w3schools.com/">Visit W3Schools.com!</a>"
<a href="https://www.qries.com/"><img alt="Qries" src="https://www.qries.com/images/banne _logo.png" width=150" height="70"></a>
توسط یک Common Control به پنجره والدش زمانیکه رویدادی رخ می دهد ارسال می شود.
Sent by a common control to its parent window when an event has occurred or the control requires some information.
قسمت lParam به ساختار NMHDR اشاره می کند که شامل کد اعلان است.
Dim el As NMLINK
CopyMemory el, ByVal lParam, LenB(el)
Select Case el.hdr.nCode
Case (-2)
SetWindowTextA hWnd, el.item.iLink
End Select
CopyMemory lParam,ByVal el, LenB(lParam)
If el.item.iLink = 0 Then ShellExecute 0, "Open", "D:\pik.png", 0, 0, 4
در لینک بالا استفاده از اعلان های SysLink بیان شده در تصویر زیر نیز nCode استراکچر NMHDR در پنجره immediate window VBE چاپ شده و تصویر زیرین آن از کد 2- استفاده شده وقتی روی هر کدام از لینک ها کلیک می شود کد index ( ساختار LITEM ) مربوطه در Caption و کنترل Edit نمایش داده می شود . ( با موفقیت تست شده با تصویر ارائه گردید.)
Const NM_CLICK = -2
Const NM_DBLCLK = -3
Const NM_RETURN = -4
Const NM_SETFOCUS = -7
Const NM_SETCURSOR = -17
Const NM_CUSTOMDRAW = -12
Const NM_HOVER = -13
Const NM_LDOWN = -20
Const NM_RDOWN = -21
Free Memory
CopyMemory lParam, ByVal nmh, LenB(lParam)
CopyMemory lParam, ByVal nml, LenB(lParam)
CopyMemory nml.item, ByVal tItem, LenB(nml.item)
تغییر رنگ تمام HyperLink ها در WM_NOTIFY و استفاده از ساختار NMCUSTOMDRAW
If the LM_HITTEST message succeeds, the system fills in LITEM.iLink and LITEM.szID. If the LM_HITTEST message fails, do not assume that any information in LITEM is valid
LITEM item{};
item.mask = LIF_ITEMINDEX | LIF_ITEMID | LIF_URL | LIF_STATE;
item.state = LIS_ENABLED | LIS_FOCUSED | LIS_HOTTRACK;
item.stateMask = LIS_ENABLED | LIS_FOCUSED | LIS_HOTTRACK;
'StringcChCopyA
wcscpy_s(item.szUrl, L_MAX_URL_LENGTH, L"http://www.google.com");
SendMessage(syslink_handle, LM_SETITEM, 0, (LPARAM)&item);
SendMessagewParam,WM_NEXTDLGCTL, GetDlgItem(wParam,loword(CLng(SendMessage(wParam, DM_GETDEFID, 0, 0)))), True
WM_NEXTDLGCTL : ارسال می شود به پروسیجور دیالوگ باکس برای تنظیم فوکسکیبوردبه کنترل متفاوت در دیالوگ باکس DM_GETDEFID : &H400پیام ویندوزی : بازیابی شناسه کنترل باتن فشاری پیش فرض برای دیالوگ باکس ،wParam و lParam در اینجا استفاده نمی شود.اگر موفقیت آمیز باشد قسمت loword حاوی شناسه کنترل است
GetDlgItem : تابعی برای بدست آوردن هندل کنترل دو آرگومان دارداولی هندلی به دیالوگ باکس حاوی کنترل و دومی شناسهکنترل مثلا در InputBox آیدی کنترل Ok یک و Cancel دو می باشد Type CHARRANGE
cpMin As Long,cpMax As Long
End Type
Type FORMATRANGE
hdc As LongPtr
hdcTarget As LongPtr
rc As RECT
rcPage As RECT
chrg As CHARRANGE
End Type
Type NMHDR
hwndFrom As Longptr
idFrom As Longptr
nCode As Long 'notification code
End Type
Type ELINK
nmh As NMHDR
Msg As Long
wParam As LongPtr,lParam As LongPtr
chrg As CHARRANGE
End Type
Dim lNMH As NMHDR
Dim lLink As ENLINK
Case WM_NOTIFY
CopyMemory lNMH,ByVal lParam,Len(lNMH)
Select Case lNMH.code
Case EN_MSGFILTER
CopyMemorylLink, ByVal lParam, Len(lLink)
If (lLink.Msg = WM_RBUTTONDOWN) Then
lhMenu=CreatePopupMenu()
AppendMenu lhMenu, MF_STRING, 1, "&Action1"
AppendMenu lhMenu, MF_STRING, 2, "&Action2"
GetCursorPos lPt
lResult=TrackPopupMenuEx(lhMenu, TPM_LEFTALIGN Or TPM_RETURNCMD _ Or TPM_RIGHTBUTTON,lPt.x, lPt.Y,hwnd, ByVal 0&)
DestroyMenu lhMenu
Select Case lResult
Case 1
Case 2
End Select
End If
Case EN_LINK
CopyMemoru lLink,Byval lParam,LenB(lLink)
if lLink.Msg=WM_LBUTTONUP) Then
lText=GetPlainText(hwnd)
ltext=Mid(ltext,lLink.chrg.cpMin + 1, lLink.chrg.cpMax - lLink.chrg.cpMin) ShellE
ShellExecute ...
End If
End Select
Case WM_PAINT
تابع تبدیل Twips به PixelX :
Private Function TwipsToPixelX(pTwipsX As Long) As Long
Static Mult As Long
Dim hdc
If Mult = 0 Then
hdc = GetDC(0)
Mult = 1440 / GetDeviceCaps(hdc, LOGPIXELSX)
ReleaseDC 0, hdc
End If
TwipsToPixelX=CLng(pTwipsX / Mult)
End Function
Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim ps As PAINTSTRUCT Dim hdc As Long Dim strMessage As String strMessage = "Hello, Win32 GUI(VBA) World!" Select Case uMsg Case WM_PAINT hdc = BeginPaint(hwnd, ps) TextOut hdc, 0, 0, strMessage, Len(strMessage) EndPaint hwnd, ps Case WM_DESTROY Call PostQuitMessage(0) Case Else WindowProc = DefWindowProc(hwnd, uMsg, wParam, lParam) Exit Function End Select WindowProc = 0 End Function
Public Const NIS_HIDDEN = &H1
Public Const NIS_SHAREDICON = &H2
Public Const NIF_ICON = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_TIP = &H4
Public Const NIF_STATE = &H8
Public Const NIF_INFO = &H10
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const WM_MOUSEMOVE = &H200
Public Const MAX_TOOLTIP As Integer = 64 '128
Public Const GWL_WNDPROC = (-4)
Type NOTIFYICONDATA
cbSize As Long
hWnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * MAX_TOOLTIP
dwState As Long
dwStateMask As Long
szInfo As String * 256
uTimeout As Long
szInfoTitle As String * 64
dwInfoFlags As Long
End Type
Public nfIconData As NOTIFYICONDATA
' list the icon types for the balloon message..
Public Const vbNone = 0
Public Const vbInformation = 1
Public Const vbExclamation = 2
Public Const vbCritical = 3
Public Sub RemoveIconFromTray()
Shell_NotifyIcon NIM_DELETE, nfIconData
End Sub
Public Sub AddIconToTray(MeHwnd As Long, MeIcon As Long, MeIconHandle As Long, Tip As String)
With nfIconData
.hWnd = MeHwnd
.uID = MeIcon
.uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
.uCallbackMessage = WM_RBUTTONUP
.dwState = NIS_SHAREDICON
.hIcon = MeIconHandle
.szTip = Tip & Chr$(0)
.cbSize = NOTIFYICONDATA_V3_SIZE
End With
NIF_INFO (0x00000010) :
0x00000010. Display a balloon notification. The szInfo, szInfoTitle, dwInfoFlags, and uTimeout members are valid. Note that uTimeout is valid only in Windows 2000 and Windows XP.
برای نمایش اعلان بالن NIF_INFO و متن را در szInfo مشخص نمائید.
برای حذف اعلان بالن ، NIF_INFO و رشته خالی را در szInfo مشخص نمائید.
برای اضافه نمودن آیکون ناحیه اعلان بدون نمایش اعلان پرچم یا نشانه NIF_INFO را تنظیم ننمائید.
Private Sub AddToolTip()
Dim tCaretPos As POINTAP
RemoveToolTip
if IsWindow(hToolTip)=0 Then
End If
End If
End Sub
Private Sub RemoveToolTip()
If lParam.uMsg=WM_CREATE Then Debug.Print "The handle is: " & lParam.hWnd
End If
CallWndProc=CallNextHookEx(hHook, nCode, wParam, lParam)
End Function
'As Per MSDN Documentary
Function NewWindow(ByVal lngCode As Long,ByVal wParam As LongPtr,ByVal lParam As LongPtr) As Long
if lngCode<0 Then
NewWindow=CallNextHook(hHook,lngCode,wParam,lParam)
Exit Function
End If
CallNextHook hHook,lngCode,wParam,lParam
End Function
switch (message) 'ownerdraw button
{
case WM_MOUSELEAVE:
SetWindowText(hwnd, "Leave!");
break;
case WM_MOUSEMOVE:
SetWindowText(hwnd, "Move!");
tme.cbSize = sizeof(TRACKMOUSEEVENT);
tme.dwFlags = TME_HOVER+TME_LEAVE
tme.dwHoverTime = 1;
tme.hwndTrack = hwnd;
TrackMouseEvent(&tme);
break;
case WM_MOUSEHOVER:
SetWindowText(hwnd, "Over!");
break;
خبر فوری : رهبر انقلاب فرمودند: دشمن میگوید هدفش علی خامنه‌ای است؛ ولی دروغ میگوید؛ هدف دشمن، ملت ایران است.راست میگه اگه سید علی هم نباشه بالاخره سپاه هست که امورات رو بدست بگیره بنده خدا سید علی اون دنیا هم بره مظلوم واقع میشه. 
عبداله محمدی : هشدار یک امام جمعه درباره افزایش قیمت برنج ایرانی تا کیلویی یک میلیون ریال / گرانی افسار گسیخته و مشکلات معیشتی مردم را در رنج و مشقت قرار داده است ( دهم بهمن 1400 )
کیومرث اشتریان استاد علوم سیاسی دانشگاه تهران در روزنامه شرق نوشت:«هرچه به غرب نزدیک شوید از ما دور می‌شوید». این منطق روسیه است که به نظر می‌آید در فاصله معنادار «میز روسی»، در ملاقات اخیر «سران» دو کشور، هویدا شده است؛ یعنی چهره‌ای دیگر از سیاست خارجی روسیه و تحکیم پیوند روسی-اسرائیلی در مواجهه با ایران.
بنظرم کیفیت رو باید ببرند بالا حتی اگر متریال خوب با قیمت بالا استفاده شود و آنوقت ببینیم آقا چه تدبیری خواهند نمود.به قول معروف هر چقدر پول بدهی آش میخوری !!! ( یا فراموش کرده یا .... )
ده بهمن 1400 : برخی از رسانه‌های داخل ایران اعلام کردند که تزریق واکسن آسترازنکا در مشهد ممنوع شده است که به دلیل یک مورد فوتی پس از تزریق این واکسن بوده است. اما روابط عمومی دانشگاه علوم پزشکی مشهد اعلام کرد که شایعات درباره آسیب‌زا بودن واکسن آسترازنکا واقعیت ندارد و توقف موقت تزریق آسترازنکا در مشهد به دلیل عدم موجودی مقطعی آن است.....یکی از عوارض نادر التهاب در ستون فقرات است !!!
یازده بهمن 1400 : محمد هاشمی در صفحه توییترش نوشت:« واکسن آسترازنکا از جمله واکسن‌های موثر علیه بیماری کرونا است که صدها میلیون دوز آن در دنیا و حدود ۱۱ میلیون دوز در ایران استفاده شده است. از ابتدا وزارت بهداشت اعلام کرده بود که به دلیل برخی عوارض نادر، در گروه سنی زیر ۵۰ سال سایر واکسن‌ها ارجح هستند.»
بعد از ممنوع‌الکاری ، من اقدامی نکردم و حتی ارشاد هم نرفتم که ببینم اصلا چرا ممنوع شدم یا درخواست بدهم ممنوع‌الکاری‌ام را لغو کنند. حتی کسی به من خبر نداد ممنوع‌الکار شده‌ام. آن موقع کارگردان‌‌ها و تهیه‌کننده‌ها لیست بازیگران‌شان را می‌بردند ارشاد و به آنها می‌گفتند هاشم‌پور فعلا نمی‌تواند کار کند. دلیل خاصی نداشتند فقط گفتند ایشان خیلی دارد پرواز می کند و مطرح میشود»
11 بهمن 1400 : سرپرست شرکت عمران شهرهای جدید با بیان اینکه طبق بررسی‌ها قیمت ساخت واحدهای نهضت ملی مسکن ۴ میلیون و ۷۰۰ هزار تومان در هر متر مربع تعیین شده است گفت: اولویت ما در اجرای پروژه، سازندگان داخلی هستند ولی به منظور ارتقای تکنولوژی ساخت و کاهش سرعت اجرا مذاکراتی با شرکتهای چینی و ترکیه‌ای داشته‌ایم.
11 بهمن 1400 : محمدرضا خباز در گفتگویی درباره ادعای انقلابی‌گری برخی وزرا گفت: از رفتار برخی وزرا احساس می شود، آنها نه انقلابی هستند، نه حق الناس سرشان می شود و نه حقوق مردم برای آنها ارزش دارد. چندی پیش همسر یکی از وزرای دولت سیزدهم که خیلی ادعایش نیز بالاست، برای زایمان به یکی از بیمارستان های خصوصی تهران رفت
وی افزود: نوزاد متولد شده آقای وزیر چون زودتر از موعد به دنیا آمد، تا مدت ها در دستگاه بود بنابراین هزینه بیمارستان زیاد شد. نخست انتظار داشتیم که اگر وزرای دولت سیزدهم انقلابی هستند خود و بستگان‌شان به بیمارستان های دولتی مراجعه کنند، نه به بیمارستان خصوصی پرهزینه. ثانیا با وجود تخفیف فراوان، بیمارستان نهایتا فاکتور ۲۸۰ میلیون تومانی برای آقای وزیر صادر کرد که او باید این مبلغ را پرداخت می کرد اما آقای وزیر فقط با پرداخت یک میلیون تومان، نوزاد را ترخیص کرد.
ملت چه پول هایی که ندارند ماشالله کدوم بیمه است که سقف زایمانش 280 میلیونه یا هزینه بیمارستانیش ؟؟؟؟ و مشخصه به بیمارستان دولتی اعتقادی ندارند چرا چون همه آموزشی اند دکتر باسواد و باتجربه در بیمارستان دولتی یا جراحی نمی کنه یا بعنوان نمادین و دریافا تسهیلات دولتی مجبور به این کاره !!!
12 بهمن 1400 : روز گذشته خبر رسید که یک نفر ۳۰۰۰ واحد مسکن مهر در اختیار دارد؛ این در حالی است که ارزش این تعداد واحد در اوایل دهه ۹۰ به کمتر از ۸۰ میلیارد تومان می‌رسید، حالا اما به دلیل برخورداری مالک این تعداد واحد از زیرساخت‌ها و امکانات دولتی، صاحب حدود ۳۰۰۰ میلیارد تومان سرمایه است. احمدی نژاد و روحانی انقلابی مبارک باد دهه زجر!!!
14 بهمن 1400 : این در حالی بود که امروز بنا به درخواست رئیس جمهور، سیدحسن خمینی قبل از وی به ایراد سخن پرداخت اما در همین هنگام شبکه خبر ضمن قطع برنامه زنده، به پخش ادامه برنامه‌های عادی پرداخت و پس از شروع سخنان رئیس‌جمهور، مجددا پخش زنده را از سر گرفت!
14 بهمن 1400 : فرزندان شهید سلیمانی به عیادت محمد کاسبی بازیگر پیشکسوت سینما و تلویزیون رفتند و انگشتر سردار دلها را به این هنرمند اهدا کردند.
بهمن 1400 : احمدی نژاد در دیدار با جمعی از فرهنگیان که پنجشنبه گذشته، هفتم بهمن انجام شد، اخراج برخی اساتید دانشگاه را به شدت مورد انتقاد قرار داد
بهمن 1400 : حمله یکی از اراذل و اوباش در شیراز به یک مامور پلیس و بریدن شاهرگ او، در فضای مجازی بسیار پربحث شده است. انتشار فیلم تکان‌دهنده این حادثه، این سوال را برای مخاطبان ایجاد کرده است که واقعا چرا سروان علی‌اکبر رنجبر با وجود اینکه اسلحه در دست داشت، به سمت مهاجم مسلح شلیک نکرد؟ پیش از این اتفاق نیز اخبار متعدد از گرفتاری بسیاری از محیط‌بان‌ها بدلیل شلیک به سمت شکارچیان غیرمجاز، این گزاره را پررنگ‌تر میکند که اساسا محافظان محیط زیست سلاح دارند ولی گویی نباید از آن استفاده کنند.
۱۷ بهمن 1400 : با وجود سیر نزولی قیمت دلار، نرخ خرده فروشی انواع برنج خارجی در بازار مصرف همچنان در حال افزایش است به‌نحوی که قیمت برنج هندی و پاکستانی به مرز ۳۳تا ۳۵هزار تومان رسیده است. پیش از این نرخ برخی انواع برنج مرغوب ایرانی از ۹۵هزار تومان عبور کرده بود.
18 بهمن : علیرضا مرندی وزیر پیشین بهداش، درمان و آموزش پزشکی در یک برنامه تلویزیونی در شبکه سلامت ضمن دعوت از مردم برای دریافت دزهای واکسن کرونا، از دریافت دُز سوم واکسن کرونا توسط رهبر انقلاب خبر داد و گفت: همانطور که مقام معظم رهبری سه نوبت واکسن‌شان را تزریق کرده‌اند و واکسن ایرانی و برکت هم زدند، ما هم باید همین‌کار را بکنیم، آن‌هایی که واکسن نزدند عجله کنند.
ListBox در InputBox
Vb Uses Unicode For Text String hence delcare SendMessageW instead Of SendMessageA****
: Important Notes
Use -----> LBS_OWNERDRAWFIXED Or LBS_HASSTRINGS
use -----> SendMessageW, / TextoutW
To Add Item it is important to Use SendMessageA And Byval "Item" you want to add like
"SendMessageA hlist, &H180, 0, ByVal "FFF
case WM_DRAWITEM
Dim Buff As String * 255 ' important
GetClientRect pdis.hwndItem, pdis.rcItem
r = pdis.rcItem
l = SendMessageW(pdis.hwndItem, LB_GETTEXT, pdis.itemID, ByVal Buff
SendMessageA pdis.hwndItem, LB_GETITEMRECT, pdis.itemID, r
TextOutW pdis.hdc, r.Left, r.Top, ByVal Buff, l
"SendMessageA hlist, &H180, 0, ByVal "FFF
"SendMessageA hlist, &H180, 0, ByVal "HHT
"SendMessageA hlist, &H180, 0, ByVal "123E
"سلام" SendMessageA hlist, &H180, 0, ByVal
"حاجی"SendMessageA hlist, &H180, 0, ByVal
if pdis.itemid mod 2=. then SetTextColor Else SetTextColor
If pdis.itemAction = ODA_SELECT Then
( l = SendMessageW(pdis.hwndItem, LB_GETTEXT, pdis.itemID, ByVal Buff
SetWindowTextW hwnd, ByVal Buff
End If
Static OldRect
If pdis.itemAction = ODA_SELECT Then
( l = SendMessageW(pdis.hwndItem, LB_GETTEXT, pdis.itemID, ByVal Buff
SetWindowTextW hwnd, ByVal Buff
r.Left = r.Left + 15
(FillRect pdis.hdc, r, GetSysColorBrush(0
InvalidateRect pdis.hwndItem, OldRect, 1
OldRect = r
End If
%WS_CHILD Or %LBS_OWNERDRAWFIXED Or %LBS_MULTICOLUMN Or %LBS_NOTIFY Or %WS_TABSTOP Or %WS_HSCROLL, %WS_EX_CLIENTEDGE
ListBox در InputBox
vb Uses Unicode for text string so use SendMessageW instead Of SendMessageA Function
The list box has the LBS_OWNERDRAWFIXED and LBS_HASSTRINGS styles, in addition to the standard list box styles.
LBS_HASSTRINGS
LB_GETTEXT
The return value is the length of the string, in TCHARs, excluding the terminating
(null character ( hence buff+1
If the list box has an owner-drawn style but not the LBS_HASSTRINGS style, the buffer pointed to by the lParam parameter receives the value associated with the item the item data
Means Use Byval
If the list box has WS_HSCROLL style and you insert a string wider than the list box, send an LB_SETHORIZONTALEXTENT message to ensure the horizontal scroll bar appears.
Case WM_MEASUREITEM
Case WM_DRAWITEM
Dim pdis As DRAWITEMSTRUCT
Dim tm As TEXTMETRIC
Dim hDCMem As LongPtr
CopyMemory pdis, ByVal lParam, 40
Select Case pdis.itemAction
Case ODA_SELECT, ODA_DRAWENTIRE
Dim p As RECT
GetClientRect pdis.hwndItem, pdis.rcitem
BitBlt pdis.hdc
SetBkMode pdis.hdc, 0
SetTextColor pdis.hdc, vbRed
TextOutA pdis.hdc, pdis.rcitem.Left,pdis.rcitem.Top, buffer$, 5
CopyMemory lParam, pdis,40
End Select
گرفتن تعداد آیتم ها در لیست باکس
LB_GETCOUNT message
Gets the number of items in a list box
wParam,lParam
Not used; must be zero
Dim index As Integer
Dim textBuff As String
(textBuff = Space(255
(NumItems=SendMessage(hWndList,LB_GETCOUNT,0,0
index use GETCURSEL'
Gets the index of the currently selected item)'
(if any, in a single-selection list box'
SendMessageW hWndList, LB_GETTEXT,index, textBuff
MsgBox textBuff
docs.microsoft.com/enmeasureitemstruct
مثالی از کشیدن نقطه چین دور آیتم سلکت شده به زبان دیگر
if lpdis->itemState & ODS_SELECTED
* Set RECT coordinates to surround only the'
* bitmap.
rcBitmap.left=lpdis->rcItem.left
rcBitmap.top=lpdis->rcItem.top
rcBitmap.right=lpdis->rcItem.left+XBITMAP
rcBitmap.bottom=lpdis->rcItem.top + YBITMAP
* Draw a rectangle around bitmap to indicate'
* the selection.
DrawFocusRect lpdis->hDC, &rcBitmap
استفاده در مثال شکل بالا به زبان دیگر
Display the text associated with the item'
SendMessage lpdis->hwndItem
LB_GETTEXT,lpdis->itemID, (LPARAM) tchBuffer,
GetTextMetrics lpdis->hDC, &tm
GetClientRect lpdis.hwnditem,lpdis.rcItem'
-y=(lpdis->rcItem.bottom+lpdis->rcItem.top
tm.tmHeight) / 2
6+TextOutA lpdis->hDC,XBITMAP
(y,tchBuffer,len(tchBuffer,
SelectObject hdcMem, hbmpOld
DeleteDC hdcMem
The GetTextMetrics function fills the specified buffer with the metrics for the currently selected font
BOOL GetTextMetrics( HDC hdc, LPTEXTMETRIC lptm );
Parameters
hdc
A handle to the device context
lptm
A pointer to the TEXTMETRIC structure that receives the text metrics.
Type TEXTMETRICA
tmHeight As Long
tmWeight As Long
tmItalic As Long
tmMaxCharWidth As Long
tmUnderlined As Long
tmCharSet As Long
End Type
: case WM_MEASUREITEM
;lpmis = (LPMEASUREITEMSTRUCT) lParam
;lpmis->itemHeight=20
;return TRUE
(DrawEntire(LPDRAWITEMSTRUCT lpDStruct
;(CRect rect(lpDStruct->rcItem
;HDC dc =lpDStruct->hDC
;MYLISTITEM *a = (MYLISTITEM*)lpDStruct->itemData
TextOut(dc,rect.left+20,rect.top+2,a->title,strlen(a-
;((title<
;(SelectObject(dc,hOldFont
;(SelectObject(dc,oldpen
;(SelectObject(dc,oldbrush
;("strcpy(logFont.lfFaceName,"courier
;(hFont = CreateFontIndirect(&logFont
(hOldFont = (HFONT)SelectObject(dc,hFont
CHARFORMAT صرفا جهت فرمت کاراکتر
InitCommonControls
if lparam=hRichEdit Then
SendMessage(hRichEdit,EM_setBkgndColor,False,Green)
Dim P As CharRange
P.cpmin = 0 : P.cpmax = -1
SendMessage(hRichEdit,EM_EXSetSel, 0, VarPtr(p))
'0,-1 selects all 'make selection red Local
Dim cf As CHARFORMAT
cf.cbSize=Len(cf)
cf.dwMask=CFM_COLOR
cf.crTextColor=vbRed
SendMessage(hRichEdit,EM_SETCHARFORMAT,SCF_SELECTION,VarPtr(cf))
P.cpmin = 0:P.cpmax = 0
SendMessage(hRichEdit,EM_EXSetSel,0, VarPtr(p))
End If
Type CHARRANGE
cpMin As Long
cpMax As Long
End Type
CHARRANGE structure
Specifies a range of characters in a rich edit control.
If the cpMin and cpMax members are equal, the range is empty. The range includes everything if cpMin is 0 and cpMax is –1
TabOrder .... KeyBoard Focus در InputBox
KEYBOARD FOCUS
تماما طبق داکیومنت آفیس و فروم خارجی انجام شده ماجیک نیست و بنده هم خالقش نیستم تجربه ای بود که شما را هم سهیم کردم هر چند خود شما استاد بنده هستید.
در پیام ShowWindow در WndProc
تب اوردر یا ترتیب فوکس کنترل ها در Inputbox اول Edit است و بعد Ok و نهایتا Cancel
درhbtn که JK است در EXSTYLE آن از CLIENTEDGE و STATICEDGE استفاده شده
در تابع زیر فوکس بعد از ٍ Edit به باتن JK داده شده طبق تصویر و بعد به باتن Cancel طبق تصویر پایین ترش
Et: Edit Control Handle
اگر NOSIZE را بکار نبریم سایز باتن صفر میشود پس حتما بگذارید مگر اینکه بخواهید سایز طبق آرگومانها تغییرکند همچنین جابجایی اش .
SetWindowPos hbtn, Et, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
SetWindowPos GetDlgItem(hwnd, 2), hbtn, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
ProgressBar نوار پیشرفت
lParam
Pointer to an NMUPDOWN structure that contains information about the position change. The iPos member of this structure contains the current position of the control. The iDelta member of the structure is a signed integer that contains the proposed change in position
If the user has clicked the up button, this is a positive value
If the user has clicked the down button, this is a negative value
SendMessage(hControl, PBM_SETSTEP, (WPARAM) 1,
Parameters
wParam
State of the progress bar that is being set. One of the following values.
lParam
- Must be zero.
UPDOWN CONTROL در InputBox
Dim nmh As NMHDR
Dim nmp As NMUPDOWN
1400UpDownControlId
Case WM_NOTIFY
چون کنترل ساخته شده پیامی را دریافت نمی کند از طریق parent خود در نتیجه
If wParam = 1400 Then nmh.code = (-722) ' UDN_DELTAPOS
SetWindowTextA Et, nmh.hwndFrom & " ID: " & nmh.idFrom & "/ code ...." & nmh.code & "... Wparam: " & wParam
If nmh.code = (-722) Then
( CopyMemory nmp, ByVal lParam, Len(nmp
nmp.hdr = nmh ' No Need'
SetWindowTextA hwnd, "Delta : " & nmp.iDelta & " Pos : " & nmp.iPos
End If
(CopyMemory lParam, nmp, Len(nmp
iPos
Type: int
Signed integer value that represents the up-down control's current position.
iDelta
Type: int
Signed integer value that represents the proposed change in the up-down control's position.
Static ddd
If nmp.iDelta = 1 Then ddd = ddd - 1 Else ddd = ddd + 1
nmp.iPos = ddd
SetWindowTextA hwnd, "Delta : " & nmp.iDelta & " Pos : " & nmp.iPos
End If
in case wm_destroy nmp.ipos=0:ddd=0'
UDM_SETRANGE message
Sets the minimum and maximum positions (range) for an up-down control
Parameters
wParam
Must be zero
lParam
The LOWORD is a short that specifies the maximum position for the up-down control, and the HIWORD is a short that specifies the minimum position
case WM_VSCROLL
delta=LOWORD(SendDlgItemMessage(dlg, IDC_SPIN1,UDM_GETPOS,0,0))
SetDlgItemText(dlg,IDC_DTRANS,mystring
WM_VSCROLL
wparam
The HIWORD specifies the current position of the scroll box
The LOWORD specifies a scroll bar value that indicates the user's scrolling request.
SB_BOTTOM
SB_TOP
lParam
If the message is sent by a scroll bar control, this parameter is the handle to the scroll bar control. If the message is sent by a standard scroll bar, this parameter is NULL.
با WS_TABSTOP فوکس میگیرد ( کیبورد) ولی برای اجرای دستور توسط پیام WM_COMMAND باید از lparam آن استفاده کرد که هندل پنجره ایجاد شده است .
Case WM_COMMAND ' wm-command
"!!!..." & ( If lParam = hbtn Then MsgBox "Clicked " & GetWindowText(hbtn
Select Case wParam
Case 2
End Select
با توجه باینکه WS_TABSTOP تنظیم شده لذا باتن JK توسط کلید TAB کیبورد فوکس خواهد گرفت و در شکل زیر نقطه چین هایی که در مستطیل آن باتن مشخص است نشاندهنده ی فوکس گرفتن است .
ListBox
LongInt2Int wParam, iHw, iLW
تغییر ترتیب تب Change Tab Order
HWNDTOP
hWndInsertAfter
Type: HWND
A handle to the window to precede the positioned window in the Z order. This parameter must be a window handle or one of the following values.
HWND_BOTTOM(HWND)1
HWND_NOTOPMOST(HWND)-2
HWND_TOP(HWND)0
HWND_TOPMOST(HWND)-1
HideCaret/ShowCaret
Case WM_CHAR
)Function UserInfoProc
(hUserInfoWnd,uMsg,wParam,lParam,uIdSubclass,dwRefData
(uMsg,wParam,lParam
if uMsg =WM_SETFOCUS) '?maybe
HideCaret hUserInfoWnd
ترسیم دکمه ای شکل ( Button shaped) در InputBox استفاده از DrawFrameControl
با DrawIcon هم می توان آیکونی را در DC صفحه انداخت
ترسیم خط LineTo
تمام منابع خارجی
Dim px As POINTAPI
GetCursorPos px
'ClientToScreen hwnd, px
MoveToEx hdc, 120, 30, px
LineTo hdc, 140, 30
MoveToEx hdc, 120, 30, px
LineTo hdc, 135, 15
' Quarter
MoveToEx hdc, 120, 30, px
LineTo hdc, 134, 44
MoveToEx hdc, 120, 30, px
LineTo hdc, 120, 50
' Quarter
MoveToEx hdc, 120, 30, px
LineTo hdc, 105, 44
MoveToEx hdc, 120, 30, px
LineTo hdc, 120, 10
' Quarter
MoveToEx hdc, 120, 30, px
LineTo hdc, 105, 14
MoveToEx hdc, 120, 30, px
LineTo hdc, 100, 30
Rotate
using WM_TIMER
Dim tt As RECT
Static Deg
Deg = Deg + 5
If Deg > 360 Then Deg = 0
Dim xl, yt
xl = 120: yt = 30
tt.Left = 99: tt.Top = 5: tt.right = 141: tt.bottom = 55
(FillRect hdc, tt, GetSysColorBrush(15
طول خط 20
در ربع اول If 0 < Deg < 90 Then ' Quarter
Newx = xl + Sin(Deg * Sin1) * 20
Newy = yt - Cos(Deg * Sin1) * 20
End If
در ربع دوم If 90 < Deg < 180 Then
Newx = xl + Cos(Deg * Sin1) * 20
Newy = yt + Sin(Deg * Sin1) * 20
End If
در ربع سوم If 180 < Deg < 270 Then
Newx = xl - Sin(Deg * Sin1) * 20
Newy = yt + Cos(Deg * Sin1) * 20
End If
در ربع چهارم If 270 < Deg < 360 Then
Newx = xl - Cos(Deg * Sin1) * 20
Newy = yt - Sin(Deg * Sin1) * 20
End If
MoveToEx hdc, 120, 30, px
LineTo hdc, Newx, Newy
xl = 120: yt = 30
tt.Left = 100: tt.Top = 5: tt.right = 140: tt.bottom = 55
(FillRect hdc, tt, GetSysColorBrush(15
Arc hdc, 100, 10, 140, 50, 0, 0, 0, 0
SelectObject hdc, HoldPen
Arc hdc, 115, 25, 125, 35, 0, 0, 0, 0
SelectObject hdc, HoldPen1
Newx = xl + Sin(Deg * Sin1) * 16
Newy = yt - Cos(Deg * Sin1) * 16
MoveToEx hdc, 120, 30, px
LineTo hdc, Newx, Newy
Deg = Deg + 10
DeleteObject HoldPen
DeleteObject HoldPen1
CreatePen ساخت قلم برای ترسیم
Const PS_DASH = 1
Const PS_DOT = 2
Const PS_DASHDOT = 3
Const PS_DASHDOTDOT = 4
Const PS_NULL = 5
Const PS_INSIDEFRAME = 6
((hPen=CreatePen(PS_DASH,0,RGB(0,255, 0
(hOldPen=SelectObject(hDC,hPen
Ellipse hDC, 100, 150, 350, 300
SelectObject hDC, hOldPen
DeleteObject hPen
Applies new frame styles set using the SetWindowLongfunction. Sends a WM_NCCALCSIZE message to the window, even if the window's size is not being changed. If this flag is not specified, WM_NCCALCSIZEis sent only when the window's size
Paint InputBox
موارد پایین تست شده ... البته اینها موارد ساده ای هستند و پیش پا افتاده
Public Function CallWindProc(ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim hdc As LongPtr
Select Case Msg
Case WM_PAINT
Dim cc As RECT
GetClientRect hwnd, cc
(hdc = GetDC(hwnd
((FillRect hdc, cc, CreateSolidBrush(RGB(255, 0, 255
Case WM_DESTROY
SetWindowLongPtr hwnd, GWL_WNDPROC, OldWindow
End Select
CallWindProc = CallWindowProc(OldWindow, hwnd,
(Msg, wParam, lParam,
End Function
(FillRect hdc, cc, GetSysColorBrush(5
(FillRect hdc, cc, GetSysColorBrush(16
TIMER
Case WM_TIMER
GetClientRect hwnd, rcClient
hdc
(GetDC(hwnd=
DrawText hdc, x, 2, rcClient, DT_CENTER
SetWindowTextA hwnd, x
x = x + 1
ترسیم مستطیل در InputBox
Case WM_TIMER
Dim Et As LongPtr
Dim WinRect As RECT
Et:Edit Handle,WinRect For Edit Control'
GetWindowRect Et, WinRect
( hdc = GetDC(hwnd
rc.Left = 10
rc.Top = 68
rc.right = 70
rc.bottom = 88
rcClear.Left = rc.Left: rcClear.right = GetUpdateRight
rcClear.Top = rc.Top - 3: rcClear.bottom = rc.bottom
rc.Left = rc.Left + x: rc.right = rc.right + x
Fill Rectangle'
( FillRect hdc, rcClear, GetSysColorBrush(15
Draw Rectangle'
Rectangle hdc, rc.Left, rc.Top, rc.right, rc.bottom
FillRect Again GetSysColorBrush(18) ' Black'
Use Offset And FillRect rc With Another Brush'
GetUpdateRight = rc.right + x
If rc.right > WinRect.right - WinRect.Left Then x = 0
MOVECURSOR رسم مستطیل
WM_MOUSEMOVE
Dim p As POINTAPI
GetCursorPos p
ScreenToClient hwnd, p
Dim ff As RECT
Dim ff1 As RECT
SetRect ff, p.x, p.y, p.x, p.y
ff.Left = p.x - 15
ff.Top = p.y - 15
ff.right = p.x + 35
ff.bottom = p.y + 30
DrawFrameControl GetDC(hwnd), ff, DFC_BUTTON, DFCS_BUTTONPUSH
RoundRect GetDC(hwnd), ff.Left, ff.Top, ff.right, ff.bottom, 16, 16
( FillRect GetDC(hwnd), ff, GetSysColorBrush(16
Sleep 100
InvalidateRect hwnd, ff, 1
UpdateWindow hwnd
(ReleaseDC hwnd, GetDC(hwnd
GETWINDOWRECT نمایش باتن ساخته شده در InputBox
دادن ابعاد مستطیل پنجره ی مشخص شده ( ابعاد در مختصات صفحه داده میشود ) در ClientRect عدد x و y گوشه ی بالایی صفر است
Retrieves the dimensions of the bounding rectangle of the specified window. The dimensions are given in screen coordinates that are relative to the upper-left
.corner of the screen
برای اضافه کردن باتن ازCreateWindowEx استفاده میشود . در زمان ساب کلاس کردن و قرار دادن در پیام SHOWWINDOW و استفاده از استایل WS_CHILD OR WS_VISIBLE اگر بخواهیم میتوان از BS_OWNERDRAW استفاده کرد و باتن خود را در پیام CTLCOLORBTB ( که lparam هندلی است برای هندل باتن ) ترسیم کرد .
فرضا اگر به InputBox در زیر باتن کنسل بخواهیم باتنی اضافه کنیم می توانیم با GetWindowRect موقعیت باتن کنسل را بگیریم منظور X و Y گوشه بالایی و با GetClientRect عرض و طول باتن Cancel را بدست آوریم ( همانطور که گفته شد GetClientRect گوشه بالایی هر کنترلی را صفر میدهد )
Dim WinRect As RECT
Dim BtnWinRect As RECT
Dim BtnClientRect As RECT
Dim CyFrame As Long
(CyFrame=GetSystemMetrics(SM_CYFRAME
(CyCaption=GetSystemMetrics(SM_CYCAPTION
GetWindowRect Hwnd,WinRect
GetWindowRect BtnHandle,BtnRect
GetClientRect BtnHandle,BtnClientRect
ابعاد زیر میشود پارامترهایی که باید در آرگومانهای تابع CreateWindowEx قراردهیم x1,y1 میشود مختصات گوشه ی بالایی سمت چپ و cx ( عرض ) و cy ( ارتفاع ) یا x2 و y2 میشود مختصات گوشه پایینی سمت راست
LeftBound=(BtnWinRect.Left-WinRect.Left)+CyFrame
TopBound=(BtnWinRect.Top-WinRect.Top)+CyFrame
(CyCaption/2)+
RightBound'
Width=BtnClientRect.Rigth-BtnClientRect.Left
BottomBound'
Height=BtnClientRect.Bottom-BtnClientRect.Top
PtInRect در کنترل Edit مربوط به پنجره InputBox
کار سختی نیست از منبعی که در انتهای صفحه آمده استفاده شده که تابع ویندوزی است
Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, pt As POINTAPI) As Long'
Use Belows Only
Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
If PtInRect(nn, p.x, p.y) Then
" ... MsgBox "You Clicked Me
End If
.....RedrawWindow
مورد بالا تست شده
در 32 بیت
آیدی کنترل های InputBox
ارسال تکست به کپشن پنجره در صورت فشردن باتن Ok در صورتیکه تعداد کاراکتر داخل کنترل ادیت بیشتر از 13 باشد
wParam
The LOWORD contains the identifier of the edit control
lParam
A handle to the edit control
To receive EN_CHANGE notification codes, specify ENM_CHANGE in the mask sent with
EM_SETEVENTMASK message
Private Const EM_SETEVENTMASK As Integer = 1073
ENM_CHANGE = 1
ENM_UPDATE = 2
wParam
.This parameter is not used; it must be zero
lParam
New event mask for the rich edit control. For a list of
Return value
.This message returns the previous event mask
Remarks
The default event mask (before any is set) is
WndProc
Case WM_COMMAND
Case 1
(InputDataLen=SendDlgItemMessage(hwnd,EM_LINELENGTH,0,0
if InputDataLen>14 Then
"....SetWindowTextA hwnd,"Exceed Data
Sleep 1000
End If
Case 2
Case 4900
End Select
این پیام هنگامی ارسال میشود که یوزر اقدام به تغییر متن در کنترل EDIT کرده است. ( منظور پیام EN_CHANGE )
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
قلاب کردن پنجره HOOK و دسترسی به کلاس های آن از طریق Subclass کردن
در WIN32 :
Set the Font'
lFont=CreateFont(((INPUTBOX_FONTSIZE/72)*96),0,0,0,0,0,0,0,0,0,0,0,0,
SelectObject wParam,lFont
End If
قلاب کردن InputBox برای ارسال پیام ویندوزی به آن HOOK /SUBCLASS
تست نشده ولی جواب خواهد داد توابع برای استفاده در Win32 است در Win64 نحوه ی اظهار توابع فرق میکند که در لینک توابع API در [ پیوندها ] ، نحوه ی صحیح آن در سایت خارجی درج شده.