نمایش رکوردهای انتخاب شده ی فرم در 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 : در پی اهانت یک افسر هندی به سردار سلیمانی و رهبر انقلاب،  مردم منطقه بدگام کشمیر به خیابان‌ها ریختند و در حمایت از سردار سلیمانی شعار سردادند و با ماموران پلیس درگیر شدند و اقدام مامور هتاک را محکوم کردند. یکی از افسران هندی در حین عملیات سرشماری یکی از شهرهای کشمیر با ورود به منزل یکی از شهروندان عکس شهید سلیمانی و رهبرانقلاب را که در خانه او بود به آتش می‌کشد. 

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

ماده 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]

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 )  شما را در تله می اندازد و باعث خطا می شود 

ارسال تکست به کلاس 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

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

Msgbox در اکسس

A twip is defined as being 1⁄1440 of an inch (approximately 0.0176 mm). 

(1÷1,440)×25.4=0.0176388889

1 Inch = 72 Point

1.047"×72=75.384 Point

کنترل های اکسس کنترل های استاندارد VB نیستند . و زمان اجرا در صفحه رسم می شوند.بر خلاف کنترل های VB ،  آنها هندل یونیک و واحدی ندارند. 

Access controls are not standard VB controls.  They're drawn on the screen at runtime. As such, unlike VB controls, they do not have a unique hWnd.

Private Declare Function apiGetFocus Lib "user32" _
        Alias "GetFocus" _
         () As Long
    On Error Resume Next
         
Function fhWnd(ctl As Control) As Long
    Else
    ctl.SetFocus
    If Err Then
        fhWnd = 0
End Function
        fhWnd = apiGetFocus
    End If
    On Error GoTo 0
End Function

getdevicecaps  

const LOGPIXELSX = 88

const LOGPIXELSY = 90

bitmap-functions

loword =Clng(lparam And 255×257)

Hiword=Clng(lparam \ 255×257)

&FFFF(Hex)=65535(Decimal)

Hext (FFFF)To Dec

F=15

16^(3)×15+16^(2)×15+16^(1)×15+16^(0)×15=65535

FORM.WINDOWLEFT

Returns an Integer indicating the screen position in twips of the left edge of a form relative to the left edge of the Microsoft Access window. Read-only.

 یک عدد صحیح را بر می گرداند که موقعیت صفحه ( به twips ) از لبه چپ یک فرم نسبت به لبه چپ پنجره Microsoft Access نشان می دهد و فقط خواندنی است.

یک اینچ برابر 96 پیکسل است بنابراین 0.8 اینچ برابر 76.8 پیکسل است. (  96 × 0.8 )

در اکسس مقدار left یا Top و ... به واحد twips داده میشود برای تبدیل twips به pixle لازم است مقدار برگشتی در (1440÷96) ضرب گردد.فرضا اگر مقدار Top عدد 0.8 اینچ باشد در تکست باکس عددد 1440×0.8 یا 1152 مشاهده می گردد برای تبدیل به پیکسل عدد 1152 را در 1440÷96 ضرب می کنیم و می شود 76.8 پیکسل .

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

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

به برکت نظام مقدس : به منظور تسهیل در خرید مسکن و کاهش آورده متقاضیان، انجمن خانه عمران پیشنهاد ساخت ۳۰ درصد از واحد‌های نهضت ملی مسکن در قالب واحد کوچک متراژ را داده است.سفره ایرانی هر سال کوچکتر از دیروز!!!

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

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

مطالب زیر تکرار مکررات است 

نمونه ای از هوک کردن ساده پنجره Msgbox با کلاس 32770# که در سایر سایت های خارجی قرارداده و پاس داده می شود مثل بنده ، تست شده و عمل میکند البته توابع دیگری هم دارد که آنها ذکر نشده مثل GetClass که از تابع GetClassNameA کتابحانه user32.Dll  استفاده شده ( کارِ این تابعِ API ، پرکردنِ بافری است که مشخص کرده اید و جواب این تابع ، تعداد کاراکترهایی است که در بافر پر کرده.) برای گرفتن Text مربوط به Button یا هر کنترل دیگر در تابع زیر از GetWinText استفاده شده  و در این تابع یا Function از این کتابخانه و تابع با نام GetWindowTextA بهره برده ایم و عملکرد این تابع مثل GetClassNameA می باشد.یکسری ثابت ها در زیر بیان شده مثل GW_CHILD و GW_HWNDNEXT که به ترتیب 2 و 5 هستند و ثابت WH_CBT نیز (4-) است.

MsgboxGrailly "www.accessvba.blogsky.com", vbYesNo, "Salam"

Subclass کردن پنجره Msgbox  با تابع ساختگی تصویر بالا و  ارسال تکست  "WM_RBUTTONDOWN"به ناحیه Caption  زمان RightClick  : تماماً از سایت های بیگانه استخراج شده ولی با مطالعه و تست موفق طبق تصویر زیر

ناحیه Static ارتفاعش زیاد نیست بنابراین نمی توان بیش از حدود 30 تا 36 درجه چرخش داد و یه مشکل وجود دارد اگر سایز فونت ( در ارسال پیام به پنجره با LOGFONT ) بیشتر شود طول پنجره زمان نمایش بیشتر نخواهد شد مگر اینکه قبل از ارسال عرض متن مشخص شود و با تابع MoveWindow یا SetWindowPos تنظیم گردد.

Case &H2 'WM_DESTROY

        DeleteObject hFont

        SetWindowLongPtr hWnd, GWL_WNDPROC, lOrigWinProc

        Exit Function

Font

Public Const WM_SETFONT = &H30

Dim lf As LOGFONT

Dim hFont

 lf.lfHeight = 16

 lf.lfEscapement = 3

If GetClass(hwndChild) = "Static" Then

                hFont = CreateFontIndirect(lf)

                SendMessageA hwndChild, WM_SETFONT, hFont, 1

End If

bitmap

stm-setimage  ' Static ارسال آیکون به ناحیه 

senddlgitemmessagea 'ارسال آیکون

ms940367(v=msdn.10)

wm-nextdlgctl 'set the keyboard focus to a different control in the dialog box.

تنظیم فوکس کیبورد به یک کنترل متفاوت در جعبه دیالوگ مثل Msgbox 

getdlgitem ' If the function succeeds, the return value is the window handle of the specified control.

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

WM_USER=&H400
BM_SETIMAGE = &HF7
STM_SETICON = &H170
STM_GETICON = &H171
STM_SETIMAGE = &H172

dm-getdefid  ''the low-order word contains the control identifier 'lparam & wparam must be zero

loword(clng(SendMessage wparam,DM_GETDEFID,0,0))

از clng استفاده شد تا خطا ندهد ( عدد بزرگ است ) . مسیج بالا قسمت low word آن البته اگر باتن فشاری نباشد حاوی نشانگر کنترل است و در آرگومان دوم تابع getdlgitem هم می توان استفاده نمود.

DM_GETDEFID = (WM_USER + 0)

DM_SETDEFID = (WM_USER + 1) 

مطالعه کنید و لذت ببرید 

To create a SysLink, call the CreateWindow or CreateWindowEx function, specifying the WC_LINK window class. 95741118

wm-notify

commctrl-nmlink

commctrl-litem

nm-click-syslink

Type NMHDR
hwndFrom As LongPtr
idFrom As Long
uCode As Lonh
End Type

Type LITEM
mask As Long
iLink As Integer
state As Long
stateMask As Long
szID As String
szUrl As String
End Type

Type NMLINK
hdr As NMHDR
item As LITEM
End Type

hWndBtn = CreateWindowEx(0, "Button", "MyButton", WS_CHILD Or WS_VISIBLE, 32, 32, 64, 64, hwnd, 0, 0, 0)

hWndEdit = CreateWindowEx(WS_EX_CLIENTEDGE, "Edit", "MyEdit", WS_CHILD Or WS_VISIBLE, 200, 10, 100, 100, hwnd, 0, 0, 0)

hWndBtn = CreateWindowEx(WS_EX_CLIENTEDGE, "Static", "MyLabel", WS_CHILD Or WS_VISIBLE, 10, 100, 100, 40, hwnd, 0, 0, 0)

Public Function WindProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

     If wMsg = WM_COMMAND Then

          If lParam = hWnd_Btn Then MsgBox "Button was clicked!"

    End If

   WindProc = CallWindowProc(WndProcOld&, hwnd&, wMsg&, wParam&, lParam&)

    End Function

Private Function loword(DWord As Long) As Integer

    If DWord And &H8000& Then

        loword = DWord Or &HFFFF0000

    Else

        loword = DWord And &HFFFF&

    End If

End Function

'Create SysLink (HyperLink) Control

Const WS_CHILD = &H40000000
Const WS_VISIBLE = &H10000000
Const WC_LINK = "SysLink"
Const ICC_LINK_CLASS = &H8000&
Dim hwnd As Long, hSysLink As Long Dim tIccex As InitCommonControlsEx Dim sCaption As String
With tIccex
.Size = LenB(tIccex)
.ICC = ICC_LINK_CLASS
End With
If InitCommonControlsEx(tIccex) Then sCaption = "<a href=" & Chr(34) & "www.google.com" & Chr(34) & ">click here</a>"
hSysLink = CreateWindowEx(0, StrPtr(WC_LINK),StrPtr(sCaption), WS_CHILD + WS_VISIBLE, _ 20, 20, 300, 20, hwnd, 0,vbNullString, 0)
End If
End Sub

createfontindirecta  'GDI32.DLL

getdevicecaps 'GDI32.DLL

getdc 'USER32.DLL

Dim PixelsPerInch       As Long
    PixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSY)

Private Const LOGPIXELSY As Long =90

-((PointSize * PixelsPerInch) \ 72)

alphablend

taskdialogindirect

جمیله علم‌الهدی، همسر رئیسی : از من خواستند مشابه کتاب میشل اوباما را بنویسم ، همسرم هم تایید کرد / مرز اصلی جنگ نرم ، عفاف و حجاب است

SendDlgItemMessage(hwnd,ID_BTN,BM_CLICK,0,0)

Type NMHDR
hwndFrom As LongPtr
idFrom As Long
uCode As Long
End Type

Type LITEM
mask As Long
iLink As Integer
state As Long
stateMask As Long
szID As String
szUrl As String
End Type

Type NMLINK
hdr As NMHDR
item As LITEM
End Type

اطلاعات در lparam است لذا برای کپی اطلاعات به حافظه و استفاده از اطلاعاتی که نیاز داریم از تابع RtlCopyMemory استفاده می نمائیم که در اینجا با نام استعار CopyMemory اظهار شده.با آرگومانهای زیر 

CopyMemory Destination,Source,Length

'Be aware that the last parameter, Length, is the number 'of bytes to copy into Destination, not the size of 'the Destination.

'use the CopyMemory API to Get a Copy into the 'Variable we setup

Select Case uMsg
       Case WM_NOTIFY
             Dim nmh As NMHDR
             CopyMemory nmh, ByVal lParam, Len(nmh)
                     Select Case lParam.uCode
                          Case NM_CLICK
                         Case NM_RETURN
                             Dim nml As NMLINK
                            CopyMemory nml,ByVal lParam,Len(nml)

                   End Select

End Select

using-window-procedures

اِفاضات در 2بهمنِ1400

ایرنا نوشت: معاون پارلمانی رئیس جمهور گفت: برخی هیاهو می‌کنند که داریم کشور را به چین و روسیه می‌فروشیم در صورتی که اصلاً این گونه نیست و هیچ‌گاه این اتفاق نخواهد افتاد.... ( در ساخت پالایشگاه اراک چینی ها هم سهیم بودند و مردان و زنان چینی هم در پروژه کار می کردند سال های 88 تا 93 ) 

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

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

در کد زیر که در تایمر فرم اصلی قرار داده شده ، پنجره با کلاس 32770# ( پنجره ویندوزی ) و کپشن Security را پیدا میکند سپس در این دایالوگ باکس ، هندل باتن با کپشن Ok را گرفته و پیام کلیک روی آن را ارسال می کند در ضمن اگر کپشنِ ویندو ، Choose File بود هندل کلاس باتن با کپشن Open را گرفته و تکستی را با پیام WM_SETTEXT به کنترل EditBox کلاس ComboBoxEx32 که کلاس ویندوزی است ارسال می نماید و در آحر پیام فشردن کلید را به باتن Open ارسال می نماید.

Private Sub Timer1_Timer()
Dim x As Long, editx As Long
Dim Button As Long

x = FindWindow("#32770", "Security Alert")
If X Then
    Button = FindWindowEx(x, 0&, "Button", "&Yes")
    If Button Then
        Call SendMessageLong(Button, WM_KEYDOWN, VK_SPACE, 0&)
        Call SendMessageLong(Button, WM_KEYUP, VK_SPACE, 0&)
    End If
Else
    x = FindWindow("#32770", "Choose file")
    If X Then
        editx = FindWindowEx(x, 0&, "ComboBoxEx32", vbNullString)
        If editx Then 
            Button = FindWindowEx(x, 0&, "Button", "&Open")
            If Button Then
                Call SendMessageByString(editx, WM_SETTEXT, 0&, Text5)
                Call SendMessageLong(Button, WM_KEYDOWN, VK_SPACE, 0&)
                Call SendMessageLong(Button, WM_KEYUP, VK_SPACE, 0&)
                Command3_Click ' < whatever this does?
            End If
        End If
    End If
End If
End Sub

تذکر مهم : اگر کدها کار نکرد یا سیستم دچار هنگ یا Crash شد به این دلیل است که یا نحوه اظهار تابع اشتباه است یا کتابخانه که بعد از "Lib" ذکر شده Wrong است و در win64 یا vb7 هستید ولی کدهای شما مربوط به win32 است یا ByVal نگذاشته اید در ابتدای پارامترها و یا دیتا تایپ شما در جایی که نباید Long باشد از Long استفاده شده در حالیکه شما در سیستم 64بیتی هستید پس نحوه اظهار کردن توابع API در WIN32 و WIN64 متفاوت هستند و دیتا تایپ ها نیز مهم هستند لذا اگر سیستم هنگ کرد باید تابع را از اول تا آخر بررسی کنید هم نام تابع و هم آرگومانهای داخلش ، اگر در تابعی فقط آرگومان اول برای شما مهم است و بقیه را احتیاج ندارید باید از کلمه Optional استفاده کنید و اگر پارامترهایی بعد از این نیز دارید باید همه Optional شوند. مثل  ( در ویندوز 32 بیتی )  : 

Public Declare Function FindWindowExA Lib "user32" (ByVal hwnd As Long,Optional ByVal hwndAfter As Long,Optional ByVal sClass As String,Optional ByVal sCaption As String)

اگر بصورت Pivate یا خصوصی بجای Public اظهار شود فقط در همان رویه ( Procedure ) یا استاندارد ماژول( STD Module ) می شود استفاده کرد و دسترسی به این تابع در جای دیگر محیط VBE را به شما نخواهد داد. نحوه اظهار تابع بالا درVB7 یا WIN64 بدین صورت است که کلمه PtrSafe قبل از Function قرار می گیرد و دو پارامتر hwnd اول دیتا تایپ LongPtr بجای Long می گیرند.( اساتید تازه کار بین کلمات حتما فاصله یا Space باشد !!!)

<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="figure" insertBeforeMso="TabHome" keytip="S">
        <group id="Group1" label="SetLayeredWindowAttributes">
          <button id="ShowFormButton" label="sfbtn" keytip="S"
                  supertip="xxxxx" onAction="onAction" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>

Const GWL_EXSTYLE = (-20)
Const WS_EX_LAYERED = &H80000
Const LWA_COLORKEY = &H1

Private Const LOGPIXELSX = 88 ' Logical pixels / inch in X
Private Const LOGPIXELSY = 90 ' Logical pixels / inch in Y

hDC = GetDC(hWnd)
  XPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
  YPixelsPerInch = GetDeviceCaps(hDC, LOGPIXELSY)
  ReleaseDC hWnd, hDC

Image1.BackColor = vbRed 
BackColor = Image1.BackColor

ExStyle = GetWindowLong(hWnd, GWL_EXSTYLE)
  ExStyle = ExStyle Or WS_EX_LAYERED
  Call SetWindowLong(hWnd, GWL_EXSTYLE, ExStyle)
  Call SetLayeredWindowAttributes(hWnd, BackColor, 0, LWA_COLORKEY)

Private rbRibbonUI As IRibbonUI  

Sub onLoad(ribbon As IRibbonUI)
  Set rbRibbonUI = ribbon 
  rbRibbonUI.Invalidate 
End Sub

Sub onAction(control As IRibbonControl)
 On Error Resume Next
  
  Select Case control.ID
    Case "ShowFormButton"
      
    Case Else
      Beep 
      MsgBox Prompt:=control.ID & "rrrr", Buttons:=vbCritical + vbSystemModal, Title:="eee"
      Exit Sub
  End Select
    Exit Sub

سایز فونت در DC 

Type FNTSIZE
Cx As Long
Cy As Long
End Type

Dim textSize As FNTSIZE

'The GetTextExtentPoint32 function 'computes the width and height of the 'specified string of text.

GetTextExtentPoint32 tempDC, StrPtr(xText), Len(xText), textSize 

When the character orientation and the print orientation are 90 degrees apart for the same string, this function returns the dimensions of the string in the SIZE structure as { cx : 18, cy : 116 }.

LOGPIXELSX = 88     ' horizontal DPI (assumed by Windows)
    LOGPIXELSY = 90     ' vertical DPI (assumed by Windows)

گرفتن ابعاد صفحه با تابع getsystemmetrics

Declare Function GetSystemMetrics32 Lib "User32" _
    Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Const SM_CXSCREEN=0
Const SM_CYSCREEN=1

Sub ScreenRes()
Dim w As Long, h As Long
    w = GetSystemMetrics32(0) ' width in points
    h = GetSystemMetrics32(1) ' height in points

End Sub

lngExStyle=WS_EX_STATICEDGE '&H20000

lngExStyle=lngExStyle+WS_EX_WINDOWEDGE '&H100

lngExStyle=lngExStyle+WS_EX_TRANSPARENT '&H20

hStatic = CreateWindowEx(lngExStyle,"STATIC", "Text" , WS_VISIBLE +WS_CHILD + SS_BITMAP,
100, 100, 200, 200, hWnd, (HMENU)10000, Application.hwndAccessApp, 0&)

' SetWindowLongPtr hWndCreate,GWL_EXSTYLE,GetWindowLongPtr(hWnd,GWL_EXSTYLE) Or WS_EX_LAYERED

'SetLayeredWindowAttributes hWndCreate, 0, (255 * 20) /100,LWA_ALPHA)

'load bitmap into static

SendMessage hStatic,STM_SETIMAGE, (WPARAM)IMAGE_BITMAP, (LPARAM)hBitmap

'destroy bitmap when it is not required any more

DeleteObject hBitmap

درگ فایل داخل فرم و گرفتن آدرس آن : 

Declare Sub DragAcceptFiles Lib "shell32.dll" _
        (ByVal hWnd As Long, _
        ByVal fAccept As Long)

Declare Sub DragFinish Lib "shell32.dll" _
        (ByVal hDrop As Long)

Declare Function DragQueryFile Lib "shell32.dll" _
        Alias "DragQueryFileA" (ByVal hDrop As Long, _
                                ByVal lFile As Long, _
                                ByVal lpFileName As String, _
                                ByVal cbLen As Long) As Long

'SubClass Window & UnSubClass 

'Call DragAcceptFiles + Subclass win

Sub SubClassHookForm()

DragAcceptFiles(frm.hWnd, 1)
lpPrevWndProc = SetWindowLong(frm.hWnd, GWL_WNDPROC, _
AddressOf WindowProc)
End Sub
'Remove Hook And Cancel Drag Files
Sub SubClassUnHookForm()
SetWindowLong(frm.hWnd, GWL_WNDPROC, lpPrevWndProc)
DragAcceptFiles(frm.hWnd, 0)
End Sub

dragqueryfilew

Const GetNumOfFiles=&HFFFF

Case WM_DROPFILES

'Get the number of dropped files
NumOfFiles = DragQueryFile(hDrop, GetNumOfFiles, 0&, 0)

For i=0 To NumOfFiles

l=DragQueryFile(hDrop:wParam,i,txt,len(txt)

s=s &;Left(Buff$,l)

Next

Write in WindowProc :

'Win MSG

Dim rcClient As RECT
Dim ptClientUL As POINTAPI
Dim ptClientLR As POINTAPI
static ptsBegin As PONITAPI

static ptsEnd As POINTAPI

static ptsPrevEnd As POINTAPI

??static fPrevLine As Boolean= FALSE

Select Case uMsg

case WM_LBUTTONDOWN

SetCapture hwndMain

GetClientRect hwndMain,rcClient 

ptClientUL.x = rcClient.left

ptClientUL.y = rcClient.top
ptClientLR.x = rcClient.right + 1

ptClientLR.y = rcClient.bottom + 1

ClientToScreen hwndMain,ptClientUL

ClientToScreen hwndMain,ptClientLR

SetRect rcClient, ptClientUL.x,ptClientUL.y, ptClientLR.x, ptClientLR.y

ClipCursor rcClient

ptsBegin = MAKEPOINTS(lParam)

'lparam And &HFFFF

'lparamOr & HFFFF

Exit Function

Case WM_MOUSEMOVE

case WM_MOUSEMOVE
  Select Case wParam
       Case MK_LBUTTON  ' 1 wm-lbuttondown
          hdc = GetDC(hwnd)

'wingdi-setrop2  ... gdi32.setrop2

     SetROP2 hdc, R2_NOTXORPEN ' 10

if  fPrevLine Then

MoveToEx hdc, ptsBegin.x, ptsBegin.y,0&)

LineTo hdc, ptsPrevEnd.x,ptsPrevEnd.y

End if 

ptsEnd = MAKEPOINTS(lParam) 'Get loword & Hiword
MoveToEx hdc, ptsBegin.x, ptsBegin.y,0&
LineTo hdc, ptsEnd.x, ptsEnd.y

fPrevLine = TRUE
ptsPrevEnd =ptsEnd
ReleaseDC hwnd, hdc

End Select

Exit Function

Case WM_LBUTTONDOWN

ClipCursor Null

ReleaseCapture

Exit Function

End Select

تابع SendInput

sendinput

mouse_event

input

'SendInput
Type INPUT_TYPE
Public dwType As Integer
Public xi As MOUSEINPUT
End Type

MOUSEEVENTF_LEFTDOWN = &H2
MOUSEEVENTF_LEFTUP = &H4
MOUSEEVENTF_MOVE=&H1
MOUSEEVENTF_RIGHTDOWN=&H8
MOUSEEVENTF_RIGHTUP=&H10

Dim inputEvents(0) As INPUT_TYPE

inputEvents(0).xi.dx = 0

inputEvents(0).xi.dy = 0

inputEvents(0).xi.mouseData = 0

inputEvents(0).xi.dwFlags = M_MOVE + M_LD + M_LU

inputEvents(0).xi.dwtime = 0

inputEvents(0).xi.dwExtraInfo = 0

inputEvents(0).dwType = INPUT_MOUSE

SendInput(1, inputEvents(0), Len(inputEvents(0)))

.

تابع ShowWindow و GetWindow در API

showwindow

Dim IE As Object
    Set IE = CreateObject("internetexplorer.application")
    IE.Visible = True
    ShowWindow IE.hwnd, SW_SHOWMAXIMIZED
    IE.Navigate "http://www.google.com"
    
    
    Do While IE.ReadyState <> 4: DoEvents: Loop
    Do While IE.Busy: DoEvents: Loop

' Close internet explorer

IE.Visible=True

ShowWindow IE.hwnd,3

Sleep 600

SendMessageA IE.hwnd,&H10,0,0

findwindow

getwindow

hWndP=FindWindow(vbNullString,vbNullString)
'PARENT WINDOW
Do While hWndP <> 0
 hWndP=GetWindow(hWndP,GW_HWNDNEXT)
Loop 

enumchildwindows

برای بدست آوردن کلاس پنجره از تابع GetWindowClassA و کپشن اگر Null نباشد از تابع GetWindowTextA استفاده می نمایند

ret=GetClassName(hwnd,Buffer_Variable,len_Buffer)

if Succeed ...ret=NumberOfCharacterSendToBufferVariableYouSpecified

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

Buff$=Space(80) ' Buffer

X=Left(Buff$,Len(Buff$)) 

X=Left(Buff$,Instr(Buff$,Chr(0))-1)

getsystemmenu

تابعی برای بدست آوردن هندل منوی سیستم ( همان دکمه هایی که بصورت max min close در TitleBar می بینید چه خود برنامه چه فرم یا گزارشات)

destroymenu

تابعی برای محو کردن منوی مشخص شده و آزاد کردن حافظه ای که منو اشغال کرده.

getwindowlongptra : extended-window-styles : window-styles

بازیابی اطلاع پنجره مشخص شده

window-styles : 

WS_MAXIMIZEBOX

WS_MINIMIZEBOX

WS_SYSMENU

WS_TABSTOP

setwindowlongptra

تغییر ویژگی  پنجره مشخص شده 

lstyle=GetWindowLongPtrA(hwnd,GWL_STYLE)

lstyle=lstyle And Not WS_MINIMIZEBOX

SetWindowLongPtrA hwnd,GWL_STYLE,lstyle

setwindowpos

تغییر سایز و موقعیت برنامه در صفحه

Type RECT

Left As Long

Top As Long

Right As Long

Bottom As Long

End Type

SetWindowPos hwnd, 0, tRect.Left, tRect.Top, tRect.Right - tRect.Left, tRect.Bottom - tRect.Top, SWP_NOREPOSITION Or SWP_NOZORDER Or SWP_FRAMECHANGED

Z-Order موقعیت پنجره را در دسته ای از پنجره های همپوشانی نشان می دهد.

پارامتر دوم ( hwndinsertafter ) :

هندلی به پنجره  که از پنجره ای در z order پیشی گرفته.این پارامتر باید یا هندل پنجره یا یکی از مقادیر مثل زیر باشد.

HWND_TOP : قرار گرفتن پنجره در بالای زِد اُردِر

SetWindowPos Me.hWnd,HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE

گرفتن هندل پنجره ها ، البته با تابع EnumChildWindows اینکار راحت تر است و به تابع زیرآن نیازی نیست 

EnumChildWindows hwnd,AddressOf EnumChildWnd,1

Function BrowseHandle(hwndParent As LongPtr)
Dim hwndChild As LongPtr
hwndChild = GetWindow(hwndParent, GW_CHILD)
Do While hwndChild
Debug.Print hwndChild & "... Class Name :" & GetClass(hwndChild) & "... Window Text : " & GetWinText(hwndChild)
BrowseHandle hwndChild
hwndChild = GetWindow(hwndChild, GW_HWNDNEXT)
If GetClass(hwndChild) = "Internet Explorer_Server" Then DD = hwndChild
Loop
End Function



984678... Class Name :OSUIBlank... Window Text : 
525766... Class Name :OSUIBlank... Window Text : 
1050060... Class Name :NUIScrollbar... Window Text : Horizontal
1246666... Class Name :NetUIHWND... Window Text : 
656882... Class Name :OSUI... Window Text : SUI
656874... Class Name :NetUINativeHWNDHost... Window Text : RecNavHost
591334... Class Name :NetUIHWND... Window Text : 
591330... Class Name :NetUICtrlNotifySink... Window Text : 
591336... Class Name :RICHEDIT60W... Window Text : Search
591358... Class Name :NetUICtrlNotifySink... Window Text : 
525792... Class Name :RICHEDIT60W... Window Text : 1 of 1
525774... Class Name :OSUIBlank... Window Text : 
722376... Class Name :NUIScrollbar... Window Text : Vertical
919166... Class Name :NetUIHWND... Window Text : 
919012... Class Name :OSUIBiDiBlank... Window Text : 
656920... Class Name :OFormSub... Window Text : 
591380... Class Name :OFormSub... Window Text : 
657000... Class Name :OGrid... Window Text : 
722518... Class Name :Shell Embedding... Window Text : 
1115700... Class Name :Shell DocObject View... Window Text : 
656938... Class Name :Internet Explorer_Server... Window Text : 
656912... Class Name :OFEDT... Window Text : 
1181188... Class Name :OKtRichTbx... Window Text : 
1377904... Class Name :OKttbx... Window Text : 
525842... Class Name :OFormSub... Window Text : 

1. Finding a report window handle
Finding a page handle in the page number display area
3. Sending a page number rewrite message
Send an enter key push message


WindowHandle=FindWindow("OReportPopup", vbNullString)
WindowHandle=FindWindowEx(windowHandle, 0, "OSUI", vbNullString)
WindowHandle=FindWindowEx(windowHandle, 0, "NetUINativeHWNDHost", vbNullString)
WindowHandle=FindWindowEx(windowHandle, 0, "NetUIHWND", vbNullString)

WindowHandle=FindWindowEx(windowHandle,0, "NetUICtrlNotifySink", vbNullString)

Handle = 0
For i = 0 To 1 Step 1
Handle=FindWindowEx(windowHandle,Handle, "NetUICtrlNotifySink", vbNullString)
If Handle <> 0 Then
Dim pageNoHandle As LongPtr

pageNoHandle =FindWindowEx(Handle, 0, "RICHEDIT60W", vbNullString) 

Dim pageNoCount As Integer

pageNoCount = GetWindowText(pageNoHandle, strWindowText, Len(strWindowText))

SetWindowText(pageNoHandle, "3")

???wrong PostMessage(pageNoHandle, WM_KEYDOWN, 13, lngTemp2)

Public Const WM_KEYDOWN = &H100
Public Const WM_KEYUP = &H101
Public Const WM_CHAR = &H102
Call SendMessageLong(x, WM_CHAR, 13, 0&)
Call PostMessage(x, WM_KEYDOWN, VK_RETURN, 0&)


'Click ‘Open’ menuitem
Private Const WM_COMMAND = &H111

Dim hwnd, hWndMenu, hWndSubMenu, MenuItem As Integer

hwnd = FindWindow(vbNullString, "Untitled - Notepad")

hWndMenu =GetMenu(hwnd)

hWndSubMenu =GetSubMenu(hWndMenu, 0)

MenuItem =GetMenuItemID(hWndSubMenu, 1)

SendMessage(hwnd, WM_COMMAND, MenuItem, vbNullString) 

PostMessage hWnd, WM_KEYDOWN, VK_TAB, 0& works here. Thanks

Private Const WM_KEYDOWN = &H100

Private Const WM_KEYUP = &H101 Sub

hWind = FindWindow(vbNullString, "Untitled Notepad")

cWind = FindWindowEx(hWind, 0, 0, 0)

Debug.Print PostMessage(cWind, WM_KEYDOWN, vbKeyA, 0)

Debug.Print PostMessage(cWind, WM_KEYDOWN, vbKeyB, 0)

Debug.Print PostMessage(cWind, WM_KEYDOWN, vbKeyC, 0)

ذخیره کردن هر ویرایشی در Single Form

'Save any edits.
    If frm.Dirty Then
        frm.Dirty = False
    End If

نحوه ساخت ساعت آنالوگ ( ثانیه شمار ) با استفاده از کنترل Line

کل مطالب زیر استخراج شده است .

Line Control In Access : 

The line control displays a horizontal, vertical, or diagonal line on a form or report.

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

You can use Border Width to change the line width. You can use Border Color to change the color of the border or make it transparent. You can change the line style (dots, dashes, and so on) of the border by using the BorderStyle property

می توان Border Width را برای تغییر عرض خط استفاده نمود. می توان Border Color را برای تغییر رنگ Border یا ایجاد شفافیت استفاده نمود.می توان با استفاده از ویژگی BorderStyle حالت مشاهده خط را تغییر داد مثل نقطه چین 

Seconds :

دایره 360 درجه است و هر دقیقه 60 ثانیه پس زاویه بین آنها 6 درجه می شود.

360÷60=6 Degree

در لینک زیر ویژگیهای شئ بیان شده مثل Height ، Top و Width .

در دایره چهار ربع وجود دارد . ربع اول x و y مثبت است و ربع دوم x منفی است.

عرض : وتر در سینوس آلفا

Width in 6 =1×sin(6×6)=0.587785

طول : وتر در کسینوس آلفا

Hieght in 6 =1×cos(6×6)=0.809016

در بالا عرض و ارتفاع در ثانیه 6 بدست آمد ( طول خط یک در نظر گرفته شد و هر ثانیه 6 درجه است )

Function pi() As Double
    pi = 3.14159265358979
End Function

برای 0 تا 15 درجه ربع اول می توان آرایه ای انتخاب کرد که محاسبات در آن قرار گیرد.

Dim Length As Long

Dim Seconds(0 To 15,1 To 3)

Length=ControlName.Height

For t=0 To15

Seconds(t,1)=6×t ' Angle

Seconds(t,2)=Length × sin(6×t×Pi/180)  ' width

Seconds(t,3)=Length × cos(6×t×Pi/180)' height

Next

عرض که مشخص شد ، زمان تغییر ابعاد Top و Height نیز تغییر می کنند.

For i=1 To 15

with ControlName

.Width = Second(t, 2)

.Top =.Top+(Second(t - 1, 3)-Second(t, 3))

.Height =.Height-(Second(t - 1, 3)-Second(t, 3))

End With

Next

در چرخیدن کنترل Line در ربع اول ، به پراپرتی Top اضافه می شود و از پراپرتی Height کم میشود و پراپرتی Width هم حاصلضرب طول خط در سینوس زاویه است.

مقدار Top در بالای سکشن صفر است و هر چقدر به پائین تر بروید اضافه خواهد شد.

Line Control Property Value (Example)

Top=1.0417"

Height=0.7083"

Convert -inches-to-twips

1.0417"×1,440=1500 show textbox or label

Top :

Top=Top+Diff

1,500+(1,500×cos(6×0)−1,500×cos(6×1))=1508

1,500+(1,500×cos(6×1)−1,500×cos(6×2))=1524

1,500+(1,500×cos(6×2)−1,500×cos(6×3))=1540

1,500+(1,500×cos(6×14)−1,500×cos(6×15))=1656

Width :

Width Sec1 : 1,500×sin(6×1)=156 ' عرض در ثانیه یک

Width Sec10 : 1,500×sin(6×10)=1299 ' عرض در ثانیه ده

Width Sec15 : 1,500×sin(6×15)=1500 ' عرض در ثانیه پانزده

Height : 0.7083×1,440=1020

Height=Height-Diff

Height Sec 1 : 

Diff Sec1 :1,500×cos(6×0)−1,500×cos(6×1)=8

Diff Sec10 :1,500×cos(6×9)−1,500×cos(6×10)=131

Diff Sec15 :1,500×cos(6×14)−1,500×cos(6×15)=156

Height Sec 1   : 1020-8=1012

Height Sec10 : 1020-131=889

Height Sec 15 : 1020-156=864

fabricatorguide.com

اختلاف بین Top نقطه قبلی و نقطه فعلی می شود چیزی که باید در ربع اول به Top اضافه و از Height کسر کرد.

Diff=length × Cos0-length × Cos 1

.Top=.Top+Diff

.Height=.Hekght-Diff

البته برای بدست آوردن سینوس یا کسینوس زاویه  همانطور که در بالاتر قید شد استفاده بنمائید.

موقعیت یک کنترل ، فاصله ی بوردر چپ یا بالا به لبه ی چپ یا بالای سکشن حاوی کنترل است.تنظیم ویژگی Top به صفر ،  لبه کنترل را در بالاترین جای سکشن قرار می دهد  ( سکشن Detail یا Form header و ... ) . برای استفاده از واحد اندازه گیری متفاوت ، در دیالوگ باکس Regional Options در کنترل پنل ، واحد را مشخص کنید مانند cm یا in ( برای مثال 3cm یا 2in ).

مثال زیر بررسی تنظیم ویژگی Top برای گaزارش درجریان . اگر این مقدار کمتر از حداقل حاشیه شد ویژگیهای NextRecord و PrintSection به False تنظیم می شوند . سکشن به رکورد بعدی پیشروی نمی کند و سکشن بعدی نیز در صفحه مشاهده نمیشود.

The following example checks the Top property setting for the current report. If the value is less than the minimum margin setting, the NextRecord and PrintSection properties are set to False. The section doesn't advance to the next record, and the next section isn't printed.

Sub Detail1_Format(Cancel As Integer,FormatCount As Integer)
Const conTopMargin = 1880
' Don't advance to next record or print next section
' if Top property setting is less than 1880 twips.
    If Me.Top < conTopMargin Then
        Me.NextRecord = False
        Me.PrintSection = False
    End If
End Sub

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

جدیدا کسانیکه واکسن زده اند دچار بیماریهای نادر و خطرناک نقص ایمنی می شوند پس مراقب باشید.

بیماری واسکولیت - وگنر :

 ( فردریک ونگنر)

کسانیکه ترشحات خونی یا چرک و خون دارند سریعا به پزشک روماتولوژی مراجعه نمایند ( بیماری نقص در خونرسانی و کاهش اکسیژن خون )

تست های خونی متداول افزایش مارکرهای غیر اختصاصی التهاب (ESR,CRP) رانشان می دهند. در گروه عمده ای از بیماران می توان نوعی پادتن بنام ANCA (Anti-Neutrophil Cytoplasmic Antibody را مشاهده نمود.

تصویر برداری از قفسه سینه , سی تی اسکن یا ام آر آی رگ های خونی و اندام های تحت تاثیر را بهتر نشان می دهد

بیوپسی , پزشک از طریق جراحی نمونه کوچکی از بافت آسیب دیده را برداشته و مورد بررسی قرار می دهد.

بیماری بسیار خطرناک وگنر

فائزه هاشمی رفسنجانی در واکنش به اظهارات ائمه جمعه و طرح های مجلس برای اجباری شدن معالجه زنان توسط پزشکان زن گفت: این از یک بُعدش درست است و از یک بّعدش اگر بخواهند در این سیاست بروند، غلط است،

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