ایجاد SysLink در پنجره دیالوگ باکس - Win32

controls/syslink

لینک بالا سندی درباره کنترل های داخل Syslink است . هر آیتم در این پنجره با کلاس Syslink از مجموعه کتابخانه commctl32  یک نوع باتن است که بشکل Hyperlink نمایش داده میشود و ایندکس آن Zero-Based است یعنی از صفر شروع می شود 

با تابع CreateWindowEx می توان آنرا در هر مختصاتی از صفحه ایجاد کرد فرضا در Msgbox می توان با تابع DestroyWindow پنجره Static با آیدی 4901 را تخریب و جای آن این پنجره را تعبیه کرد البته می توان ناحیه Static را کاری کرد که در آن تکست Hyperlink نیز بنمایش درآید در پیوندها بدان اشاره شده ولی به زبان Vba نیست باید رمزگشایی کنید. ( ساخت یک ناحیه استاتیک دیگر و ساب کلاس این  کنترل ) 

اگر پنجره WM_NOTIFY را دریافت کند( می توان استایل SS_NOTIFY را در پارامتر CreateWindowEx تنظیم نمود.)  NM_CLICK با عدد ثابت منهای 2 را دریافت می کند و اینجا می توانید Index آیتمی را که کلیک کردید را بازیابی نمائید. 

ساختار NMLINK را در اینترنت جستجو و مشاهده نمائید داخلش دو ساختار NMHDR و LITEM وجود دارد که در قسمت دوم iLink مشخص کننده ایندکس است .

Type NMHDR

hWndFrom As LongPtr

idFrom As Long

nCode As Long

End Type

Type LITEM

iLink As Long

End Type

Type NMLINK

nmh As NMHDR

tItem As LITEM

End Type

از تابع CopyMoemory برای تخصیص حافظه استفاده نمائید . استفاده از این تابع ضروریست !!! 

Dim nmh As NMHDR

if nmh.nCode=-2 Or nmh.nCode=-4 Then 

CopyMemory nmh.tItem,ByVal lParam,LenB(nmh.tItem)

SetWindowTextA hwndParent,nmh.tItem.iLink

End If 

ثابت های دسیمال منهای چهار زمانیست که روی لینک اینتر می زنید و منهای دو زمانیکه کلیک می کنید.

البته NM_SETFOCUS و NM_CLICKFOCUS هم وجود دارد البته نه برای همه آیتم ها ،زمانیکه فوکس روی Syslink برود یا آنرا ترک  کند .

در مطالب این بلاگ  ، اگر InputBox را سرچ کنید مطلب و تصویربرای فهم بیشتر قرار داده شده 

آیدی کنترل استایتک که prompt در آن قرار میگیرد 65535 است که با تابع GetDlgCtrlId می توان هندل پنجره را گرفت و با تابع GetWindowClass نیز کلاس پنجره البته تابع دوم باید متغیری را بعنوان بافر تنظیم کرد که تعداد کاراکتر کلاس را درون آن کپی می کند (  نتیجه برگشتی تعداد کاراکتر کپی شده است ) و از طریق آن با تابع left می توانید رشته را دریافت کنید تعداد کارکتر کپی شده هم که با تابع قبلش .

البته مطلب دیگری که در اسناد موجود است و باید بدانید این است که برای تغییر ایندکس Tab روی پنجره ها یا به بیانی دیگر تغییر در z-order از تابع SetWindowPos استفاده میشود دو تا پارامتر اول hwnd و hwndinsertafter دارد که دراینجا TabIndex تغییر می نماید. اگر hwndInsertAfter را صفر در نظر بگیرید و دیگر پارامترهای x و y را هم صفر قرار دهید پنجره ای ندارید متاسفم !

create-a-command-link  'BS_COMMANDLINK

bcm-setnote

syslink-control-reference-messages

LM_HITTEST Message : 

مشخص می کند آیا کاربرلینک مشخص شده  را کلیک کرده است 

wParam  

Must be **NULL**.

lParam

Pointer to a **LHITTESTINFO** structure to be filled with information about the link the user clicked, if any exists.

Return value

جواب True است اگر کاربر روی یک پیوند یا لینک را کلیک نماید ، در غیر اینصورت False خواهد بود

Returns TRUE if user clicked on a link, otherwise returns FALSE.

رنگ ناخن در تشخیص بیماریها

بدانید و آگاه باشید ... زنهار

پلیس فتا - هشدار: سامانه ثنا از شماره شخصی پیامک ارسال نمی‌کند، به هیچ وجه روی لینک‌های ارسالی کلیک نکنید، بدانید که: کلیک=خالی شدن حساب

نحوه عملکرد شما را به درگاه جعلی متصل می کند و می گوید برای نمایش مبلغ ناچیزی پرداخت کنید و پرداخت کردن همانا و سرقت شماره کارت و رمز دوم و تاریخ انقضاء همانا و نهایتا خالی کردن حساب ... هر لینکی از شماره شخصی جرم است و می بایست به پلیس فتا 110 فی الفور گزارش شود. حتی در واتساپ یا gmail هم لینک ناشناس را که جهت سرقت داده هاست کلیک نکنید

در نشست خبری فیلم سینمایی «نمور» که در در واپسین روز چهلمین جشنواره فیلم فجر برگزار شد، یکی‌از خبرنگاران حاضر در نشست از نوشین معراجی نویسنده فیلم «نمور» پرسید: باتوجه به حلال‌زاده نبودن یکی از شخصیت‌های فیلم، چرا این اثر به مقام مادر تقدیم شده است؟ و معراجی در پاسخ گفت: «وقتی دو نفر همدیگر را دوست دارند، عشقی که بین‌شان وجود داشته، آن قدر حرمت دارد که به‌نظر من بچه‌ای که از آن‌ها به دنیا می‌آید حلال‌زاده است! »  

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

عباس عبدی، فعال سیاسی اصلاح طلب در توئیتی با اشاره به سخنان این هفته ائمه جمعه و انتقادات تند آنان از اظهارات نوشین معراجی، فیلمنامه‌نویس «نمور» در جشنواره فیلم فجر نوشت: سکوت در برابر اسناد فساد و حمله به سخنان یک خانم در جشنواره فیلم دو روی یک سکه است. ولی ای کاش آقایان در کنار این همه اعترض، یک مقاله کوتاه در نقد فقهی آن سخن هم بنویسند تا همه بدانند کجای سخن وی ایراد فقهی دارد؟ دیر نشده یک هفته هم می توان صبر کرد. 

منظورش فکر کنم فساد در جمهوری اسلامی است ، اینقدر زیاد است که در برابر  سخن این خانم یک سوزن در انباری از کاه است .

به احتیاط واجب صیغه عقد باید به عربی صحیح خوانده شود. و اگر خود مرد و زن نتوانند صیغه را به عربی صحیح بخوانند به هر لفظی که صیغه را بخوانند صحیح است، و لازم هم نیست که وکیل بگیرند اما باید لفظی بگویند که معنای “زوّجت” و “قبلت” را بفهماند.

در این اطلاعیه آمده‌است: ساعت ۳ و ۲۷ دقیقه بامداد یک شنبه اول اسفند ماه  ۱۴۰۰ ، راننده یک دستگاه خودروی تریلی که دچار ناراحتی روحی شده بود، اقدام به شکستن درب ۶ مسجد مقدس جمکران کرد و قصد ورود به صحن جامع مهدوی را داشت که ماشین وی متوقف و از حرکت باز ماند.

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

گفتنی است این حادثه خسارت خاصی به همراه نداشت و نیروهای امنیتی در حال بررسی چرایی این اقدام راننده هستند

کلیک نکن! لطفا بر روی لینک‌های ارسالی در پیامک‌های باشماره شخصی و با عنوان سامانه ثنا هرگز کلیک نکنید.

دهه اول اسفند 1400 : رئیس جمهوری فرانسه، روز جمعه با اشاره به گفت‌وگوهای پیشین با همتای روس خود پیش از حمله به اوکراین، گفت: ولادیمیر پوتین همزمان با اینکه پشت تلفن، جزئیات توافقات مینسک را با من بررسی می‌کرده، در حال آماده شدن برای آغاز جنگ بوده است؛ این فریبکاری و نارو زدن است.

به گزارش ایسنا به نقل از گاردین، امانوئل ماکرون، رئیس جمهوری فرانسه پس از نشست اتحادیه اروپا گفت: بله، دورویی اتفاق افتاد؛ انتخابی آگاهانه و عمدی برای آغاز جنگ صورت گرفت، آن هم در زمانی که هنوز می‌توانستیم بر سر صلح مذاکره کنیم.

ماکرون تاکید کرد که فرانسه تحریم‌های مجزای خود را به بسته تحریمی اتحادیه اروپا علیه روسیه اضافه می‌کند.

رئیس دولت اوکراین ( زلنسکی ) گفت: امروز از مسکو شنیدیم که روسیه در نهایت می‌خواهد گفت‌وگو کند. کرملین می‌خواهد درباره وضعیت بی‌طرف اوکراین صحبت کند. به شرکای اوکراین می‌گویم که سرنوشت کشورمان همین حالا در حال تعیین شدن است. من از آن‌ها (متحدان غربی اوکراین) می‌پرسم که آیا در کنار ما هستند یا خیر و پاسخ آن‌ها مثبت است؛ اما هنوز آماده پذیرش ما در این اتحاد (ناتو) نیستند.

۶ اسفند 1400 : عضو شورای مرکزی موتلفه:خانواده‌های ولایی باید با لبیک به رهبری و فرزند آوری، دشمن را ناامید کنند

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

 پوتین  : 

کیهان : وقتی هیتلر به روسیه لشکر کشید، بخشی از اوکراینی‌ها با ارتش نازی همدست شدند و تعداد زیادی از هموطنان خود را به طرز فجیعی کشتند. وقتی ورق جنگ جهانی دوم برگشت، این بار نوبت طرف مقابل بود که دست به انتقام و کشتار بزند. منظور کیهان اینه که همبستگی قومیتی چه سُنی و چه شیعه در ایران حفظ نشود بساط ایران هم همین است ، البته کیهان فراموش کرده مسلمان معتقد مخصوصا ایرانی ها را با هیچ مسلمانی در کشورهای دیگر نمی توان مقایسه کرد.

تصویر ماهواره ای تخریب پل مرزی بین اوکراین و بلاروس توسط خود اوکراینی ها ۸ اسفند ۱۴۰۰ 

9 اسفند 1400 : 

صفحه رسمی ‏گارد ملی اوکراین فیلمی منتشر کرده که عضو آن در حال آغشته کردن گلوله‌هایش به چربی خوک است تا هنگام شلیک به سربازان مسلمان چچنی به آنها آسیب معنوی برساند. منبع: خبرفوری

دختر مدل اوکراینی اسلحه بدست در جنگ با پوتین 

مارتین فورد و خانواده : 

10 اسفند 1400 درگذشت زهره فکور صبور در ۴۳ سالگی : 

ادعای سفارت روسیه مبنی بر همراهی ایرانیان با جنگی که روسیه به راه انداخته ...

سریال «نرگس» به تهیه کنندگی مهران مهام در سال ۱۳۸۵ پخش شد،نقش اصلی این سریال را پوپک گلدره بازی می‌کرد که در اواسط بازی، بر اثر تصادف با اتومبیل به کما رفته و پس از ۸ ماه درگذشت. نقش او را ستاره اسکندری ادامه داد.

«بی همگان» اخرین هنرنمایی زهره فکور را ثبت خواهد کرد.

نمایش رکوردهای انتخاب شده ی فرم در MsgBox یا جعبه پیام ویندوزی

استفاده از آبجکت RecordSetClone و لوپ در رکوردست 

در لینک زیر داکیومنت را مطالعه نمائید و در آخر مثالی در پیمایش در رکوردها داده شده 

office/vba/api/access.form.recordsetclone

تهیه یک کپی از رکوردهای فرم هایی که تحت جدول یا کوئری هستند و باز کردن در رکوردست برای پیمایش و دستکاری داده ( Manipulate ) یا پیدا کردن ( Find ) داده  خاص در آن 

.Bof

.Eof

.FindFirst

.NotMatch

.Edit Or .Add 

.Update

اگر از Edit برای ویرایش داده فیلدی استفاده کنید اگر رکوردست خالی  باشد  با ارور No Current Record  مواجه خواهید شد در نتیجه باید از روش Add استفاده بنمائید.

پیام WM_NEXTDLGCTL برای تنظیم فوکس کیبورد به کنترل دیگر

تمام مطالب زیر از سایت خارجی استخراج شده  بخوانید و لذت ببرید. داکیومنت یا رفرنس نیز با لینک قید گردیده.

wm-nextdlgctl

Sent to a dialog box procedure to set the keyboard focus to a different control in the dialog box.

ارسال به دیالوگ باکس برای تنظیم ( یا تغییر ؟ ) فوکس کیبورد به کنترل دیگر در این باکس

The low-order word indicates how the system uses wParam. If the low-order word is TRUE, wParam is a handle associated with the control that receives the focus

low-order نشان میدهد که چگونه سیستم از wParam استفاده می نماید . اگر True باشد ( lParam ) ، در نتیجه wParam هندلی است در ارتباط با کنترلی که فوکس را دریافت می نماید .

wParam : GetDlgItem(hwnd/wParm,IDCtrl)

lParam=True Or >0

DM_GETDEFID :  '&H400

Retrieves the identifier of the default push button control for a dialog box.

getkeystate

syslink-control-styles

win32/url-control

Virtual-Key Codes

VK_TAB =&h9

SubClassEditControl :

Select Case Umsg 

Case 8  'WM_KILLFOCUS

'1000 is Id Of SysLink Control

'Set KeyBoard Focus To SysLink (ID:1000 )

 PostMessage hwndParent, &H28, GetDlgItem(hwndParent, 1000), 1

Or Using "SetFocus GetDlgItem(hwndParent, 1000)"

INT_PTR CALLBACK TabBackwardSubclassProc(
    HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam,
    UINT_PTR subclassId, DWORD_PTR)
{
  switch (message) {
  case WM_NCDESTROY:
    RemoveWindowSubclass(hwnd, TabBackwardSubclassProc,
                         subclassId);
    break;
  case WM_GETDLGCODE:
    return DefSubclassProc(hwnd, message, wParam, lParam) |
           DLGC_WANTTAB;

  case WM_KEYDOWN:
      HWND hdlg = GetParent(hwnd);
    if (wParam == VK_TAB) {
      if (GetKeyState(VK_SHIFT) < 0) {
        HWND tabDestination = GetDlgItem(hdlg,
        // Tabbing backward - go to the Customer ID.
                                         IDC_CUSTOMERID);
        // Do the normal tabbing thing.
        SendMessage(hdlg, WM_NEXTDLGCTL,
                    (WPARAM)tabDestination, TRUE);
      } else {
      if (wParam == VK_TAB) return 0;
        SendMessage(hdlg, WM_NEXTDLGCTL, FALSE, FALSE);
      }
      return 0;
    }
    }
    break;
    case WM_CHAR:
      break;
    return DefSubclassProc(hwnd, message, wParam, lParam);
}

    If lCode = HCBT_ACTIVATE Then
        If IsMsgBox(wParam) Then
            Call UnhookWindowsHookEx(hHook): hHook = 0
            hStatic = GetDlgItem(wParam, IDPROMPT)
            If InStr(1, sStoredPrompt, sStoredHypText, vbTextCompare) Then
                hFont = SendMessage(hStatic, WM_GETFONT, 0, 0)
                With tStaticRect
                    Call GetWindowRect(hStatic, tStaticRect)
                    p1.X = .Left: p1.Y = .Top
                    Call ScreenToClient(wParam, p1)
                    Call DestroyWindow(hStatic)
                    Call MoveWindow(hSysLink, p1.X, p1.Y, .Right - .Left, .Bottom - .Top, 1)
                    Call SendMessage(hSysLink, WM_SETFONT, hFont, True)
                End With
                Call SendMessage(wParam, WM_NEXTDLGCTL, GetDlgItem(wParam, loword(CLng(SendMessage(wParam, DM_GETDEFID, 0, 0)))), True)
            End If
        End If
    End If

WM_NCCALCSIZE

Figured it out, WM_NCCALCSIZE is sent before the edit control is subclassed.

So i had to superclass the EDIT class.

EDIT:

Another solution I just thought of would be to subclass it, then call SetWindowPos with SWP_FRAMECHANGED, this causes it to send the WM_NCCALCSIZE message.

      ncc1.rgrc(0) is the new rectangle
    ncc1.rgrc(1) is the old rectangle
    ncc1.rgrc(2) is the client rectangle

Width : ncc1.ncc1.lppos.x   , Height : ncc1.lppos.y

W=Left-Right

W=349-9=340 

Dim rrr As RECT

 CopyMemory rrr, ByVal lParam, LenB(rrr)

SetWindowtext  : rrr.Right

WS_EX_CLIENTEDEGE

2 Pixle Wide 'test

to draw on the parent DC, WS_CLIPCHILDREN must be off
        HWND h

NonClientArea

ToolbarWindow32

The window class name for a toolbar control is TOOLBARCLASSNAME, which is defined as "ToolbarWindow32" in Commctrl.h.

CreateWindowEx creates an empty toolbar that you fill by sending a TB_ADDBUTTONS message, specifying the address of a TBBUTTON structure.

If you use the CreateWindowEx function to create a toolbar, you must send the TB_BUTTONSTRUCTSIZE message before adding any buttons. The message passes the size of the TBBUTTON structure to the toolbar.

Create ToolBar

WM_NCHITTEST در ساب کلاس EDIT Control

تمام موارد کپی شده از داکیومنتِ موجود است  تست شده همراه با تصویر ، ثابت ها نیز از داکیومنت استخراج و قابل مشاهده برای عموم است. لینک ها شما را به مطلب داکیومنت هدایت خواهند نمود.

if the return value of the message response function of WM_NCHITTEST is HTCLIENT, indicating that the mouse clicked on the client area, Windows will send a WM_LBUTTONDOWN message to the window; if the return value of the message response function of WM_NCHITTEST is not HTCLIENT (may be HTCAPTION, HTCLOSE,

HTMAXBUTTON) Etc.), that is, when the mouse clicks on the non-client area, Windows will send a WM_NCLBUTTONDOWN message to the window.

اگر مقدار برگشتی پاسخ پیام تابع، HTCLIENT باشد، نشان می دهد که ماوس روی ناحیه Client کلیک شده . ویندوز یک پیام WM_NCLBUTTONDOWN به پنجره خواهد فرستاد اگر مقدار جواب پیام برگشتی HTCLIENT نباشد ممکن است HTCAPTION یا HTCLOSE و یا حتی HTMAXBUTTON باشد .یعنی زمان کلیک در منطقه خارج از Client ( هر پنجره ای می تواند خود باتن باشد یا کنترل ویرایش یا  دیالوگ باکس ) ویندوز یک پیام WM_NCLBUTTONDOWN به پنجره ارسال می نماید.

تصویر بالا وقتی ماوس داخل کنترل ویرایش است ( Client ) در Caption یا TitleBar عدد یک و وقتی روی بوردر است عدد 18 را مشاهده می نمائید ثابت ها در پائین ذکر شده .

Case 132 ' WM_NCHITTEST
ff = CallWindowProc(HookInputBoxprev, hWnd, uMsg, wParam, lParam)
SetWindowTextA GetParent(hWnd), ff

HTBORDER=18   '<<<<<<

HTBOTTOM=15

HTBOTTOMLEFT=16

HTBOTTOMRIGHT=17

HTCAPTION=2

HTCLIENT=1  ' <<<<<

HTCLOSE=20

HTERROR=-2

HTGROWBOX=4

HTHELP=21

HTHSCROLL=6

HTLEFT=10

HTMENU=5

HTMAXBUTTON=9

HTMINBUTTON=8

HTNOWHERE=0

HTREDUCE=8

HTRIGHT=11

HTSIZE=4

HTSYSMENU=3

HTTOP=12

HTTOPLEFT=13

HTTOPRIGHT=14

HTTRANSPARENT=-1

HTVSCROLL=7

HTZOOM=9

How to Get Border Of NonClientArea

1. Call GetClientRect() to get the size of the client area.
2. Call ClientToScreen() to transform client rect to screen coordinates.
3. Call GetWindowRect() to get the rectangle of the control including NC area, in screen coordinates.
4. Calculate difference between client rect and window rect coordinates to get size of border (e. g. leftBorderWidth = clientRect.left - windowRect.left).

how-to-set-the-size-of-the-non-client-area-of-a-win32-window-native

win32/gdi/nonclient-area

CoorDinate     ..... PtInRect

در بالا مختصات x و y با پیام WM_MOUSEMOVE و پارامتر lParam و استفاده از loword و hiword آن در Caption ذکر شده برای گرفتن Right مستطیل کنترل ویرایش از تابع GetClientRect استفاده شده.

Case WM_MOUSEMOVE
         GetClientRect GetDlgItem(hwnd, 1000), r1
         GetCursorPos tt
         ScreenToClient hwnd, tt
         mm.x = CLng(lParam And &HFFFF&)  'LoWord(lParam
         mm.y = CLng(lParam \ &HFFFF&)  'HiWord(lParam
        SetWindowTextA hwnd, "Coordinate :(" & mm.x & "," & mm.y & ")" & " &RectR:" & r1.Right & " &tt_X_Y(" & tt.x & "," & tt.y & ")"
           'r1.Left = 0: r1.Right = 30: r1.Top = 0: r1.Bottom = 50
           If PtInRect(r1, mm.x, mm.y) Then
            'SetWindowTextA GetDlgItem(hwnd, 1), "In"
           ElseIf Not PtInRect(r1, mm.x, mm.y) Then
            'SetWindowTextA GetDlgItem(hwnd, 1), "Out"
           End If

در تصویر پائین Right را 1263 زده چون از تابع GetWindowRect کنترل ویرایش با آیدی 4900 استفاده شده . در ضمن اگر ماوس در مختصات خاصی که که مستطیل را تعریف کردیم ( با left و top و right و bottom ) باشد در باتن Ok با آیدی 1 رشته In و اگر خارج باشد رشته Out جایگزین تکست پنجره باتن میشود.( استفاده از تابع PtInRect )

if Points moved inside the edit 's rectangle we specified  in the above code  , the window text of "Ok" button will  be changed to "In" , Otherwise "Out"

Byval StrPtr

"1604;1591;1601;1575;32;1601;1602;1591;32;1608;1575;1585;1583;32;1705;1606;1740;1583"

The InflateRect function increases or decreases the width and height of the specified rectangle. The InflateRect function adds -dx units to the left end and dx to the right end of the rectangle and -dy units to the top and dy to the bottom. The dx and dy parameters are signed values; positive values increase the width and height, and negative values decrease them.

تابع InflateRect عرض و ارتفاع مستطیل ( Rectangle )  را افزایش یا کاهش می دهد . این تابع dx- واحد به چپ و dx واحد به انتهای راست مستطیل و dy- به بالا و dy به پائین اضافه می نماید.پارامترهای dx و dy مقادیر علامت دار هستند .مقادیر مثبت عرض و ارتقاع را افزایش می دهند و مقادیر منفی آنها را کاهش می دهند.

Dim Mpos As POINTAPI
'Retrieves the position of the mouse cursor, in screen coordinates.
 Retval = GetCursorPos(MPos) 
'Retrieves a handle to the window that contains the specified point.
hWnd = WindowFromPoint(MPos.x, MPos.y)
'A handle to the window to be tested.
 If CBool(IsWindow(hWnd)) = False Then
    Label1.Caption = ""
    Exit Sub
  End If
' Determines whether a window is maximized
  IsMaximized = IsZoomed(hWnd)
'Determines whether the specified window is minimized (iconic).
  IsMinimized = IsIconic(hWnd)
'Retrieves a handle to the specified window's parent or owner.
  ParentWnd = GetParent(hWnd)

 

29 بهمن 1400 : در پی اهانت یک افسر هندی به سردار سلیمانی و رهبر انقلاب،  مردم منطقه بدگام کشمیر به خیابان‌ها ریختند و در حمایت از سردار سلیمانی شعار سردادند و با ماموران پلیس درگیر شدند و اقدام مامور هتاک را محکوم کردند. یکی از افسران هندی در حین عملیات سرشماری یکی از شهرهای کشمیر با ورود به منزل یکی از شهروندان عکس شهید سلیمانی و رهبرانقلاب را که در خانه او بود به آتش می‌کشد. 

هشدار مهم پلیس فتا

بهمن 1400 : 

هشدار مهم: هر پیام حاوی لینک از شماره شخصی با مضمون شکایت علیه شما جعلی و به قصد خالی کردن حساب شماست. لطفا کلیک نکنید.

از صحت درگاه ها حتما اطمینان حاصل کنید و ترجیحا از کارتی استفاده کنید که مبلغ پول خیلی کمی در آن دارید

هشدار: سامانه ثنا از شماره شخصی پیامک ارسال نمی‌کند، به هیچ وجه روی لینک‌های ارسالی کلیک نکنید، بدانید که: کلیک=خالی شدن حساب

در نشست خبری فیلم سینمایی «نمور» که در در واپسین روز چهلمین جشنواره فیلم فجر برگزار شد، یکی‌از خبرنگاران حاضر در نشست از نوشین معراجی نویسنده فیلم «نمور» پرسید: باتوجه به حلال‌زاده نبودن یکی از شخصیت‌های فیلم، چرا این اثر به مقام مادر تقدیم شده است؟ و معراجی در پاسخ گفت: «وقتی دو نفر همدیگر را دوست دارند، عشقی که بین‌شان وجود داشته، آن قدر حرمت دارد که به‌نظر من بچه‌ای که از آن‌ها به دنیا می‌آید حلال‌زاده است! »

عیدی دولت و حکومت در تولید ملی  : بهمن 1400

مبلغ وام فرزندآوری به ازای فرزند اول ۲۰ میلیون تومان، به ازای فرزند دوم ۴۰ میلیون تومان، به ازای فرزند سوم ۶۰ میلیون تومان، به ازای فرزند چهارم ۸۰ میلیون تومان و به ازای فرزند پنجم و بیشتر  از آن، ۱۰۰ میلیون تومان است.

فرمانده سپاه ثارالله استان کرمان با اشاره به اینکه ترویج مکتب شهید سلیمانی مصونیت آور است و برای جامعه وحدت ایجاد می‌کند گفت: مدیر اسلامی باید در بین مردم حضور داشته باشد و به مردم نوکری کند و مدیری که به‌دنبال آقایی کردن باشد ( روحانی نعوذ بالله) به درد حکومت اسلامی نمی‌خورد.

حجت الاسلام مسعود عالی استاد حوزه در اظهاراتی از نوشین معراجی، فیلمنامه‌نویس «نمور» در پی مواضع اخیرش در خصوص روابط زن و مرد به شدت انتقاد کرد و گفت: آن خانم داوری که در جشنواره حرف ازدواج سفید را زد، مسئولین ارشاد تو دهنش باید می‌زدند. تو غلط میکنی ...

مراسم ازدواج نازنین جعفریان مدل ایرانی الاصل پر زرق و برق ترین مراسمی بود که با ثروتمندترین سیاه پوست برگزار کرد.

نازنین جعفریان، فارغ ­التحصیل رشته مهندسی زیست ­پزشکی از دانشگاه منچستر که به­ عنوان مدل و نیز مشاور بازاریابی مشغول به فعالیت است، مراسم عروسی خود را با آقای فولارین الاکیا، کارآفرین، سرمایه ­گذار و فیلمبردار نیجریه ای برگزار کرد. ( .... جالبه مادر داماد یکی از چند سرمایه دار نفتیه تو دنیا کشور ما کجا اونا  کجا ما هم سیدعلی سرمایمونه) 

سه مدیر دولتی که قبلا به عنوان متهم در پرونده اتوبوس خبرنگاران معرفی شده بودند، از سوی بازپرس ارومیه تبرئه شدند.

سید علی خشگمین می شود ، 28 بهمن 1400 : رهبر معظم انقلاب فرمودند: امروز نوبت سپاه است که ، به سپاه تهمت بزنند و لجن‌پراکنی کنند و در ضمن به شهید بزرگ شهید سلیمانی، و اگر جرات می کردند و از خشم مردم نمی‌ترسیدند به امام هم اهانت می‌کردند.

حمید حسینی، عضو اتاق بازرگانی: مدیران برخی شرکت هایی که کار مهاجرت انجام می‌دهند، شخصا به من اعلام کردند که قبلا هفته ای سی تا چهل درخواست برای مهاجرت داشتند که از سوی افرادی با تخصص های بالا و درس خوانده ارائه می شد اما در شرایط فعلی تعداد این درخواست برای این شرکت‌های معمولی به ۱۸۰ درخواست رسیده است که نشان از افزایش میل به مهاجرت در ایران دارد.جالب است در میان متقاضیان مهاجرت از لوله کش تا کابینت‌ساز و آشپز و برق کار و آرایشگر و ... نیز دیده می شوند،این یعنی اگر تا دیروز فقط درس خوانده‌ها می خواستند از ایران بروند، امروز صاحبان حرف و افرادی که حرفه‌ای را بلدند نیز متقاضی مهاجرت هستند و این نشانه‌های باید سیاستگذار را نگران کند.

روح الامینی، نماینده مجلس گفت: قبلا توقع‌ها کمتر بود؛ مردم از سرویس‌های بهداشتی مشترک استفاده میکردند. الان همه به دنبال تجهیزات و وسایل مستقل هستند. توقع‌ها باید تنظیم شود.

لطفا توقعتان را به تنظیمات کارخانه بازگردانید مصرف آب و برق و گاز را خیلی کم کنید تا بتوانند از تحریم ها عبور نمایند و به یکسری کشورهای تحت حمله رژیم شیطانی کمک بنمایند.

رستم قاسمی : به خانوارهایی که سه تا چهار فرزند داشته باشند، زمین مجانی برای ساخت مسکن داده می‌شود.

البته رستم خان قاسمی فکر نکرده که قشر کارگر حقوق بگیر ۵ میلیونی با ۳ تا ۵ فرزند چطوری و با کدام درآمد می تواند هزینه  ساخت و ساز را فراهم نماید.

تصویر زیر گویای این است که نگران نباشید ، همیشه ، حتی در سختی ها لبخند بزنید تا همه چیز درست شود چون بنیان درست است.

 کوبا توانست با استفاده از ظرفیت پزشکان، خود را از تحریم‌ها نجات دهد و در عملیاتی با نام معجزه، پزشکان خود را به کشورهای آمریکایی و همجوار فرستاد تا بتواند مانع بروز بیماری در آن مناطق شود، از این طریق خود را از حصار تحریم نجات داد.

همسران بخوانند ( تجسس در گوشی ) 

► حضرت آیت الله العظمی شبیری زنجانی:

• تنها با دلیل محکم خوف از معصیت جایز است.

► حضرت آیت الله العظمی خامنه ای:

• بدون اذن و رضایت ایشان جایز نیست.

► آیت الله العظمی مکارم شیرازی:

• تجسس در گوشی دیگران حرام است.

سجاد غریبی ۲۹ ساله، ملقب به هالک ایرانی به حریف انگلیسی خود، مارتین فورد که به ترسناک‌ترین مرد جهان معروف است، هشدار دارد که مبارزه را روی برانکارد ترک خواهد کرد.

4001127100

مدیر کل خیلی جوان !!!

29 بهمن 1400 : در پی اهانت یک افسر هندی به سردار سلیمانی و رهبر انقلاب،  مردم منطقه بدگام کشمیر به خیابان‌ها ریختند و در حمایت از سردار سلیمانی شعار سردادند و با ماموران پلیس درگیر شدند و اقدام مامور هتاک را محکوم کردند. یکی از افسران هندی در حین عملیات سرشماری یکی از شهرهای کشمیر با ورود به منزل یکی از شهروندان عکس شهید سلیمانی و رهبرانقلاب را که در خانه او بود به آتش می‌کشد. 

۲۸ بهمن ۱۴۰۰ گفتگو با رفیق دوست : ( هویدا ) گفت من هنوز هم بر عقیده خودم هستم! جنگی بین ما و شما بود و شما بردید و ما را هم می‌کشید! آن وقت که این چهار نفر را برای اعدام می‌بردند، او باز سر موضعش بود! وقتی می‌خواست از پله‌ها بالا برود، گفت دست‌ها و چشم‌های مرا نبندید و همان طور هم اعدام شد. بقیه را از زیر بغل‌هایشان می‌کشیدند و می‌بردند! یادم است که خسروداد، آنچنان می‌لرزید که زانوهایش به هم می‌خورد! خسرودادی که معروف بود از دیوار راست بالا می‌رود و از ارتفاع ۱۰ متری می‌پرد، آنچنان خودش را باخته بود که حساب نداشت!...».

حرف های ضد و نقیض و گفته زیر در سایتی دیگر : کشته شد اعدام نشد

دست‌کم بر اساس گزارش روزنامه‌های وقت از جمله آیندگان می‌دانیم که جلسه دادگاه تا ساعت ۶ و نیم به طول انجامید و باز گزارش همین روزنامه می‌گوید که هویدا در ساعت ۷ و ۲۵ دقیقه هدف گلوله قرار گرفت. یعنی چیزی حدود یک ساعت از اتمام جلسه دادگاه تا تیر خوردن او فاصله بوده است. پس احتمال قریب به یقین او را به سلولش منتقل کرده بودند و شلیک گلوله از جانب خلخالی یا شخص دیگری در زمانی اتفاق افتاده که او در سلولش به سر می‌برده و نه هنگامی که در حال انتقال به سلول بوده است.

یا ممکن است از سوی ضدانقلاب بوده باشد عمال رجوی چون اوایل انقلاب مملکت حساب و کتاب و قانون درستی نداشته .

هندی‌ها بار دیگر توقیف کشتی‌ها و محموله هایی که از مبدا یا به مقصد ایران هستند، از سر گرفته‌اند.

طبق اعلام یک منبع آگاه به ایلنا ، کشتی «کابل» متعلق به شرکت ادمیرال با مالکیت «برادران شمخانی» به بهانه نقص مدارک از تقریبا ١٠ روز پیش همراه با تمام باری که در حال حمل آن بوده، به حکم یک دادگاه هندی در بندر کاندلا توقیف شده‌ است. 

رادیو پس فردا : بهمن 1400 - یکی از مسئولان سازمان بنادر و دریانوردی در همین زمینه به ایلنا گفته است از آنجایی که این کشتی با پرچم ایران در حال تردد نیست، بنابراین سازمان بنادر و دریانوردی امکان ورود به این موضوع را ندارد.

او توضیح نداده است که کشتی «کابل» با پرچم چه کشوری در حال تردد بوده، اما داده‌های «مرین ترفیک» نشان می‌دهد که این کشتی ایرانی با پرچم جمهوری لیبریا، از کشورهای آفریقای غربی، در حال تردد بوده است.

در این اطلاعیه آمده‌است: ساعت ۳ و ۲۷ دقیقه بامداد یک شنبه اول اسفند ماه راننده یک دستگاه خودروی تریلی که دچار ناراحتی روحی شده بود، اقدام به شکستن درب ۶ مسجد مقدس جمکران کرد و قصد ورود به صحن جامع مهدوی را داشت که ماشین وی متوقف و از حرکت باز ماند.

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

گفتنی است این حادثه خسارت خاصی به همراه نداشت و نیروهای امنیتی در حال بررسی چرایی این اقدام راننده هستند

6 اسفند 1400 : عضو شورای مرکزی موتلفه:خانواده‌های ولایی باید با لبیک به رهبری و فرزند آوری، دشمن را ناامید کنند

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

9 اسفند 1400 : 

نماینده دوآتشه حامی طرح صیانت در توئیتی منتقدان و مخالفان این طرح را گرگ‌های مجازی و سگ‌های قلاده بلند خطاب کرد.

در ۲۱:۵۶ سه شنبه ۱۰ اسفند ۱۴۰۰

[;database;path;pwd].[tbl]

استخراج داده جدول از صفحات وب در اکسس

ماده 4 ـ ( بنیاد تعاون سپاه 1372 )

سرمایه اولیه بنیاد در تاریخ تأسیس ده میلیون ریال می باشد که از طرف مقام معظم رهبری و فرماندهی کل قوا اهداء گردیده است.

چنانچه مطلب مفید بود لطفا در نظرسنجی شرکت نمائید.

مطلب زیر استخراج داده های جدول موجود در سایت www.tuttitalia.it/regioni  است داخل فایل تکست 

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

تماما کتابخانه ها در منو آیتم Refrences محیط VBE  موجود است اگر با آنها راحتید تیک بزنید مثل Microsoft Html Object Library ... با متد Refrences.Add هم می توانید تیک بزنید در رفرنس پراپرتی Count فقط تیک خورده ها را می شمرد!!!

https://docs.microsoft.com

https://docs.microsoft.com

msxml/list-of-xml-parser-versions

winhttp-functions

Set xmlReq = CreateObject("MSXML2.XMLHTTP")
xmlReq.Open  Get,uRl,0
xmlReq.Send

OBJECT : "HtmlFile"

For Each ele In objIE.document.getElementById("myTable").getElementsByTagName("tr")

        'show the text content of 'tr' element being looked at

        Debug.Print ele.textContent

        'each 'tr' (table row) element contains 4 children ('td') elements

        'put text of 1st 'td' in col A

        Sheets("Sheet1").Range("A" & y).Value = ele.Children(0).textContent

        'put text of 2nd 'td' in col B

        Sheets("Sheet1").Range("B" & y).Value = ele.Children(1).textContent

        'put text of 3rd 'td' in col C

        Sheets("Sheet1").Range("C" & y).Value = ele.Children(2).textContent

        'put text of 4th 'td' in col D

        Sheets("Sheet1").Range("D" & y).Value = ele.Children(3).textContent

        'increment row counter by 1

        y = y + 1

    'repeat until last ele has been evaluated

    Next

uRl: https://www.tuttitalia.it/regioni/      استخراج لینک ها

hDoc.body.innerHTML = xmlReq.responsetext

Set hEle = hDoc.body.getElementsByTagName("a")

Open "d:\ExtractLink.txt" For Output As #1

For Each h In hEle

If h.href Like "*https*" Then

Write #1, h.href, h.innertext

End If

Next

Close #1

در تصویر  زیر،  طبق کدهای بالا  ،  تکست های تگ a که داخلشون http بود به فایل تکست با نام ExtractLink ارسال شده.

Me.Text1 = hDoc.body.innertext

Dim mtbl As Object, table_data As Object

Set mtbl = hDoc.body.getElementsByTagName("Table")(0)

Set tblHeader = mtbl.getElementsByTagName("th")

Set tblRows = mtbl.getElementsByTagName("tr")  ' TAble Data

در جدول با ایندکس صفر چون Header حاوی اسکی کد اضافه بود اون رو با Replace حذف کردیم که زیر هم چاپ نشوند چون در حالت عادی از vbrclf استفاده شده بود که در استخراج تکست های هدر زیر هم چاپ میشد.

For Each h In tblHeader
ss = ss & IIf(ss = "", "Row", ";") & Replace(h.innerText, Chr(10), "")
Next
Me.Text1 = ss

تصویر زیر تکست های مربوط به هدر است البته عرض کردم یک کاراکتر اضافی دارن که باعث میشه زیر هم بیان با تابع Replace اون اسکی کد اضافی رو حذف کردیم.ستون اول Blank هست گفتیم بجاش کلمه Row جایگزین بشه در تصویر ملاحظه می کنید.

برای گرفتن تعداد ردیف ها و ستون ها در جدولی که در صفحه وب است از ویژگی length استفاده کنید.Zero Base و از صفر شروع میشود فقط اعدا صحیح

RowsCount = tblRows.length - 1     ' 21 

  6'   ColsCount = tblHeader.length - 1

در تصویر زیر داده های جدول با ایندکس صف ر در فایل تکست Print شده .  از Print Statement استفاده کنید بجای Write که کوتیشن اول و آخر تکست هاتون در هر ردیف نزنه... در کدها البته گفت شده اگر تکست هر ردیف از ستون خاص یا مربوطه Numeric نبود بین تکست استخراجی یک تک کوتیشن بزنه ... در تصویر مشاهده بنمائید.( در تصویر رشته غیر عددی بین دو تک کوتیشن قرار گرفته )

البته جلوی ردیف ها نقطه وجود دارد که می توان گفت اگر آخر رشته  نقطه بود برداشته شود .

txt="1."

t=Replace(Right$(txt,1),".","")

بخاطر اینکه از دستور Insert Into زبان Sql دیتابیس اکسس برای استخراج فایل تکست به داخل جدول اکسس قراره استفاده کنم می بایست عبارات غیر عددی یا تکست ، داخل تک کوتیشن قرار گیرد وگرنه ارور می دهد در نتیجه بهتر است برای جلوگیری از خطا تکست ها داخل تک کوتیشن قرار گیرد 

strSql=insert into Tbl1 (Fld1,,,Fldn) Values(val1,'txt1',,,,valn,'txtn')=

Docmd.RunSql   ' استفاده از متد 

پِراپِرتی  رکوردز اَفِکتِدِ کارِنت دی بی  

Dim fileStream As Object
Set fileStream = CreateObject("ADODB.Stream")
With fileStream
.Open
.Type = 2 'Text
.Charset = "utf-8"

.WroteText strtext,1

.SaveToFile "d:\dddddddd.txt",2

.Close

End With

این آبجکت متد LoadFromFile نیز دارد.فرضا دانلود تصویر از سایت  یا شئ رکودست 

Hex$(AscW(Mid(txt, i, 1)))

Set tbl = hdoc.getElementsByTagName("table")(0)

Set  tRows = tbl.getElementsByTagName("tr")

Debug.Print  tRows.length  '8 

تصویر زیر استخراج جدولی از سایت بانک مسکن است.برای اینکه حروف فارسی در فایل تکست کاراکتر نامعلوم یا ? نشود از آبجکت ADO STREAM استفاده شد و Charset به utf-8  تنظیم گردید. برای ارسال فایل تکست به جدول اکسس از تب External Data و گروه Import استفاده نمودیم. بین تکست ها در ارسال به فایل تکست از یک Delimiter یا  جدا کننده مثل سمی کالن  ( ; ) استفاده شد ( در تصویر زیر در تصویر notepad می توانید مشاهده نمائید ) که در مراحل import در قسمت مربوطه جداکننده اعلان شود تا هر کدام در فیلد جداگانه ثبت گردد. بدون دسترسی به کتابخانه ها یا فایل های tlb و dll هیچ کدام از مراحل زیر یا قابل انجام نیست یا به تخصص خیلی بالایی نیاز است.

CreateObject("MSXML2.XMLHTTP") 

'GET,WebFile,False

'oResp() As Byte = oXMLHTTP.responseBody 
     
    vFF = FreeFile 
    If Dir(vLocalFile) <> "" Then 
        Kill vLocalFile 
    End If 
    Open vLocalFile For Binary As #vFF 
    Put #vFF, , oResp 
    Close #vFF 

Set TagLink=hDoc.getelementsByTagName("link")

For Each Links in TagLink

Debug.Print Links.href  

Next

می توانید از Refrences محیط VBE  ، فایل های microsoft html object  و microsoft xml را تیک بزنید و استفاده کنید بجای ساختن Object 

Dim URL As String = "http://www.footballlocks.com/nfl_odds.shtml"
        Dim XMLHttp As MSXML2.XMLHTTP
        Dim HTMLDoc As HTMLDocument
        Dim table As HTMLTable
        Dim tableRow As HTMLTableRow
        Dim tableCell As HTMLTableCell

        XMLHttp = New MSXML2.XMLHTTP
        XMLHttp.open("GET", URL, False)
        XMLHttp.send()
        HTMLDoc = New HTMLDocument
HTMLDoc.body.innerHTML = XMLHttp.responseText
        table = HTMLDoc.getElementsByTagName("TABLE")(39)
        For Each tableRow In table.rows
            For Each tableCell In tableRow.cells
                Console.WriteLine(tableCell.innerText)
            Next
        Next

سوراخ‌کاری بدن یا پیرسینگ ( Piercing ) یا آژین‌کاری شامل سوراخ کردن یا بریدن قسمتی از اعضای بدن است که برای نصب جواهرات یا انداختن حلقه و آویز ایجاد می‌شود.

25 بهمن 1400 : ( فایل صوتی ) برخورد سپاه با شرکت یاس که قرار بود منابع مالی جنگ با داعش را تامین نماید و تامین هم ننمود : 

شرکت یاس چه بود و برای چه ایجاد شد؟

شرکت یاس در بحبوحه درگیری میدانی نیروی قدس سپاه با داعش و تروریستهای تکفیری و در شرایطی که دولت وقت حاضر به پشتیبانی از رزمندگان در میدان نبود، تاسیس شد. ( احتمال خیلی کم منظورش روحانی بوده استغفر...(

این شرکت قرار بود از طریق اجرای پروژه‌های عمرانی منابع مالی لازم را برای پشتیبانی از جبهه مقاومت تامین کند.

با این حال شرکت یاس نتوانست به طور کامل در اهداف اقتصادی خود موفق شود و از طرفی چون بیرون از ساختار سپاه و شهرداری ایجاد شده بود سیستمهای نظارتی این دو نهاد نتوانسته بودند نظارت موثری را در حین فعالیت این شرکت داشته باشند.

اما با مشکوک شدن فرماندهان سپاه به نحوه عملکرد شرکت، مجموعه نظارتی سپاه به موضوع ورود کرده و متوجه تخلف افرادی به نام محمود سجادی نیا (سیف) و عیسی شریفی می‌شوند و بلافاصله ضمن منحل کردن این شرکت، متخلفان را به دادگاه نظامی معرفی می‌کنند. محمود سیف و عیسی شریفی از افراد بیرون سپاه بودند که در پروژه یاس فعالیت می کردند.

عیسی شریفی نظامی سابق ایرانی است که معاونت هماهنگی امور مناطق شهرداری تهران را از مهر ۱۳۸۶ تا اردیبهشت ۱۳۹۶ بر عهده داشت و به «شهردار در سایه» ملقب شده بود. گفته می‌شود در دوران جنگ ایران و عراق از فرماندهان نیروی هوایی سپاه بوده‌است. او به مدت ۱۲ سال قائم مقام و معاون قالیباف در شهرداری تهران بوده‌است. ویکی‌پدیا

اتهام(های) جزایی: مشارکت در کلاهبرداری باندی، مشارکت در پولشویی و برداشت و تصاحب غیرقانونی وجوه

شاخه نظامی: سپاه پاسداران انقلاب اسلامینیروی انتظامی

https://fa.m.wikipedia.org

بهمن 1400 : عزل 1000 نفر از مدیران فاسد و نالایق اداره کار ( استخفر ... در جمهوری اسلامی   ) به روش عبدالملکی 

102 no Out

البته تصاویری که در این فیلم در ۲۶ بهمن ۱۴۰۰ پخش نشد.( مصادف با روز مرد )

حجت الاسلام مسعود عالی استاد حوزه در اظهاراتی از نوشین معراجی، فیلمنامه‌نویس «نمور» در پی مواضع اخیرش در خصوص روابط زن و مرد به شدت انتقاد کرد و گفت: آن خانم داوری که در جشنواره حرف ازدواج سفید را زد، مسئولین ارشاد تو دهنش باید می‌زدند. تو غلط میکنی ...

فارس نوشت:حجت الاسلام حسینی گفت: در جشنواره فجر انقلاب، سالیان متمادی است که به اسلام و انقلاب دهن کجی می کنند و مسؤولین امر سکوت می‌کنند. ازدواج سفید یعنی بدون تعهد و بدون ضوابط شرعی و طفل حاصل از آن را مباح دانستن، ترویج اباحه گری است

[;database;path;pwd=].[tb1]

ویژگی رنگ پشت زمینه ردیف ها یک در میان در سکشن Detail

B3

Private Sub Detail_Print(Cancel As Integer, PrintCount As Integer)

Me.Section("Detail").AlternateBackColor = RGB(240, 240, 240)

End Sub

به نمای دیزاین بروید روی سکشن Detail کلیک کنید و بر گه پراپرتی آن را بیاورید به تب Format بروید و بگردید دنبال  AlternateBackColor  از اونجا می توانید گزینه ای را انتخاب کنید یا رنگ دلخواهتون رو از جداول RGB استخراج کنید و به هگزادسیمال در این تکست باکس وارد کنید .

RGB =RED , GREEN , BLUE 

RGB(255,255,255)=#FFFFFF

اعداد داخل پرانتز به دسیمال است برای تبدیل دسیمال به هگزادسیمال عدد را بر 16  تقسیم می کنید  عدد های  خارج قسمت و مانده را در کنار هم می گذاریم البته معادل آنها را  ،  مثل A برابر 10 ، B برابر 11 تا F برابر 15 و زیر 10 همان خود عدد در نظر گرفته میشود 

255÷16=15

255-15×16=15

1515=FF

Decimal : 109

109÷16=6

109-6×16=13

Hex : 6 13 =6D  ' هگزا میشود معادل 6 و 13 کنار هم 

RGB(109,109,109)=#6D6D6D

در لینک زیر امتحان کنید 

www.w3schools.com/colors/colors_rgb

اعداد دسیمال  را داخل پرانتز جانمایی کنید و روی لینک Use this color in our Color Picker بزنید هگزا و رنگ در باکس نمایش داده خواهد شد

برای White شدن یا ازبین بردن کالر ردیف های یک در میان  ، داخل تکست باکس ویژگی  Alternative در تب Format سکشن Detail یا Blank کنید اگر ارور ندهد یا FFFFFF# را وارد کنید یعنی (RGB(255,255,255 معادل رنگ سیفید

حال برای اینکه روی هر ردیف که کلیک می کنید کل فیلدهاش BackColor یکسان بگیرند از ConditionalFormatting یا قالب بندی شرطی استفاده می کنند البته برای هر فیلد باید یک شرط نوشت !!! نسخه اکسس تا کنون قابلیت اینکه تمام فیلدهای ردیف را رنگی یا Coloured بنماید ندارد. چه شرطی بنویسید ؟!!! روش کار : باید حتما در فرمتان یک آیدی وجود داشته باشد !!! یا کد یونیک !!! یک تکست باکس در Header تعبیه کنید و در رویداد Current فرم آنرا معادل فیلد ID یا فیلد عددی قرار دهید سپس چک کنید هر وقت به رکوردهای دیگر می روید آن تکست باکس همان ID که در آن هستید را به شما نشان می دهد ... حال به Conditional Formatting فیلد مورد نظر بروید در حالت LayOutView هم تنظیم امکانپذیر است. در آنجا یک شرط ایجاد کنید باکس مربوطه را به Expression تنظیم نمائید . عبارت شرطی شما ،  اگر نام فیلد در فرم کانتینیوس  ID و نام تکست Txt1 باشد می شود

[ID]=[Txt1]

با روش FormatConditions.Add می توان یک قالب شرطی به فیلد اضافه نمود. برای اصلاح از روش Modify بهره ببرید.

expression.Add (Type, Operator, Expression1, Expression2)

مثال : 

Field1.FormatConditions.Add acFieldValue,acEqula,"id Mod 2=0)
Field1.BackColor=RGB(255,255,255)
Field1.ForeColor=RGB(240,240,240)

 یک پراپرتی Count هم دارد که تعداد آیتم های موجود در قالب شرطی هر فیلد را میشمرد و بر پایه صفر یا Zero Base است یعنی از صفرشروع و  تا پراپرتی Count منهای یک ادامه می یابد البته تعداد آیتم ها محدود است

در Load فرم اگر لوپی در TextBox و TextBox مربوط به ComboBox لوپ می زنید که کاندیشنال فرمتینگ به فیلدها اضافه بنماید می توانید قبلش با پراپرتی Count فیلد چک کنید اگر صفر بود اضافه کند البته اگر کاندیشنال ضروری دیگری در آن نداشته باشید.

برای تعیین رنگ BackColor آیتم خاص در کاندیشنال فرمتینگ هر فیلد از پراپرتی Item که ایندکس از صفر شروع میشود استفاده کنید . نحوه استفاده (Module.Item(0 با (Module(0 فرقی نمیکنند. ایندکس کنترل ها هم Zero Base است

Controls("ID").FormatConditions.Item(0).BackColor=(0,100,200)

یک Type کاندیشنال به نام DataBar هم دارد که داده عددی را بصورت میله ای نمایش می دهد.

کافئین منجر به کم آبی بدن می‌شود و در نتیجه افزایش لخته شدن خون و همچنین کاهش عناصر کمیاب خون مانند پتاسیم می‌شود که بر عملکرد قلب و سیستم قلبی عروقی تاثیر منفی می‌گذارد. اگر اُمیکرون گرفتید از خوردن چای پرهیز کنید !!!

22 بهمن 1400 : 

23 بهمن 1400  : صبح امروز به دلیل اتصال شبکه برقِ جنبِ بازار کفاشانِ تهران ، دچار آتش سوزی شد که خوشبختانه هیچکدام از مغازه های کفش آسیب ندیده و این حادثه متوجه صنف لوازم خانگی بوده است.

23 بهمن 1400 ( مسکن ملی - مجردها ) محمودزاده در پاسخ به این سئوال که آیا در زمان برگشت پول و آورده اولیه به مجردهایی که نتوانستند در مدت زمان معین متاهل شوند، بحث پرداخت سود برای خواب سپرده و پول افراد در نظر گرفته شده، گفت: خیر، برگشت پول به افراد بدون سود است چراکه بنگاه معاملاتی باز نکرده‌ایم که واحدی را از کسی بخریم و به فرد دیگر بفروشیم و از این محل سودی کسب کنیم.

گزارش-میدانی-آیا-مردم-از-انقلاب-پشیمان/

23 بهمن 1400 : یک استاد دانشگاه در اهواز که تمایلی به معرفی خود ندارد می‌گوید: «مسئله‌ی امروز ما انقلاب نیست که بگوییم مردم پشیمان شده‌اند یا نه، بلکه موضوع اصلی این است که نظام سیاسی که پس از انقلاب بر سر کار آمد به درستی انتخاب نشد و اشکالات و تناقضات موجود در قانون اساسی نیز دقیقا به همین دلیل به وجود آمده است. ریشه‌ی بسیاری از مشکلات امروز به همین موضوع بازمی‌گردد که اصطلاحا مردم می‌دانستند چه نمی‌خواهند اما نمی‌دانستند چه می‌خواهند، حتی رهبران انقلاب هم نمی‌دانستند که پس از انقلاب باید چه کار کرد و به همین دلیل این وضعیت به وجود آمده است».

هشدار: پیامک حاوی لینک دانلود اپلیکیشن از شماره‌های شخصی، جعلی و به قصد سرقت از حساب شماست، به هیچ وجه کلیک نکنید.

در اختتامیه جشنواره فیلم فجر، اُمیکرون؛ رفته بود گل بچیند!

22 بهمن 1400 : میثم مطیعی امروز در مراسم جشن پیروزی انقلاب، در شعرش گفت: «حق مردم نه چنین صنعت خودروسازی‌ست» و سپس بینندگان با قطع ناگهانی پخش زنده مواجه شدند.

بدون سقف !!!

[;Database;Path;Pwd=].[T1]

launching the second button by the first

Private Sub Command1_Click()

Command2_Click

End Sub 

Public Sub Command2_Click()

Msgbox "launching the second button by the first" & Me.Command2.Caption

End Sub 

کلاس پنجره ها در باکس ورودی پسورد اکسس ( دیتابیس با پسورد )

کلاس پنجره 32770# است و آیدی های کنترل داخل آن با لوپ زدن و استفاده از تابع GetDlgCtrlID گرفته شده

SendMessageA(GetDlgItem(hhWnd, 2213), WM_GETTEXT, wparam,lparam use strptr

wParam تعداد کاراکتری است که به متغیر بافر تخصیص می دهد ( منظور داخل بافر کپی می کند ) و lParam خود متغیر بافر است مثل $Buff ، برای ارسال نوشته  داخل کنترل RichEdit جایی که پسورد را تایپ کردیم  به Caption پنجره والد از تابع SetWindowTextA بهره بردیم دقیقا مثل تصویر زیر

Function NewWindow1(ByVal hWnd As LongPtr,ByVal uMsg As Long,ByVal wParam As LongPtr,ByVal lParam As LongPtr) As LongPtr
Dim lRes As long
NewWindow1=CallWindowProc(oldWindow, hWnd, uMsg, wParam, lParam)
Select Case uMsg
   Case &H133
   Case &138
   SetBkMode wParam,1
   wParam, RGB(255, 0, 0)
NewWindow1=GetStockObject(8)
   Case WM_NCHITTEST
 lRes=DefWindowProc(hWnd,uMsg,wParam,lParam)
   '   1  : Client
   '   2 :  Caption
   '   wm-nchittest
   Case Else
End Select
End Function

منظور نوشته زیر این است که اگر شما از DefWindowProc استفاده کنید تغییر رنگ ناحیه Static امکانپذیر نیست و این تابع رنگ پیش فرض سیستم را انتخاب می کند پس سعی بیهوده نکنید!!!

By default, the DefWindowProc function selects the default system colors for the static control.

setwindowsubclass

Declare PtrSafe Function SetWindowSubclass Lib "comctl32" (ByVal hWnd As LongPtr, ByVal pfnSubclass As LongPtr, _

  ByVal uIdSubclass As LongPtr, ByVal dwRefData As LongPtr) As LongPtr

Declare PtrSafe Function RemoveWindowSubclass Lib "comctl32" (ByVal hWnd As LongPtr, ByVal pfnSubclass As LongPtr, _

  ByVal uIdSubclass As LongPtr) As LongPtr

Declare PtrSafe Function DefSubclassProc Lib "comctl32" (ByVal hWnd As LongPtr, ByVal uMsg As Long, _

  ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr

Dim hNotePad As Long
    Dim hEdit As Long
    hNotePad = FindWindow("NotePad", vbNullString)
    hEdit = FindWindowEx(hNotePad, 0, "Edit", vbNullString)
    Call SendMessage(hEdit, WM_SETTEXT, 0, ByVal "abc")
'StrPtr : Transfer Unicode
'Const WM_SETTEXT = &HC




CopyMemory  nml,ByVal lParam,,LenB(nml)

CopyMemory  lParam,,ByVal nml,LenB(nml)

SubClassing ( Tested Successfully ) 

وقتی SubClass می کنید در واقع پنجره جدیدی ساخته شده و پنجره قدیمی میشود Default.لذا زمان خروج از New به Prev یا Default منتقل میشوید. اگر حذف بدرستی انجام نشود Crash حتمی است  و در نهایت مجبور خواهید شد با Ctrl+Shift+Esc  به Task Manager رفته و اپلیکیشن را End Process  کنید !!! متاسفم چاره ای نیست برای همه پیش می آید حتی باتجربه ها

OnTimer : 

Use FindWindowA  To Get Handle For the Window Class  "#32770"

if HandleWindow<>0  And hHook=0 Then

hHook=SetWindowsHookEx(WH_CBT,AddressOf NewHook,0&,GetCurrentThreadId)

Me.TimerInterval=0

Crash در این قبیل موارد طبیعی است و می بایست قبل از انجام همچین موارد غیر اصولی  که آفیس هم توصیه نمی کند ، حتما یک بک آپ از فایل تهیه شود تا در صورت خرابی فایل فایل جایگزین داشته باشید!!!

Function NewHook(nCode,wParam,lParam)

NewHook=CallNextHookEx(hHook,nCode,wParam,lParam)

If nCode=5 Then 

      If GetClass(wParam)=""32770" Then 

              UnhookWindowsHookEx hHook

              SetWindowSubclass wParam,AddressOf SubClass,1,0

      End If 

End If

End Function

Function SubClass(hWnd,uMsg,wParam,lParam)

Dim hBr As LongPtr

Dim WinR As RECT

Dim WinP1 As POINTAPI,WinP2 As POINTAPI

SubClass=DefSubClassProc(hWnd,uMsg,wParam,lParam)

Select Case uMsg

            Case WM_CREATE

                  hBkColor=RGB(100,100,100)

                  hTxtColor=RGB(200,0,100)

                 hBr=hBkColor 'GetStockObject(8)

           Case WM_ERASEBKGND

'البته مختصات صفحه باید با تابع ScreenToClient به مختصات کلایِنت تبدیل شود اگر این پیام توسط Parent یا والد Recieve شود رنگ بک گراند پنجره عوض خواهد شد. ( به رنگ دلخواه شما از پالت رنگ آمیزی )  RGB

          Case  WM_CTLCOLORSTATIC

'در اینجا رنگ داخل ناحیه استاتیک و نوشته هاش  که Prompt است عوض می شود

                SetBackColor wParam,hBkColor

                SetTextColor wParam,hTxtColor

               SubClass=hBr

          Case WM_DESTROY,WM_NCDESTROY

'حذف ساب کلاس و هوک در زمان خروج 

               RemoveWindowSubclass

 hWnd,SubClass,1

              ' DeleteObject (hBrush Or hFont)

              hHook=False

End Select

End Function

sputniknews.

free : subclassing-and-hooking-with-visual-basic

free : subclassing-and-hooking-with-visual basic_78aa.pdf

i can not figure out what to do what not  to  do

21 بهمن 1351؛ دلار سقوط کرد

21 بهمن 1400 : ایرنا نوشت: جواد منصوری گفت: آمریکا ژنرال هایزر را فرستاده بود تا یک میلیون آدم بکشد  تا محمدرضا پهلوی بر اوضاع مسلط شود ولی این اتفاق نیافتاد، خداوند نخواست و امام (ره) انقلاب را رهبری و فرماندهی کرد و نهایتا انقلاب پیروز شد.

21 بهمن 1400 : علیرغم انتقاد رهبر انقلاب از افزایش قیمت‌ لوازم خانگی، متاسفانه هنوز شرکتهای بزرگ این حوزه از جمله اسنوا که سودهای غیرمتعارف بالای هزار میلیارد تومانی دریافت می کردند، اقدام به کاهش قیمت نکرده اند، بلکه برخی هنوز دنبال افزایش مجدد قیمت هستند.

22 بهمن 1400 : مدیر بیوتکنولوژی موسسه رازی با بیان اینکه بر اساس مطالعات انجام شده، اثربخشی واکسن کووپارس ۲.۵ تا سه برابر بیش از سینوفارم بوده است، گفت: تزریق دز استنشاقی واکسن رازی منجر به افزایش مقدار آنتی بادی در قسمت‌های بینی و مخاطی شده و هم ورود ویروس به قسمت فوقانی دستگاه تنفسی کمتر شده و در نتیجه انتقال ویروس کمتر اتفاق می‌افتد.

نشانک یا BookMark در اکسس و بررسی رفتن به رکورد خاص

کاربرد ویژگی Bookmark با فرم ها برای تنظیم نشانکی که بصورت یکتا یک رکورد خاص در فرم تحت جدول را مشخص می نماید.

Form.Bookmark

نشانک ها را در هر فرمی که کاملا بر اساس جدول های اکسس است می توان بکار برد . اگرچه دیگر محصولات دیتابیس می توانند نشانک ها را پشتیبانی نکنند . برای مثال شما نمی توانید نشانک ها را در یک فرم بر پایه یک جدول پیوندی ( link Table  ) که primary index ندارد استفاده نمائید.

Requery کردن یک فرم هر نشانک تنظیم شده ای روی رکوردها در فرم را ازبین می برد.اگرچه انتخاب Refresh در رکوردها نشانک ها را مورد تاثیر قرار نمی دهند. 

بدلیل اینکه اکسس یک نشانک یکتا برای هر رکورد در رکوردست یک فرم ایجاد می نماید زمانیکه یک فرم باز است !!!  ، یک نشانک فرم در رکوردست دیگر حتی زمانیکه دو رکوردست بر پایه یک جدول باشند کار نخواهد کرد !!!

Docmd.GoToRecord

استفاده از روش GoToRecord برای تبدیل رکورد مشخص شده به رکورد جاری در یک جدول باز ، فرم یا مجموعه نتایج کوئری ( پرس و جو ).

اگر پارامتر Type و Name آبجکت ( فرم فرضا ) خالی بگذارید روی آبجکت جاری انجام می گردد.

استفاده از روش GoToRecord برای تبدیل یک رکورد به رکورد جاری ( رکوردی که در آن قرار دارید یا کر سر در آن است ) یک فرم پنهان اگر فرم پنهان را در آرگومان های Type و Name آبجکت مشخص نمائید.

ایجاد رکورد خالی در جدول البته اگر کلیدی در جدول وجود نداشته باشد یا جای رکوردهایی که فیلدشان Primary key است و نمی تواند خالی باشد ( required آن Yes است )  پر شود که ارور نگیرید . فرضا یک جدول دارید که شماره پرونده فرد مذکور برای اقساط ثبت می گردد و جدول دیگری که جزئیات مربوطه یعنی  تعداد اقساط فرد با کد یونیک پرونده در آن ایجاد می شود با اکشن Docmd.GoroRecord !!!

تابع URLDownloadToFile جهت دانلود فایل

دانلود فایل بصورت بیت از اینترنت و ذخیره آنها در یک فایل 

https://docs.microsoft.com/

Access_URLDownloadToFile_API_function

Sub timeout_for_bad_starts()
dlpath = "C:\DownloadedPics\"
For i = 2 To 7
    imgsrc = Cells(i, 2)
    imgname = Cells(i, 1)
    result = URLDownloadToFile(0, imgsrc, dlpath & imgname & ".jpg", 0, 0)
    
    If result <> 0 Then
        Application.Wait (Now + TimeValue("00:00:03"))
        result = URLDownloadToFile(0, imgsrc, dlpath & imgname & ".jpg", 0, 0)
    End If
    'if the result is still zero, mark the failure somehow and move on
Next i
End Sub

HTML DOM Events

مطالعه بفرمائید لینک زیر را چون رویدادهاش در کنترل WebBrowser کاربرد دارند فرضا OnMouseDown که وقتی باتن چپ ماوس فشرده شده کاری را انجام دهد بعضی از آنها با Private Sub و بعضی هم با Private Function و نام رویداد + As Boolean اظهار می شوند.

w3schools

برای استفاده از ابزار html حتما در رفرنس ویژوال اکسس تیک html object library را بزنید.

برای استفاده از رویدادها حتما باید متغیر تنظیم شده ( دررویه DocumentComplete ) را با WithEvents در بالای تمام رویه ها در هر Mo dule اعلان کنید.

Private Sub WebBr0_DocumentComplete(Byval pDis As Object,url As Varaint)

Set htmlDoc=WebBr0.Document

End Sub

Dim IE As Object

Set IE=CreateObject("InternetExplorer.Application")

Set AllHyperlinks=IE.Document.getElementByClassName("product- list - container")(0).getElementByTagName("a")

For Each hyperlink in AllHyperlinks

Debug.print hyperlink.href & hyperlink.innerText

Next

WebBr0.Document.body.doscroll="no"

برای پیمایش به پائین ترین موقعیت webpage:

WebBr0.Document.parentwindow.scroll 0,4000

ParentWindow.event  متدهایی  دارد مثل ClientX و ClientY که در onmousemove می توان بهره برد یا KeyCode برای گرفتن کد کلید فشرده شده در رویداد onkeyup یا حتی onkeypress ( فرضا در این رویداد گفته میشود اگر کدها غیر از کد عدد 0 تا 9 بود عملی انجام نشود KeyCode=0 )

internet-explorer/ie-developer

X=1

Set NodeList=Doc.

getElementsByTagName("P")

For Each Elem In NodeList

Select Case X

       Case 2

              Debug.Print Elem.innerText

       Case 4

             Debug.Print Elem.innerText

End Select

X=X+1

Next

Private Sub Command1_Click()
   WebBrowser0.ControlSource = "=""C:\Users\Renaud\AppData\Local\Temp\map-simple.htm"""
End Sub

19 بهمن 1400 : هرچند نقش ویتامین دی در سلامت استخوان‌ها و سیستم ایمنی بدن شناخته شده بود اما تاکنون تاثیر آن بر علائم نوع حاد «کووید ۱۹» مشخص نشده بود.

تحقیقی که دانشمندان اسرائیلی انجام داده‌اند اولین پژوهشی است که در آن ارتباط سطح ویتامین دی در بدن فرد پیش از ابتلا به ویروس کرونا با بروز علائم حاد «کووید ۱۹» مورد بررسی قرار گرفته است.

مرگ بر اسرائیل !!!

روش ساخت Refrence به یک نوع کتابخانه در یک فایل مشخص یا تیک زدن mshtml.tlb موجود در محیط VBE اکسس برای استفاده ازابزار HTML

AddFromFile

The AddFromFile method creates a reference to a type library in a specified file.

C:\Windows\System32\mshtml.tlb

VBE.ActiveVBProject.Refrences.AddFromFile (FileName)

Dim WithEvents htBody As htmldocument    استفاده از رویدادها در وب بروزر

گرفتن مختصات x , y زمان فشردن باتن سمت چپ ماوس روی پنجره

Function BoxProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lparam As LongPtr) As LongPtr

Case WM_LBUTTONDOWN

       Dim p As POINTAPI

        GetCursorPos p

        ScreenToClient hWnd, p

        SetWindowTextA hWnd, "lbtn" & "..." & p.x & "." & p.Y

Case WM_DESTROY,WM_NCDESTROY

      SetWindowLongptr hWnd,(-4),HookBox

End Select

BoxProc=CallWindowProc(HookBox,hWnd,Umsg,wParam,lParam)

End Function

FIELD.VALUE

به طور کلی ویژگی Value برای بازیابی و تغییر ( alter ) داده ها در اشیاء رکوردست استفاده می شود.

ویژگی Value ویژگی پیش فرض آبجکت یا اشیاء Paramer ، Field و Property است بنابراین بجای تعیین این ویژگی می توانید با مراجعه مستقیم به یکی از این اشیاء (مثل Field بدون ذکر Value ) مقدار آن  را تنظیم یا بازیابی نمائید.

تلاش برای تنظیم یا برگرداندن ویژگی Value در یک زمینه نامناسب ( بعنوان مثال ویژگی Value یک شئ Field در مجموعه یا کالکشن Fields یک شئ TableDef )  شما را در تله می اندازد و باعث خطا می شود 

بازیابی یا گرفتن متن داخل کنترل Edit در جعبه InputBox ( کلاس 32770# )

لطفا در صورتِ "استفاده" حتما در نظر سنجی شرکت و فاتحه ای برای پدر مرحومم قرائت بفرمائید.

فروش مطالب ارزنده زیر به غیر ممنوع و اشکال شرعی دارد ( پیوند دادن منعی ندارد ) لطفا رعایت نمائید !!!

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

Case WM_NCLBUTTONDBLCLK  '&HA3   Client درمنظقه بیرون 

        SetWindowTextA hWnd, "Dbl Clicked"

WM_NCRBUTTONDOWN 'constant : &HA4  Client درمنطقه بیرون 

Using SetWindowTextA 

EXIT FUNCTION

تبدیل متن فارسی به کدهای یونیکد برای استفاده ، در پیوندها با عنوان "کاراکتر فارسی" قرار داده شده که می توانید از آن بهره ببرید.البته کد Space را نمی دهد و کد آن 0020 است.

edit-controls

تنظیم و بازیابی تکست درتکست باکس ادیت کنترل : 

با تابع 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 Bars

سیستم سه پیام  که برنامه می تواند به کنترل ویر ایش دارای 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 'تنظیم نمایش کاراکتردلخواه بجای کاراکترورودی

'Password InputBox

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).

wm-command

طبق جدول لینک بالا ،  پارامتر lParam در کنترل هندلی است به پنجره آن البته نوتیفیکیشن یا اعلان نیز می فرستد چه زمان فوکس گرفتن ،  تغییر و به روز رسانی ، در EN_CHANGE  پیام هایی که دریافت شده را ملاحظه بفرمائید.

' If lparam=hRichEdit Then

'1398/07/15

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  'سه کاراکتر انتخاب شده

  : CHARFORMAT2

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 را ارسال می نمایند.

WM_COMMAND

Case WM_INITDIALOG

 m_redcolor=RGB(255,0,0) 'red m_bluecolor=RGB(0,0,255) 'blue m_textcolor=RGB(255,255,255) 'white text m_redbrush=CreateSolidBrush(m_redcolor)'red background m_bluebrush=CreateSolidBrush(m_bluecolor) 'blue background

Case CTLCOLOR_EDIT, CTLCOLOR_MSGBOX

  Select Case GetDlgCtrlID(hWnd)

       Case 4900 'Edit

          SetBkColor hDC,bluecolor

          SetTextColor hDC,textcolor

             hbr=m_bluebrush

          Exit Function

   End Select

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>

Static Style

WM_NOTIFY

توسط یک Common Control به پنجره والدش زمانیکه رویدادی رخ می دهد ارسال می شود.

Sent by a common control to its parent window when an event has occurred or the control requires some information.

قسمت lParam به ساختار NMHDR اشاره می کند که شامل کد اعلان است.

EN_LINK Notification Code

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

use-syslink-notifications

در لینک بالا استفاده از اعلان های 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

COMCTL

Free Memory

CopyMemory lParam, ByVal nmh, LenB(lParam)
CopyMemory lParam, ByVal nml, LenB(lParam)
CopyMemory nml.item, ByVal tItem, LenB(nml.item)

WM_NOTIFY'

 Case (-1249)

            SetWindowTextA hWnd, nmh.idFrom

            End Select

تغییر رنگ تمام HyperLink ها در WM_NOTIFY و استفاده از ساختار NMCUSTOMDRAW

lhittestinfo

lm-hittest   :  

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

about-rich-edit-controls

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);


creating-a-hyperlink

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 

دو می باشد 

add-a-hyperlink-to-a-dialog

ساخت Popup Menu :

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
 

shell_notifyicona : 

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)

'loadiconmetric

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

Shell_NotifyIcon NIM_ADD, nfIconData

End Sub

Public Sub BalloonPopUp()

' ok, create a balloon popup..

With nfIconData

.dwInfoFlags = vbInformation

.uFlags = NIF_INFO

.szInfoTitle = "ToolTip" & vbNullChar

.szInfo = "Message" & vbNullChar

End With

' ok, write it to the system tray icon

Shell_NotifyIcon NIM_MODIFY, nfIconData

End Sub

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 را تنظیم ننمائید.

TTM_ADDTOOLW (Unicode) and TTM_ADDTOOLA (ANSI)

Private Sub AddToolTip()
Dim tCaretPos As POINTAP
RemoveToolTip

if IsWindow(hToolTip)=0 Then

InitCommonControls

hToolTip = CreateWindowEx(0, "tooltips_class32", 0, WS_POPUP Or TTS_BALLOON,0, 0,0,0, 0, 0, GetModuleHandle(vbNullString), 0)

 If hToolTip Then  'False 

  With tToolInfo   'Structure

.cbSize = LenB(tToolInfo)

GetWindowRect(GetFocus, .cRect) ' گرفتن ابعاد مستطیل پنجره

.hWnd = GetFocus ' گرفتن هندل کنترل 

.uFlags = TTF_TRACK 'Or TTF_ABSOLUTE

.uId = GetFocus

.lpszText = "Balloon Text "

SendMessageA hToolTip, TTM_SETTITLEA, lBallonIcon, ByVal sBallonTitle)

End With

SendMessageA hToolTip, TTM_ADDTOOL, 0, tToolInfo 

ClientToScreen GetFocus, tCaretPos 

GetCaretPos(tCaretPos)

With tCaretPos

.y = .y + 10

SendMessageA hToolTip, TTM_TRACKACTIVATE, True, tToolInfo

SendMessageA hToolTip, TTM_TRACKPOSITION, ByVal 0&,

End With 

'SetTimer Application.hWndAccessApp,0,,0,AddressOf MonitorInputBoxPos)

End If

End If

End Sub

Private Sub RemoveToolTip()
   ' bInputBoxInactive = False
   ' KillTimer Application.hWndAccessApp, 0
    DestroyWindow hToolTip
End Sub

Private hHook A Long

Function CallWndProc(ByVal nCode As Long, ByVal wParam As Long, lParam As CWPSTRUCT) As Long
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 بهمن : علیرضا مرندی وزیر پیشین بهداش، درمان و آموزش پزشکی در یک برنامه تلویزیونی در شبکه سلامت ضمن دعوت از مردم برای دریافت دزهای واکسن کرونا، از دریافت دُز سوم واکسن کرونا توسط رهبر انقلاب خبر داد و گفت: همانطور که مقام معظم رهبری سه نوبت واکسن‌شان را تزریق کرده‌اند و واکسن ایرانی و برکت هم زدند، ما هم باید همین‌کار را بکنیم، آن‌هایی که واکسن نزدند عجله کنند.

هک صدا و سیما

KaYywMemBx

641492

مطابق با مستندات منتشر شده از سوی سازمان بورس، زیان انباشته بانک آینده برای عملکرد منتهی به پایان شهریور ماه ۱۴۰۰ به ۸۱ هزار و ۹۰۰ میلیارد تومان رسیده است.

ارسال تکست به کلاس 32770# و شرح COPYDATASTRUCT

Const WM_SETTEXT=&HC

Const WM_GETTEXT=&HD

Const WM_GETTEXTLENGTH=&HE

Const WM_COPYDATA=&H4A 

Type COPYDATASTRUCT 

dwData As Long

cbData As Long

lpData As Long

End Type

WM_GETTEXT :

پارامتر wparam مربوط به ماکزیمم کاراکتری که در بافر کپی میشود و پارامتر lparam یک نشانگر به بافری است که کاراکترها را دریافت می کند ... برگشتی تابع تعداد کاراکترهای کپی شده جز کاراکترهای Null.

Dim lRet As LongPtr

Dim Buff

Buff=Space(255)

'Declare SendMessageA :

'ByVal hwnd As Longptr,Byval uMsg as long,Byval wParam As LongPtr,lParam As Any) As Long Or LonPtr

lRet=SendMessage (hwnd,WM_GETTEXT,Len(Buff),Buff)

Debug.Print lRet

درتصویربالارشته www.accessvba.blogsky.com به همراه طول این رشته ( شامل 25 کاراکتر) به پنجره Msgbox که دارای کلاس 32770# است فرستاده شده . با ارسال پیام WM_GETTEXTLENGTH هم می توانید طول رشته را بگیرید.

WM_COPYDATA:

hwnd = FindWindow(vbNullString, "Data Collector")
If hwnd <> 0 Then
Dim cds As COPYDATASTRUCT

cds.dwData = 0

cds.cbData = Len(partNumber) * 2 + 2

cds.lpData = StrPtr(partNumber)

result = SendMessage(hwnd, WM_COPYDATA, 0, cds)

End If

End Sub

hWndNotepad = FindWindow("notepad", vbNullString)

hWndNotepadEdit = FindWindowEx(hWndNotepad, 0, "Edit", vbNullString)

WM_SETTEXT :

sendMessageByString hwnd,&HC,0,"www.accessvba.blogsky.com"

برای ارسال با SendMessage پارامتر lParam را بصورت lParam As Any بنویسید و در این پارامتر برای ارسال تکست از ByVal بهره ببرید

SendMessageA Lib "user32" (ByVal hwnd As LongPtr, ByVal wMsg As Long,ByVal wParam As LongPtr, lParam As Any) As LongPtr

SendMessageA wParam, &HC, 0, ByVal "www.accessvba.blogsky.com"

Window Style : 

WS_HSCROLL=&H100000&

WS_VSCROLL=&H200000&

GetInnerAccessHwnd =FindWindowEx(hWndAccessApp, ByVal 0&,"MDIClient", vbNullString)
'GetClientRect hwnd,MyRect

'MoveWindow

'MDIClient 

ExStyle=GetWindowLongPtr(ClientHandle,GWL_EXSTYLE)
ExStyle=ExStyle and not WS_EX_CLIENTEDGE
SetWindowLongPtr(ClientHandle,GWL_EXSTYLE,ExStyle)
SetWindowPos ClientHandle, 0,0,0,0,0,SWP_FRAMECHANGED or SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER

   Public Function NewClassProc(ByVal hwnd As Long, ByVal uMsg As Long, _ 
                ByVal wParam As Long, ByVal lParam As Long) As Long
    
    Dim I As Integer
    Dim FocusWindow As Long
    NewClassProc = CallWindowProc(OrigWndProc, hwnd, uMsg, _
                                  wParam, lParam)
    For I = 0 To Forms.Count - 1
        If Forms(I).hwnd = hwnd Then
            FocusWindow = I
            Exit For
        End If
    Next I
    
    'Modify the windows default processing if necessary
    If uMsg = WM_SYSCOMMAND And FocusWindow <> 0 Then
        If wParam = SC_MINIMIZE Then
            If Forms(FocusWindow).WindowState <> vbMaximized Then
                'Do not process message - instead do our own work
                Forms(FocusWindow).Height = 30
            End If
            NewClassProc = 0
        Else
            NewClassProc = CallWindowProc(OrigWndProc, hwnd, uMsg, _
                                          wParam, lParam)
        End If
    Else
        'Pass message to default handler
        NewClassProc = CallWindowProc(OrigWndProc, hwnd, uMsg, _
                                      wParam, lParam)
    End If
End 
Function

حذف پنجره Static و ساختن یک کنترل Static دیگر در همان مختصات البته با Border

Dim P1 As POINTAPI

DIM P2 AS POINTAPI

DIM winRect As RECT

Dim StaticRect As RECT

DestroyWindow hStatic

GetWindowRect wParam,winRect

GetWindowRect wParam,StaticRect

With StaticRect

P1.x=.Left : P1.y=.Top

P2.x=.Right : P2.y=.Bottom

ScreenToClient hSatatic,P1

ScreenToClient hStatic,P2

hNewStatic=CreateWindowEx(0,"Static","",WS_CHILD+WS_VISIBLE+WS_BORDER,P1.x,P1.y,P2.x-P1.x,P2.y-P1.y,wParam,0,0)

Dim lf As LOGFONT

lf.lfHeight=20

lf.lfwidth=20

hFont=CreateFontIndirect(lf)

SendMessageA hNewStatic,WM_SETFONT,hFont,1

SendMessageA hNewStatic,WM_SETTEXT,0,Byval "Hi"

پنجشنبه ۷ بهمن 1400 : 

خبرگزاری صداوسیما در این مورد نوشت که عصر پنج‌شنبه برخی شبکه‌های رادیو و تلویزیونی در صداوسیما، از جمله شبکه یک سیما، شبکه قرآن، رادیو پیام و رادیو جوان «برای لحظاتی هک شدند».

این گزارش می‌گوید «افراد یا گروهی ناشناس دقایقی قبل تلاش کردند تا چند شبکه صداوسیما را هک کنند» اما در ادامه می‌افزاید که «در میان پخش آنونس برنامه‌ها به مدت ده ثانیه، تصاویری از سران» سازمان مجاهدین خلق «و صوت یکی از سخنرانی‌های آن‌ها روی آنتن شبکه یک دیده و شنیده شد».

در پی این هک ۱۰ ثانیه‌ای، پخش برنامه‌ از چند شبکه تلویزیونی ایران از جمله شبکه‌های یک، قرآن، پیام و جوان متوقف شد، و هم‌زمان تصاویری از مریم رجوی و مسعود رجوی از رهبران سازمان مجاهدین خلق و تصویری از رهبر جمهوری اسلامی با ضربدر قرمز که روی آن شعار «مرگ بر خامنه‌ای، درود بر رجوی» دیده می‌شد، پخش شد.

31674296

ترسیم ناحیه TitleBar

BOOL IsWindowEnabled( [in] HWND hWnd

Declare PtrSafe  Functuon IsWindowEnabled lib "user32" (ByVal hWnd As LongPtr) As Boolean

If idHook = HCBT_ACTIVATE Then
        If IsWindowEnabled(GetParent(wParam)) Then
            UnhookWindowsHookEx lHook
            MsgBox "You can't format a Modeless Userform.", vbCritical
            Exit Function
        End If

'Put Inside WindowProc

Dim tPt As POINTAPI, tClientRect As RECT
Dim loword As Long, hiword As Long
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)
DrawTitleBar(hwnd, lTitleBarColor)
InvalidateRect hwnd, tClientRect, 0
Case WM_EXITSIZEMOVE
DrawTitleBar(hwnd, lTitleBarColor)
InvalidateRect hwnd, tClientRect, 0
Case WM_NCPAINT
If bDrawn = False Then bDrawn = True: 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
If PtInRect(tUpdatedCloseButtonRect, tPt.x, tPt.y) Then
If PtInRect(tUpdatedCloseButtonRect, tPt.x, tPt.y) Then

DrawTitleBar(hwnd, lTitleBarColor, True) Do DoEvents
Loop Until GetAsyncKeyState(vbKeyLButton) = 0
GetCursorPos tPt

CopyMemory lngPtr, tPt, LenB(tPt)

If PtInRect(tUpdatedCloseButtonRect, lngPtr) Then
If PtInRect(tUpdatedCloseButtonRect, tPt.x, tPt.y) Then
If PtInRect(tUpdatedCloseButtonRect, tPt.x, tPt.y) Then
If bCloseButtonPressed Then Sleep 200 Unload oForm
End If
End If

If bCloseButtonPressed Then
DrawTitleBar hwnd, lTitleBarColor InvalidateRect hwnd, tClientRect, 0
End If

Case WM_DESTROY
SetWindowLong hwnd, GWL_WNDPROC, lPrevWinProc
SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) And Not CS_DROPSHADOW


'DrawTitleBar function

Dim p1 As POINTAPI, p2 As POINTAPI
Dim tFormRect As RECT, tFillRect As RECT
Dim tPs As PAINTSTRUCT

BeginPaint hwnd, tPs
hdc = GetWindowDC(hwnd)
Color = CaptionColor
hBrush = CreateBrushIndirect(Color)
Call GetWindowRect(hwnd, tFormRect)


bCloseButtonPressed = PressedCloseButton

If Not PressedCloseButton Then
SetRect tFormRect, 0, 0, tFormRect.Right, tFormRect.Bottom
SetRect tFillRect, 0, 5, GetSystemMetrics(SM_CXSIZE), GetSystemMetrics(SM_CYSIZE) + tFormRect.Bottom
OffsetRect tFillRect, tWinRect.Right - tWinRect.Left - GetSystemMetrics(SM_CXSIZE), 0
FillRect hdc, tFormRect, hBrush
DeleteObject(hBrush)
DrawFrameControl hdc, tCloseRect, DFC_CAPTION, DFCS_CAPTIONCLOSE Else
DrawFrameControl hdc, tCloseRect, DFC_CAPTION, DFCS_CAPTIONCLOSE + DFCS_PUSHED
End If

If bDropShadow Then
SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) Or CS_DROPSHADOW
End If

SetBkMode hdc, 1
SetTextColor hdc, lFontColor
CreateFont(hdc) 'CreateFontIndirect
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
EndPaint hwnd, tPs

بررسی قرار گرفتن نشانگر ماوس در ناحیه مورد نظر API

تمام این مطالب گردآوری شده از سایت های مختلف است بعضی امتحان شده و تصویر نیز در مطلب قرار داده شده و در بعضی موارد فقط مطلب Copy Paste شده است به بزرگی خودتان ببخشید دوستان 

این تابع تعیین می کند آیا نقطه داخل ناحیه مشخص شده است یا خیر .فرضا یک ناحیه بیضوی درست کرده اید در WM_PAINT و می خواهید زمانیکه Mouse را داخل آن منطقه بردید کاری را برای شما انجام دهد ، lParam در WM_MOUSEMOVE قسمت loword آن xmouse و قسمت hiword آن ymouse است .

The PtInRegion function determines whether the specified point is inside the specified region.

SetRect R, 0, 0, 50, 50

'Create an elliptical region

createellipticrgnindirect ' Lib "gdi32"

mRGN = CreateEllipticRgnIndirect(R)

For x = R.Left To R.Right
For y = R.Top To R.Bottom
'If the point is in the region, draw a green pixel
If PtInRegion(mRGN, x, y) <> 0 Then
'Draw a green pixel

setpixel  ' Lib "gdi32"

SetPixel Me.hdc, x, y, vbGreen

ElseIf PtInRect(R, x, y) <> 0 Then

'Draw a red pixel

SetPixel Me.hdc, x, y, vbRed

End If

SubClassing The Window : win64

Private OldWindowProc As LongPtr

Const WM_CONTEXTMENU=&H7b

' List_Of_Windows_Messages

Public Function NewWindowProc(ByVal hwnd As LongPtr, ByVal msg  As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Const WM_NCDESTROY = &H82
Debug print Hex$(msg)
If msg = WM_NCDESTROY Then

SetWindowLonPtr hwnd,GWL_WNDPROC,OldWindowProc End If

NewWindowProc=CallWindowProc(OldWindowProc,hwnd,msg,wParam,lParam)

End Function

.

قابلیت دریافت پیام ماوس کلیک در قسمت کنترل Static

برای اینکه کنترل Static  پیام های ماوس را دریافت کند باید استایل SS_NOTIFY تنظیم گردد.

A static control that has the SS_NOTIFY style receives mouse input, notifying the parent window when the user clicks or double clicks the control. Static controls belong to the STATIC window class.

In other words, this Style allows the control to accept mouse messages

تنظیم Style : 

SetWindowLongPtr(HwndStatic, GWL_STYLE, GetWindowLongPtr(HwndStatic,GWL_STYLE) Or SS_NOTIFY

در زیر اعلام کرده که کنترل استاتیک در دیالوگ از بین برود و یکی دیگه ساخته شود.

drag and drop a STATIC control on the Dialog, and name the ID

کد زیر در پیام ویندوزی WM_NOTIFY قرار می گیرد و بعد از کلیک کردن روی ناحیه آن فایل یا Urlباز خواهد شد.

ShellExecute 0,"OPEN",sTargetUrl,0,0, 

SW_SHOWNORMAL

Create Button

گردآوری شده از سایت های مختلف 

Const WS_EX_STATICEDGE=&H20000
Const WS_EX_WINDOWEDGE=&H100

Const WS_EX_CLIENTEDGE=&H200

Const WS_TABSTOP=&H10000

Const WS_CHILD=&H40000000

Const WS_VISIBLE=&H10000000

Const BS_ICON=&H40

Const WM_COMMAND=&H111

Const WM_SYSCOMMAND=&H112

Const WM_KEYUP=&H101

Const WM_LBUTTONUP=&H202

Const HWND_TOP=0

Const HWND_TOPMOST=-1

Const SWP_SHOWWINDOW=&H40

Const SWP_NOMOVE=&H2

Const SWP_NOSIZE=&H1

If bAlwaysOnTop Then fTop=HWND_TOPMOST
Else fTop=HWND_TOP
End If
SetWindowPo hWF,fTop,0,0,0,0,SWP_SHOWWINDOW+SWP_NOMOVE+SWP_NOSIZE

HCBT_CREATEWND '3

Dim Pt As POINTAPI

Dim MyRect As RECT

GetCursorPos Pt

GetClientRect hwnd,MyRect

ClientToScreen MyRect,Pt

Pt.x=(MyRect.Right-MyRect.Left)+5

Pt.y=(MyRect.Bottom-MyRect.Top)-20

nx=Pt.x+20

ny=Pt.y+10

hButton1 =CreateWindowEx(WS_EX_STATICEDGE,"Button","Close",WS_CHILDWINDOW+BS_PUSHBUTTON+WS_VISIBLE,Pt.x,Pt.y,nx,ny,hwnd,BTN1,Application.hwndAccessApp,0&)

hButton2 =CreateWindowEx(WS_EX_STATICEDGE,"BUTTON","Execute", WS_CHILDWINDOW+BS_PUSHBUTTON+WS_VISIBLE,15,175, 70, 30,hwnd,BTN2,Application.hwndAccessApp,0&)

Function WndProc(ByVal hwnd As LongPtr,ByVal uMsg As LongPtr,ByVal wParam As LongPtr,ByVal lParam As LongPtr) As LongPtr

Select Case uMsg

case WM_COMMAND 

     Select Case wParam 

           Case BTN1

              DestroyWindow(hwnd)

              Exit Functuon

          Case BTN2

           MsgBox " You Clicked Me !!! "

Exit Function

    End Select

Case WM_DESTROY '&H2

SetWindowLongPtr hwnd,(-4),PrevProc

PrevProc=0

Exit Function

End Select

WndProc=CallWindowProc(hwnd,uMsg,wParam,lParam)

End Funct

MENUITEM : 

Public Const WM_MENUSELECT = &H11F

Public Const MF_SYSMENU = &H2000&

Public Const MIIM_TYPE = &H10

Public Const MIIM_DATA = &H20

Dim iHi As Integer, iLo As Integer

Select Case Msg

Case WM_MENUSELECT

Form_Form1.Label0.Caption=""

CopyMemory iLo, wParam, 2

CopyMemory iHi, ByVal VarPtr(wParam) + 2, 2

If (iHi And MF_SYSMENU) = 0 Then

Dim m As MENUITEMINFO, Cap As String

m.dwTypeData = Space$(64)

m.cbSize = Len(m)

m.cch = 64

m.fMask = MIIM_DATA Or MIIM_TYPE

If GetMenuItemInfo(lParam, CLng(iLo), False, m) Then

Cap = m.dwTypeData & Chr$(0)

Cap = Left$(Cap, InStr(Cap, Chr$(0)) - 1)

End If

Button Style ( BS )

shell32_dll icon id

ایجاد باتن که هم تکست بگیرد و هم آیکون ، اگر از BS_ICON بجای BS_TEXT استفاده شود فقط آیکون نمایش داده میشود 

'Don't set the BS_ICON or BS_BITMAP style (but do set 'the BS_TEXT style), and send a BM_SETIMAGE 'message once the button has been created.

ConsWM_SETICON=&H80&
Const BM_CLICK=&HF5&
Const BM_SETIMAGE=&HF7&

ID=110 است فرضا اگر از تابع GetDlgCtrlID استفاده کنید برای گرفتن هندل باتن می توانید از این تابع براحتی استفاده بنمائید.

case WM_CREATE

btn=CreateWindowExW(0, "BUTTON","Button text",WS_VISIBLE+WS_CHILD+BS_TEXT,10,10,200,50,hWnd,110,nullptr,

nullptr

HICON=LoadImageW(GetModuleHandle(nullptr),StrPath+StrFile,S IMAGE_ICON, 32, 32, &H0)

ارسال پیام SETIMAGE به پنجره باتن برای لود آیکون در آن

SendMessage btn,BM_SETIMAGE,IMAGE_ICON,icon)

Exit Function

Const IMAGE_BITMAP=0
Const IMAGE_ICON=1
Const IMAGE_CURSOR=2
Const LR_DEFAULTCOLOR=&H0
Const LR_LOADFROMFILE=&H10
Const LR_LOADTRANSPARENT=&H20

Const SS_BITMAP = &HE
Const SS_REALSIZECONTROL = &H40
Const SS_REALSIZEIMAGE = &H800
Const SS_CENTERIMAGE = &H200
Const STM_SETIMAGE = &H172

Lib "Shell32"

hIcon=ExtractAssociatedIconA(hInst,pszIconPath,piIcon)

Lib "User32"

DestroyIcon hIcon

in vb not vba

hIcon = ExtractIcon(Me.hWnd, "C:\Windows\System32\shell32.dll", 31) 'Recycle Bin
DrawIcon Picture1.hdc, 0, 0, hIcon

SubClass Window

Public origWndProc As Long

Public Sub SetHook(hwnd, bSet As Boolean)

If bSet Then

origWndProc = SetWindowLongPtr(hwnd, GWL_WNDPROC, AddressOf AppWndProc)

ElseIf origWndProc Then

Dim lRet As Long

lRet = SetWindowLongPtr(hwnd, GWL_WNDPROC, origWndProc)

origWndProc = 0

End If

End Sub

hStatic =CreateWindowEx(WS_EX_LAYERED+ WS_EX_NOACTIVATE+ WS_EX_TOPMOST,"STATIC", "", WS_POPUP Or SS_BITMAP, 0,0, 0, 0, 0, hwnd, GetModuleHandle(vbNullString), 0&
'hwnd.AccessApp
SetLayeredWindowAttributes(hStatic,0, 100, LWA_ALPHA)

SetWindowLongPtr hStatic, GWL_HWNDPARENT, hForm

hBitmap=LoadImage(Application.hwndAccessApp,"D:\image1.Bmp",IMAGE_ICON, 32, 32, &H0)

SendMessag hStatic,STM_SETIMAGE,IMAGE_BITMAP, ByVal hBitmap)

SetActiveWindow hForm

HookMsgbox :

Sub Sample()
HookIt = SetWindowsHookEx(WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
Msgbox "Prompt"
End Sub


Private Const WH_CBT=5
Const HCBT_CREATEWND=3
Const GWL_STYLE As Long = -16
Const GWL_EXSTYLE = (-20)
Const LWA_ALPHA = &H2&
Const GWL_WNDPROC=(-4)
Const WS_EX_LAYERED=&H80000
Const WM_COMMAND=&H1
Const WM_NCDESTROY=&H82
 
Type POINT_TYPE
x As Long
y As Long
End Type


Private Function HookProc(ByVal idHook As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim curStyle As LongPtr

if idHook = HCBT_CREATEWND Then
If GetClass(wParam) = "#32770" Then
hwndMsgBox = WParam
'Style = GetWindowLongPtr(hWnd, -16) And Not &HC00000
'SetWindowLongPtr hWnd, -16, Style
'DrawMenuBar hWnd
curStyle = GetWindowLongPtr(WParam, GWL_EXSTYLE)
NewStyle = curStyle Or WS_EX_LAYYERED
SetWindowLong WParam,GWL_EXSTYLE, NewStyle
SetLayeredWindowAttributes(hwndMsgBox,0, 255, LWA_ALPHA)
 MakePolygon hwndMsgBox
OldMBoxWinProc =SetWindowLongPtr(WParam, GWL_WNDPROC, AddressOf NewMsgBxWindowProc)
UnhookWindowsHookEx HookIt
End If
End If
 HookProc = CallNextHookEx(HookIt, idHook, ByVal WParam, ByVal lparam) End Function


Private Function NewMsgBxWindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal WParam As LongPtr, ByVal lparam As LongPtr) As LongPtr
 On Error Resume Next
Select Case uMsg
Case WM_NCDESTROY, WM_COMMAND SetWindowLongPtr hwnd, GWL_WNDPROC, OldMBoxWinProc
End Select
NewMsgBxWindowProc = CallWindowProc(OldMBoxWinProc, hwnd, MSG, WParam, lparam)
End Function

Function MakePolygon(hwnd As LongPtr)
Dim ptarr(0 To 28) As POINT_TYPE
ptarr(0).x = 104: ptarr(0).y = 30
ptarr(1).x = 504: ptarr(1).y = 30
ptarr(2).x = 404: ptarr(2).y = 180
ptarr(3).x = 4: ptarr(3).y = 180
ptarr(4).x = 104: ptarr(4).y = 30
hRegion=CreatePolygonRgn(ptarr(0),28, 1)
SetWindowRgn hwnd,hRegion,True
End Function

SubClassing The Form

شوگر مامی" به زن ثروتمندی گفته می شود که با مردان جذاب، جوان و پویا وارد رابطه می شود، البته به طور قطع هر پسری تمایل به برقراری رابطه با شوگرمامی ها ندارد.

برای SubClass کردن پنجره حتما پنجره VBE بسته باشد و در صورت لزوم انجام تغییرات حتما از برنامه خارج شده و دوباره وارد شوید.

WikiBooks : SubClassing

Declare Function SetClipboardViewer Lib "user32" (ByVal hwnd As Long) As Long

Private PrevProc As LongPtr

Private Const WM_SETTEXT=&HC As Long

Function WindowProc(ByVal Hwnd As LongPtr,Byval uMsg As Long,ByVal wParam As LongPtr,ByVal lParam As LongPtr)

Select Case uMsg 

 ' SendMessageList

     Case WM_LBUTTONUP

     Case WM_SETTEXT

در این پیام wparam استفاده نمی شود و lparam هم رشته است .

sTemp=StrConv("SubClassing" & Chr(0),VbFromUnicode)

lParam=lParam & "..." & sTemp

 End Select

WindowProc=CallWindowProc(PrevProc,Hwnd,uMsg,wParam,lParam)

End Function

Function SubClassForm(Frm As Form)

PrevProc=SetWindowLongPtr(Frm.hwnd,(-4),AddressOf WindowProc)

End Function

Function UnSubClassForm(Frm As Form)

SetWindowLongPtr Frm.hwnd,(-4),PrevProc

End Function

Form 1 : 

Event:Load

SubClassForm Me

Event UnLoad

UnSubClassForm Me

CommandButton0

SendMessage Me.hwnd,&HC,0&,Byval "This is a test..."

توجه : اگر توابع درست فراخوانی نشوند یا اینکه دیتا تایپ اشتباه باشد یا در جایی که نیاز است ByVal استفاده نشود ، Crash خواهد داد ( وباید از Task Manager یا زدن  کلید ترکیبی ctrl+shift+esc  اکسس اجرایی را ببندید ) و باعث آسیب به دیتا بیس خواهد شد هر چند اکسس قبلش یک BackUp می سازد.

برای اصلاح در محیط VBE حتما از فایل خارج شوید و دوباره وارد فایل شوید و گرنه کلوز باتن فرم در اجرای مجدد فریز شده و می بایست به اپلیکیشن دیگر فوکس کرده یا به دسکتاپ Move کنید و سپس به اکسس بروید . در این صورت پیام ویندوزی هم دریافت نمی گردد.

Private Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI

End Type

Private hXLDesk As LongPtr
Private lPrevWnd As LongPtr
Private bXitLoop As Boolean

Public Sub InstallHook()

If lPrevWnd = 0 Then 

hXLDesk =FindWindowEx(FindWindow("XLMAIN",Application.Caption),0, "XLDESK", vbNullString)

lPrevWnd=SetWindowLongPtr(hXLDesk,(-4), AddressOf TransitionalProc)

' Msg pump for safe subclassing !!!! 

MessageLoop

End If

End Sub

Public Sub ClearHook()

'cleanUp.

bXitLoop = True

SetWindowLongPtr hXLDesk,(-4),lPrevWnd 

lPrevWnd = 0

hXLDesk = 0

End Sub 

Private Sub MessageLoop()

Dim aMsg As MSG

bXitLoop = False

On Error Resume Next

'ensure all Msgs are posted during the subclassing.

' winuser-getmessage

Do While GetMessage(aMsg, 0, 0, 0) And bXitLoop = False

DoEvents

PostMessage 0,aMsg.message, aMsg.wParam, aMsg.lParam

Loop

End Sub

Dim loword As Long,hiword As Long

Case WM_SETCURSOR
         GetHiLoword lParam, loword, hiword
If hiword = WM_MOUSEMOVE Then
GetCursorPos tPt
End If

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

MINMAXINFO

The minimum tracking width (x member) and the minimum tracking height (y member) of the window. This value can be obtained programmatically from the system metrics SM_CXMINTRACK and SM_CYMINTRACK

Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any,ByVal cbCopy As Long)

Type POINTAPI

x As Long : y As Long

End Type

Type MINMAXINFO

ptReserved As POINTAPI :ptMaxSize As POINTAPI

ptMaxPosition As POINTAPI :ptMinTrackSize As POINTAPI

ptMaxTrackSize As POINTAPI

End Type

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long,ByVal wParam As Long,ByVal lParam As Long) As Long 

Dim mmiT As MINMAXINFO

' Copy parameter to local variable for processing

کپی کردن lparam که منبع است به متغیر mmiT که مقصد است 

CopyMemory mmiT, ByVal lParam, LenB(mmiT)

' Minimium width and height for sizing mmiT.ptMinTrackSize.x = 128

mmiT.ptMinTrackSize.y = 128

' Copy modified results back to parameter

CopyMemory ByVal lParam,mmiT, LenB(mmiT) 

End Function 

Declare PtrSafe Function SetWindowSubclass Lib "comctl32" (ByVal hWnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr, Optional ByVal dwRefData As LongPtr) As LongPtr

Declare PtrSafe Function RemoveWindowSubclass Lib "comctl32" (ByVal hWnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr) As LongPtr

Declare PtrSafe Function DefSubclassProc Lib "comctl32" (ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr

TIMER  : 

A millisecond (from milli- and second; symbol: ms) is a thousandth (0.001 or 10⁻³ or ¹/₁₀₀₀) of a second.

Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr,ByVal nIDEvent As Long,ByVal uElapse As Long,ByVal lpTimerFunc As LongPtr) As LongPtr

Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr,ByVal nIDEvent As Long) As Long

Public TimerID As LongPtr

Dim lCount As Long
Sub SetTheTimer()
  lCount = 0
TimerID = SetTimer(0&, 0&, 500, AddressOf TimerProc)
End Sub

Sub KillTheTimer()
  KillTimer 0, TimerID
End Sub

Function TimerProc(ByVal hwnd As LongPtr,ByVal wMsg As Long,ByVal idEvent As LongPtr,ByVal dwTime As Long)
On Error Resume Next 'necessary

lCount = lCount + 1

    Debug.Print "Timer callback " & lCount

    If lCount = 10 Then KillTimer 0, TimerID

End Function

در یکی از برنامه‌های خبری شبکه بی‌بی‌سی عربی، وقتی از «مهدی عفیفی» به عنوان کارشناس درباره مسائل اوکراین پرسش شد، وی پس از مدت کوتاهی بعد از شروع صحبتش درباره این موضوع، ناگهان گفت: «موضوعی که می‌خواهم به آن اشاره کنم این است که بی‌بی‌سی دو سال است که پول برنامه‌های ما را نداده! مسئولان بی‌بی‌سی کجا هستند؟ چگونه می‌خواهید عدم پرداخت پول ما را توجیه کنید؟»