گرفتن عبارت Sql مربوط به کوئری یا تغییر آن و تعداد فیلدها و نام فیلد کوئری

ویژگی SQL حاوی عبارت یا دستور SQL است که نحوه انتخاب ، گروه بندی و ترتیب رکوردها را هنگام اجرای کوئری تعیین می کند. می توان از کوئری برای انتخاب رکوردهایی برای گنجاندن در شئ رکوردست استفاده کرد.همچنین می توان اکشن کوئری ها را برای اصلاح بدون ارجاع به رکوردها تعریف کرد.

نوشتار SQL مورد استفاده در یک کوئری باید با SQL موتور کوئری مطابقت داشته باشد که بر اساس نوع فضای کاری تعیین میشود. در یک فضای کاری مایکروسافت اکسس ، از گویش  یا زبان Microsoft Access Sql استفاده کنید مگر اینکه یک کوئری pass-through ایجاد کنید در اینصورت باید از زبان ( dialect  ) سرور استفاده کرد.

اگر عبارت SQL شامل پارامترهایی باشد باید آنها را قبل از اجرا تنظیم کنید . تا زمانیکه پارامترها تنظیم مجدد نشوند ، هر بار که کوئری اجرا می شود ، همان مقادیر پارامتر اعمال می گردد.

You should not use SET except with objects. You need an object for QueryDefs, so:

SET  برای Objects استفاده می شود.

Dim qd As QueryDef

Set qd =CurrentDb.QueryDefs("MyQuery")

qd.SQL = "SELECT Category FROM Categories"

در لینک زیر ویژگیهای دیگر  این آبجکت یا شئ وجود دارد.

querydef-properties-dao

گرفتن تعداد فیلدهای کوئری مورد نظر

QueryDefs("QueryName").Fields.Count

گرفتن نام اولین فیلد از کوئری مورد نظر

QueryDefs("QueryName").Fields(0).Name

پس ملاحظه فرمودید از صفر شروع می شود

دوستان عزیز لطفا شرکت در نظرسنجی فراموش نشود

چک کردن باز بودن فرم بصورت Form Dialog و شفافیت یا کدورت پنجره

استفاده از تابع ویندوزی GetwindowLongA

win32/api/winuser/getwindowlonga

win32/winmsg/extended-window-styles  

GWL_EXSTYLE=-20

WS_EX_DLGMODALFRAME =&H1

GetWindowLongA hWnd,nIndex(GWL_EXSTYLE)

LIB "USER32"

برای TransParent یا شفاف کردن دیالوگ باکس می توانید از مطلب در لینک زیر که کاملا گویا است بهره ببرید.

using-layered-windows

کدر شدن یا شفاف شدن یک پنجره لایه ای را تنظیم میکند. 

winuser-setlayeredwindowattributes

یک آرگومان بنام alpha دارد اگر صفر باشد پنجره کاملا شفاف است زمانیکه مقدار آن 255 شود پنجره کدراست.

When bAlpha is 0, the window is completely transparent. When bAlpha is 255, the window is opaque.

البته پیشنهاد نمیشه اینکار چون  ممکن است خطا بدهد و هک کردن پنجره بسیار آسان است.

در ویندور 8 استایل Extended Layered برای پنجره های بالایی و زیر پنجره ها پشتیبانی می شود ولی در نسخه های قبل تر فقط به پنجره های بالاتر اعمال می شود.کسانیکه پنجره ویندوزی می سازندبا این مفاهیم آشنا هستند.

Windows 8:  The WS_EX_LAYERED style is supported for top-level windows and child windows. Previous Windows versions support WS_EX_LAYERED only for top-level windows.

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

ویژگی ColumnHidden جهت پنهان کردن ستون در نمای دیتا شیت

textbox.columnhidden

اگر ویژگی هیدن در فیلد مورد نظر وجود نداشت با کد زیر می توان این ویژگی ( ColumnHidden ) را اضافه کرد البته پراپرتی یونیک است و اگر دوباره اضافه شود خطا نمایان خواهدشد.

expression .CreateProperty(Name, Type, Value, DDL)

Field.CreateProperty("ColumnHidden",dbLong,True)

You manipulate a table definition using a TableDef object and its methods and properties

برای دستکاری ویژگیهای جدول : استفاده از شئ TableDef و متد و ویژگیهای آن

متد Add برای اضافه کردن شروط قالب به مجموعه FormatConditions

CONDITIONAL FORMATTING ( VBA )

FormatConditions.Add Method : 

با استفاده از متد Add می توان یک فرمت شرطی  بعنوان شئ FormatCondition به مجموعه FormatConditions یک کنترل  کمبو یا تکست باکس اضافه نمود.

expression.Add (Type, Operator, Formula1, Formula2)

آرگومان Type در متد بالا : 

AcFormatConditionType : 

acDataBar :The conditional format is displayed as a 

data bar

قالب شرطی که بصورت میله داده نمایش داده می شود

acExpression : The conditional format is based on an expression.

قالب شرطی بر اساس یک عبارت است مثل "Me.Id Mod 2"

acFieldHasFocus : The conditional format is based on the value of the control that has focus on a form.

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

acFieldValue : The conditional format is based on values in the selected control.

قالب شرطی بر اساس مقادیر در کنترل انتخاب شده است مثل فیلد ME.ID

آرگومان Operator که عملگرها است مثل acequal و ....

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

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

فرض کنید میخواهید اعداد زوج یا فرد در فیلد ID رنگ متفاوتی داشته باشند.

تعریف OFC بعنوان FormatCondition.

Set کردن OFC برای استفاده از متد ADD در ویژگی FormatCondition  تکست باکس ( txt1.FormatConditios.Add ) اگر تنظیم نشود ( یعنی از Set استفاده نشود ) ارور می دهد ، در متد Add آرگومانها بدلخواه پر شوند.

مرحله آخر مقدار دادن به ویژگی ForeColor کنترلی است که به متغیر OFC تنظیم شده. ( OFC.ForeColor=vbGreen )

می توانید کدها را در رویداد لود فرم قرار دهید.

FormatConditions خودش یکسری ویژگیها دارد مثل Count که تعداد شروط مربوط به تکست باکس یا کمبو باکس مشخص شده را می دهد.

Remarks

You can use the Delete method of the FormatConditions collection to delete an existing FormatConditions collection from a combo box or text box control.

با استفاده از متد Delete مجموعه FormatConditions می توان این مجموعه را از یک کنترل تکست یا کمبو باکس حذف نمود

مرجع : داکیومنت اکسس سایت آفیس

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

TempVars یا تعریف متغیر و استفاده در سایر فرم ها

Tempvar متغیری است که می تواند در Vba مورد استفاده قرار گیرد.

مجموعه TempVars که متدهای Add و Delete دادد تا 255 شی Tempvar را می تواند ذخیره کند. اگر آنرا حذف نکنید در حافظه تا بسته شدن دیتابیس باقی می ماند . بهترین پیشنهاد حذف متغیرهاست وقتی که کارتان به اتمام رسیده.

برای ارجاع به شی Tempvar در یک مجموعه با شماره اختصاصی یا با خصوصیت نامش می توانید شکل نوشتاری زیر را تنظیم نمائید.

• TempVar![name]

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

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

اکسس فقط یک دیتابیس است

دسترسی به تمام اشیاء دردیتابیس اکسس ( جداول ، کوئری ها ) یا ( فرم و گزارشات )

CurrentData

دارای خصوصیات یا ویژگیهای زیر است ، مورد استفاده : فرضا بخواهید لیست جداول را بگیرید یا در جداول و  کوئری ها لوپ بزنید برای جستجو.

برای دسترسی به مجموعه های زیر و خصوصیات هر کدام 

Properties

• AllDatabaseDiagrams
• AllFunctions
• AllQueries
• AllStoredProcedures
• AllTables
• AllViews

برای دسترسی به فرم ها و گزارشات از CurrentProject استفاده بنمائید

در هر صورت داکیومنت آفیس را مطالعه بفرمائید.

office/vba/api/access.currentproject

ساخت کوئری در وی بی ای با CreateQueryDef

CreateQueryDef

در فضای کاری مایکروسافت اکسس اگر چیزی غیر از رشته با طول صفر  ("") برای نام شئ فراهم کنید زمان ساخت QueryDef نتیجه این میشود که شئ QueryDef بصورت اتوماتیک به مجموعه QueryDefs اضافه میشود

اگر شی مشخص شده ( کوئری ایجاد شده )  قبلا عضو مجموعه QueryDefs باشد ، با خطا مواجه خواهید شد. شما می توانید با استفاده از رشته ای با طول صفر زمان اجرای CreateQueryDef برای آرگومان Name یک QueryDef موقت بسازید. حتی می توانید این کار را با تنظیم ویژگی Name یک QueryDef جدید روی یک رشته با طول صفر "" انجام دهید 

شی QueryDef موقت مفید هستند چنانچه بخواهید مکررا از عبارات اس کیو ال دینامیکی بدون احتیاج به ساختن اشیاء دائم جدید در مجموعه QueryDefs استفاده کنید. نمی توانید یک شی QueryDef موقت را به هر مجموعه ای اضافه کنید بدلیل اینکه رشته با طول صفر برای یک شئ QueryDef دائم معتبر نیست . می توان همیشه خصوصیات Sql و Name شئ QueryDef جدیدا ساخته شده را تنظیم و نتیجتا QueryDef را به مجموعه QueryDefs اضافه نمائید.

برای اجرای عبارت Sql در شئ QueryDef از متد Execute یا OpenRecordset بهره ببرید.

 استفاده از شئ QueryDef راه ترجیحی است برای اجرای کوئریهای نوع Sql pass-through یا sql هایب که پاس دهی می شوند به یک رابط بیرونی با ODBC.

برای حذف این شئ از مجموعه در موتور دیتابیس اکسس از متد Delete در مجموعه استفاده نمائید.

expression .CreateQueryDef(Name, SQLText)

دو آرگومان بالا Optional یا انتخابی است.

پس با مطالعه داکیومنت آفیس به این نتیجه می رسیم که اگر نام کوئری ساخته شده چیزی غیر از رشته ای  با طول صفر باشد ، در زمان ایجاد دوباره آن یا Recreate با خطا مواجه خواهیم شد چون  بطور دائم به مجموعه QueryDefs اضافه می کند و تکرار پذیر هم نیست ( یونیک است ) لذا برای ایجاد کوئری موقت از ("") استفاده  بنمائید بدون فاصله ، چرا ؟!!! چون خود Space هم طول دارد و صفر نیست.

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

گرفتن موقعیت کرسر ماوس در داخل یا بیرون فرم

برای 32 بیت : 

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Type POINTAPI

        x As Long

        y As Long

End Type

Dim a As POINTAPI

از رویداد OnTimer استفاده میشود تا در هر لحظه تغییر مختصات ماوس در Screen گرفته شود.

GetCursorPos a

Label1.Caption="X:" & a.x & ";Y:" & a.y

When running in 64-bit versions of Office, Declare statements must include the PtrSafe keyword. The PtrSafe keyword asserts that a Declare statement is safe to run in 64-bit development environments. Adding the PtrSafe keyword to a Declare statement only signifies that the Declare statement explicitly targets 64-bits.

وقتی در نسخه 64 بیت اجرا می شود.عبارات اظهارشده می بایست شامل کلیدواژه ی PtrSafe باشد.در عبارات زیر مشاهده می کنید که PtrSafe در کجا بکاربرده شده و در ضمن بجای تایپ داده Long از LongLong یا LongPtr استفاده شود.

[ Public | Private ] Declare PtrSafe Function name Lib "libname" [ Alias "aliasname" ] [ ( [ arglist ] ) ] [ As type ]

پراپرتی UsedRange در اکسل

در Vba ویژگی UsedRange محدوده ای از WorkSheet که داده در آن قرار دارد را ارائه می کند و از اولین سلول در WorkSheet جایی که مقداری است شروع شده و تا آخرین سلولی که مقدار وجود دارد ختم می شود.

In VBA, the UsedRange property represents the range in a worksheet that has data in it. The usedrange starts from the first cell in the worksheet where you have value to the last cell where you have value.

میشود از Clear و Copy با یک نقطه بعد از آن کل محدوده را پاک یا به جای دیگری انتقال داد.

ActiveSheet.UsedRange.Clear 

Or 

ActiveSheet.UsedRange.Copy

روش حذف ردیف های خالی در اکسل

در تصویر اول با توابع If و CountA صورت گرفته ، طبق فرمول اگر در رنج A2 تا D2 کانت سلول برابر صفر بود کلمه Blank و یک بود Not blank در ستون E قید گردد.البته بعد از نوشتن فرمول در سلول E2 حتما کنترل و اینتر را بزنید تا عمل بنماید.

در تصویر دوم کالمن A را انتخاب کرده ، دکمه Ctrl بهمراه G را گرفته و از پنجره بازشو Special را انتخاب نموده و باز هم از پنجره بازشوی بعدی رادیو باتن Blanks را انتخاب و اقدام به فشردن باتن Ok کرده که نتیجتا سلول های خالی در ستون A انتخاب شده ( یک تصویر قبل از تصویر آخر ) سپس کلیک راست کرده و در پنجره Delete رادیو باتن کل ردیف یا Entite Row را انتخاب نموده ، بعد از فشردن باتن Ok ردیف های خالی حذف شده اند.( تصویر آخر )

Create TextFile

VBA Code:

Sub Ger_sinal()
Dim sinal() As integer

ReDim sinal(3)

'Test values
 sinal(0) = -22306
 sinal(1) = 5836
 sinal(2) = 0
 sinal(3) = 23326

'Creates a file and puts the values in it
Dim n_arq As Integer
Dim path As String
path = "C:\Users\DELL\Desktop\App\WAVs\Sinal_VBA.wav"
 
     Set fs = CreateObject("Scripting.FileSystemObject")
     Set a = fs.CreateTextFile(path, True)
     a.Close
    
     n_arq = FreeFile
     Open path For Binary As n_arq

     Put n_arq, , sinal
    Close n_arq

End Sub

آبجکت Adodb.Stream برای لود کردن فایل در فیلد باینری

راه های زیادی برای لود کردن فایل به bytearray وجود دارد .که میتوان از آبجکت ADODB.Stream استفاده نمود.

Dim db As DAO.Database
Dim rst As DAO.Recordset

Set db = CurrentDb
Set rst = db.OpenRecordset("dbo_WATER_FILES", dbOpenDynaset, dbSeeChanges)
rst.Edit
Dim strm As Object
Set strm = CreateObject("ADODB.Stream")
strm.Type = 1 'adTypeBinary
strm.Open
strm.LoadFromFile "C:\test.jpg"
rst.Fields("Binary_File").Value = strm.Read 'FileData
strm.Close
rst.Update

برای برگشت باینری به یک فایل : 

With CreateObject("ADODB.Stream")
    .Type = 1 'adTypeBinary
    .Open
    .Write  rst.Fields("Binary_File").Value
    .SaveToFile "C:\testcopy.jpg", 2 'adSaveCreateOverWrite
    .Close
End With

تبدیل باینری به تکست یا تکست به باینری هم از همین آبجکت

می توان بهره برد.

Field Name
Description
FileData
The file itself is stored in this field.
FileFlags
Reserved for future use.
FileName
The name of the file in the attachment field.
FileTimeStamp
Reserved for future use.
FileType
The file extension of the file in the attachment field.
FileURL
The URL for the file for a linked SharePoint list. Will be Null for local Access tables.

Whatsapp Message

How to send Whatsapp messages without saving the 

number

Use AddressBar :

IE.navigate "whatsapp://send?phone=5511912341234&text=something" '

Whatsapp Message

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

whatsapp/send-file

gateway-endpoints برای ارسال فایل البته پرداخت ماهیانه 

ارسال پیام  از طریق web ،  فقط از روی کامپیوتر و اسکن کیو آر کد توسط گوشی 

How to send Whatsapp messages without saving the 

number

1. How to send Whatsapp messages without saving the number
2. Open the web browser and then paste ‘https://api.WhatsApp.com/send?phone=number’ in the Address bar of your phone’s browser. 
 
3. In the place of “number”, enter the phone number of the person to whom you want to send a WhatsApp message with the country code.
 
4. Omit any zeroes, brackets or dashes when adding the phone number in international format.
 
5. The number that you provided should have a WhatsApp account.
 
6. Click on “Message” button.
 
7. You will be taken to the WhatsApp app with a chat being open for the said contact.

  Application.FollowHyperlink method:

Application.FollowHypwrlink "http://web.whatsapp.com/"

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

Application.FollowHyperlink "D:\text.accdb"

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)

 

CreateObject("WScript.Shell")

wShell.Sleep 1000

"https://web.whatsapp.com/send?phone='"+phone_no+'" & "&text='"+message & "'"

how-to-use-click-to-chat

Send Message To WhatsApp If Number Available

پس باید شماره در لیست شماره های تلفن شما باشد و همچنین اپلیکیشن بازشده باشد. ( تلفن با کد کشور بدون صفر و پرانتز یا براکت اضافه !!!

Application.FollowHyperlink  "https://wa.me/975777723456?text=Hi"

خیلی ساده و کاربردی توسط WhatsApp توصیه شده و برای استفاده از کاربرانی است که میخواهند پیامی را به مخاطب یا مخاطبان لیست خودشون در whatsapp بفرستند فرضا فایل اکسلی دارید در ستونی شماره تماس مخاطباتون که هم در واتساپ هست و هم آنها واتساپ دارند اضافه می کنید سپس طبق لینک بالا در Address می گذارید و ارسال می شود.

در زیر اگر تلفن در CONTACT LIST شما باشد پیام روی واتساپ نمایش داده می شود ولی احتیاج به فشردن کلید SEND است که برای اینکار میشوداز  SENDKEYS استفاده نمود.

https://api.whatsapp.com/send?phone=979109077999&text=dummy

https://wa.me/whatsappphonenumber/?text=urlencodedtext. For example, if you have to send a message that says “How are you?” to an unsaved number 9988776655, this will be the final URL that you will need to enter – https://wa.me/919988776655?text=How%20are%20you%20?

بخاطر اینکه در بستر وب انجام میشود و برای هر ارسال یک تب جدید باز میشود می توان CTRL+W را با SENDKEYS فرستاد تا برنامه را در همان ویندو ببندد 

Ctrl+W is a shortcut key most often used to close a program, window, tab, or document. Alternatively referred to as Control W and C-w, Ctrl+W is a shortcut key most often used to close a program, window, tab, or document.

Sleep Api use 

SendKeys "{Enter}"

TVRoY6bQ

لطفا نظر سنجی فراموش نشود !!!

ارسال فایل 

https://faq.whatsapp.com/general/whatsapp-business-api/getting-access-to-business-api/

https://www.whatsmate.net/whatsapp-image-individual-api.html

Whatsapp uses TCP 443 (HTTPS) to pass the majority of the connection traffic but it also uses TCP 80 (HTTP). If voice is used, then ports 4244, 5222, 5223, 5228,50318, 59234 & 5242 are used.

UDP Ports: 34784, 45395, 50318, 59234.

Are you limiting outgoing port via the Egress firewall? If yes you need to give access to ports 5222,5223 and 5228. This is for Whatsapp calling.

Text messages should work by default as far as I am aware (as port 80 and 443 are used which are usually open)

کاربرد چند تابع API در فرم

در رویداد Open فرم Child :

hParent = FormParent.hwnd

hChild = FormChild.hwnd

SetParent hChild, hParent

SetWindowPos hChild, hParent, 163, 44, 725, 437, &H4

Private Type Rect

Left,Top,Right,Bottom As Long

End Type

در رویداد Resize فرم Child :

Dim mainRECT As RECT 

hParent = FormParent.hwnd

hChild = FormChild.hwnd

GetWindowRect hParent, mainRECT

uFlags last Arguman in SetWindowPos (swp ) Function
&H80   'hidewindow
&H20   'draw frame
&H2     'no move
&H400 'no send changing
&H4      ' ignores the hWndInsertAfter parameter
&H40   'Showwindow

SetWindowTexA hWnd,lpString  تغییر کپشن پنجره

SetDlgItemTextA hDlg,nIDDlgItem,lpString تغییر تکست کنترل

GetClassNameW hWnd,lpClassName,nMaxCount  گرفتن کلاس پنجره

کلاس مسیج باکس 32770# است اگر اشتباه نکنم  ،  در window-classes می توانید مشاهده بنمائید. با  تابع EnumChildWindows  و قرار دادن EnumProc به True می توان کلاس های Child  پنجره اصلی را گرفت 

ShowWindow  hWnd, nCmdShow  حالت نمایش پنجره فرضا مخفی کردن یا مینیمایزکردن حتی جای آرگومان آخر صفر بگذارید پنجره مخفی می شود

 اگر آرگومان دوم که کپشن ویندو است خالی باشد نتیجه ( قسمت Title ) با هر پنجره ای که Match شود برگردانده میشود که 32770 کلاس Dialog Box است اگر خطا بدهد نتیجه NULL است  ، اگر آرگومان اول خالی باشد نتیجه طبق همان آرگومان دوم که Title است برگردانده میشود فرضا در مسیج باکس می توانید از آرگومان دوم که بتواند هندل درستی به این پنجره باشد استفاده بنمائید.

FindWindowW "#32770", VbnullString  

برای جستجو  در  پنجره های Child  استفاده از  FindWindowEx.

تابع زیر برای شمردن پنجره های   Child  که متعلق به پنجره مادر یا Parent مشخص شده است با عبور هندلی به هر پنجره Child

EnumChildWindows hWndParent,lpEnumFunc,lParam

آرگومان دوم استفاده از AddressOf قبل از lpEnumFunc

فرضا Parent پنجره ای با کلاس دیالوگ باکس یعنی 32770# و آرگومان دوم آدرسی به تابعی جهت لوپ در این پنجره. مثل

EnumChildProc hWnd,lParam

که hWnd هندلی است به پنجره Child و برای شمارش می بایست این تابع برابر True قرار گیردو برای Stop برابر False 

EnumChildProc=True

Public Function EnumChildProc(ByVal hWnd As Long,ByVal lParam As Long)

اینجا می توان از تابع GetClassNameA استفاده کرد و  Class و Title هر پنجره Child را استخراج کرد ( hWnd ) یا حتی GetWindowTextA

EnumChildProc=True

خط بالا برای ادامه شمارش و برای خاتمه دادن به شمارش از False استفاده می کنیم 

Exit Function

برای تغییر لوکیشن هر پنجره Child می توان از تابع    movewindow   استفاده نمود. از showwindow هم برای مخفی کردن پنجره Child.

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

EnableWindow hWnd,bEnable

برای ساختن  Timer : 

SetTimer hWnd,nIDEvent,uElapse,lpTimerFunc

تخریب Timer مشخص شده : 

KillTimer hWnd,uIDEvent

پست یک پیام به پنجره  مثل ارسال WM_CLOSE برای بستن پنجره مشخص شده : 

PostMessageA hWnd,Msg,wParam,lParam

فعال ، غیرفعال یا خاکستری کردن آیتم منو : 

EnableMenuItem hMenu,uIDEnableItem,uEnable

uIDEnableItem : 

MF_BYCOMMAND=&H0

 نشان میدهد که  IDEnableitem یک نشانگری به آیتم منو می دهد فرضا اگر آیتمی در منو در نظر باشد باید اشاره شود.

MF_GRAYED=&H1

 غیرفعال و خاکستری و نمی تواند انتخاب شود

MF_DISABLED=&H2

غیرفعال ولی خاکستری نمیشود نمی تواند انتخاب شود

گرفتن هندل منوی پنجره ،  همان کلوز و مینیمایز و ماکزیمایزدرفرم : آرگومان دوم باید حتما 0 یا False باشد.

hMenu=GetSystemMenu(hWnd,bRevert)

مثال از دو تابع گرفتن هندل منوی فرم و تابع فعال یا غیر فعال کردن پنجره  :

hMenu=GetSysMenu(.hWnd,False)

EnabledWindow hMenu,False

تغییر ویژگی پنجره :

SetWindowLongPtrA hWnd,nIndex,dwNewLong

nIndex  : GWL_STYLE=-16    تغییر استایل پنجره

dwNewLong : 

WS_MAXIMIZE=&H1000000
WS_MINIMIZE=&H20000000
WS_MAXIMIZEBOX=&H10000 'باتن ماکزیمایز
WS_MINIMIZEBOX=20000 'پنجره باتن مینیمایز دارد
WS_SYSMENU=&H80000 'پنجره یک منو دارد در قسمت تایتل
WS_TABSTOP=&H10000 ' فوکس کیبورد
WS_CLIPCHILDREN=&H2000000 'زمان ساخت پرنت ویندو استفاده می شود
WS_CHILD=&H40000000 ' پنجره با این استایل نمی تواند نوار منویی داشته باشد
WS_CAPTION=&HC00000 'پنجره تایتل بار دار با بوردر

تابعی برای گرفتن ابعاد screen  :

GetSystemMetrics nIndex ' Lib user32

فقط یک آرگومان دارد از user32.dll ، اگر nIndex صفر باشد X را بر می گرداند (  به پیکسل )  و یک باشد Y را بر میگرداند.

X=GetSystemMetrics(0)

Y=GetSystemMetrics(1)

توابع مربوط به منو :

هندل به منوی پنجره مشخص شده

GetMenu hWnd  ' lib user32

تعیین تعداد آیتم ها در منوی مشخص شده

GetMenuItemCount hMenu  ' lib user32

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

RemoveMenu hMenu,uPosition,uFlags ' lib user32

uFlags :

MF_BYCOMMAND=&H0

MF_BYPOSITION=&H400

آپدیت کردن منو بار زمان تغییرات اعمال شده :

DrawMenuBar hWnd ' lib user32

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

GetSubMenu hMenu,nPos 'lib user32

'get menu

hMenu= GetMenu(MainWindowHandle)

'get item count

count = GetMenuItemCount(hMenu)

'loop & remove

for  i = 0 to count

RemoveMenu hMenu,0, (MF_BYPOSITION Or MF_REMOVE)

'force a redraw

DrawMenuBar MainWindowHandle

تغییر اطلاعات درباره آیتم منو البته طبق تنظیم استراکچری که دارد

SetMenuItemInfoA hmenu,item,fByPositon, lpmii

Public Type MENUITEMINFOA

cbSize As Long

fMask As Long

fType

fState

wID

hSubMenu As Long

hbmpChecked

hbmpUnchecked

dwItemData As Long

dwTypeData As String

cch As Long

hbmpItem As Long

End Type

'fmask
MIIM_BITMAP=&H80
MIIM_STATE=&H1
MIIM_STRING=&H40 'dwTypeData
MIIM_FTYPE=&H100 'ftype

'Menu fType
MFT_BITMAP=&H4
MFT_BITMAP is replaced by MIIM_BITMAP and hbmpItem.
MFT_STRING=&H0

'Menu item state
MFS_DISABLED=&H3
MFS_GRAYED=&H3
MFS_HILITE=&H80

cch: The length of the menu item text, in characters

طول متن مورد منو ، به صورت کاراکتر ، هنگامی که اطلاعات مربوط به آیتم منو از نوع MFT_STRING دریافت می شود. با این حال ، cch فقط در صورتی استفاده می شود که پرچم MIIM_TYPE در عضو fMask تنظیم شده باشد و در غیر این صورت صفر باشد. همچنین وقتی محتوای یک آیتم منو با فراخوانی SetMenuItemInfo تنظیم می شود ، cch نادیده گرفته می شود.

عضو cch از MENUITEMINFOA کاربردش زمانی است که پرچم MIIM_STRING در عضو fMask تنظیم شده باشد.

برای بازیابی آیتم منوی تایپ MFT_STRING ، اول سایز رشته را با تنظیم عضو dwTypeData از MENUITEMINFO به NULL پیدا کنید و سپس تابع GetMenuItemInfo را فراخوانی کنید. مقدار cch+1 سایزی است که مورد نیاز است.سپس بافری را تخصیص دهید ،   یک نشانگر به بافر در dwTypeData قرار دهید ، افزایش cch و یکبار دیگر تابع GetMenuItemInfo را صدا بزنید تا بافر را با رشته پر کند.

طبق دستورالعمل داکیومنت آفیس عمل می کنیم شما تست بفرمائید اگر درست نبود اصلاح شده در نظرات همین پست قید گردد 

Dim Mii As MENUITEMINFOA

With Mii

.cbSize=Len(MENUITEMINFO)

.fMask=&H40 'MIIM_STRING

.dwTypeData=vbNullString

End With 

با GetMenu میشود هندل منوی پنجره را بدست آورد و در 

hMenu قرار داد.

GetMenuItemInfo hMenu,0,True,&Mii

سپس اضافه کردن یک به cch

Mii.cch=Mii.cch+1

Mii.dwTypeData = Space(mii.cch)

Mii.fMask=&H40 Or &H2

' Retrieve data  بازیابی داده

GetMenuItemInfo(hMenu, wParam(ItemNumber),True,&mii)

------------------------------

wCaption = String$(256, 0)
    hwnd = GetActiveWindow  ؟؟؟؟  دقیق نیست
    retVal = GetWindowText(hwnd, wCaption, 255)
    wCaption = Left$(wCaption, retVal)
    If InStr(1, wCaption, "Microsoft Excel", vbTextCompare) = 0 Then
      Exit Sub
    End If

    hSysMenu = GetSystemMenu(hwnd, 0)
    Count =GetMenuItemCount(hSysMenu)

RemoveMenu hSysMenu, Count-1,MF_REMOVE Or MF_BYPOSITION)
RemoveMenu(hSysMenu, Count-2, MF_REMOVE Or MF_BYPOSITION)



Private Const MF_BYCOMMAND = &H0
Private Const SC_CLOSE = &HF060

MnuHandle = GetSystemMenu(handleWindow, ByVal 0)
lRetVal=DeleteMenu(l_lMenuHandle, SC_CLOSE,MF_BYCOMMAND)

---------------SYSMENU-------------

Public Declare Function GetMenu Lib "user32.dll" (ByVal hWnd As Long) As Long
Public Declare Function GetMenuItemCount Lib "user32.dll" (ByVal hMenu As Long) As Long


Public Declare Function Lib "user32.dll" Alias "GetMenuItemInfoA" (ByVal _ hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Long, lpmii As _ MENUITEMINFO) As Long


hMenu=GetMenu(hWnd)
itemcount = GetMenuItemCount(hMenu)


With mii
.cbSize = Len(mii)
.fMask =&H40
For c = 0 To itemcount - 1
     .dwTypeData = Space(256)
     .cch = 256
  retval =GetMenuItemInfoA(hMenu, c, 1, mii)
 Debug.Print Left$(.dwTypeData,.cch)

Next   

----------SYSMENU EXTRACT STRING---------

hMenu=GetMenu(hwnd) 

MenuCount = GetMenuItemCount(hMenu)
If MenuCount < 0 Then
Exit Sub
End If

MII.cbSize = Len(MII)
MII.fMask = MIIM_TYPE
MII.fType = MFT_STRING

For ForLoopCounter = 0 To MenuCount - 1
MII.dwTypeData = vbNullString
MII.cch = Len(MII.dwTypeData)
GetMenuItemInfo(hMenu, ForLoopCounter, True, MII)

MII.dwTypeData = Space(MII.cch + 1)
MII.cch = Len(MII.dwTypeData)

GetMenuItemInfo(hMenu, ForLoopCounter, True, MII)

StopChar = Right(MII.dwTypeData, 1) Debug.Print Left(MII.dwTypeData, InStr(1, MII.dwTypeData, StopChar) - 1) 

Next

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

SetMenuItemInfoA hmenu,item,fByPositon, lpmii

آرگومان سوم True باشد آرگومان دوم ایندکس است از صفر شروع می شود و تعداد کل منهای یک .. تعداد کل با تابع GetMenuItemCount بدست می آید و آرگومان آخر اطلاعات که در استراکچری بانام MENUITEMINFOA ذخیره شده یا می شود .

SetMenuItemBitmaps hMenu,uPosition, uFlags,hBitmapUnchecked,hBitmapChecked

 BITMAP مناسب را در کنار آیتم منو نمایش می دهد. ( فقط فایل BITMAP )  ، در مثال زیر کنار آیتم 5 ( ایندکس آیتم از صفر شروع میشود ) یک BITMAP قرار می دهد.

setmenuitembitmaps hSysMenu, 5, &H400, loadimage(image_Bitamp),loadimage(image_Bitamp)

اضافه کردن یک آیتم جدید به آیتم منوها اگر اضافه شود دیگر آیتم ها به پائین منتقل می شوند.

InsertMenuA hMenu,uPosition,uFlags,uIDNewItem,lpNewItem  ' Lib User32

uFlags +  

: MF_BYCOMMAND OR MF_BITMAP

در زیر اشاره شده استفاده از BITMAP بعنوان آیتم منو ، پارامتر lpNewItem حاوی هندلی به BITMAP است 

MF_BITMAP 0x00000004L

Uses a bitmap as the menu item. The lpNewItem parameter contains a handle to the bitmap.

پارامتر uFlags باید با یکی ازمقادیر زیر باشد.

MF_GRAYED=&H1 غیر فعال کردن منو و خاکستری کردن آن
MF_DISABLED=&H2 غیرفعال کردن منو
MF_SEPARATOR=&H800
MF_STRING=&H0 '  lpNewItem =your text

lpNewItem بستگی به این دارد که پارامتر uFlags شامل Flag ( پرچم )MF_BITMAP, MF_OWNERDRAW یا MF_STRING باشد

flag های زیر با هم نمی توانند استفاده شوند :

• MF_BYCOMMAND and MF_BYPOSITION
• MF_DISABLED, MF_ENABLED, and MF_GRAYED
• MF_BITMAP, MF_STRING, MF_OWNERDRAW, and MF_SEPARATOR
• MF_MENUBARBREAK and MF_MENUBREAK
• MF_CHECKED and MF_UNCHECKED

CONST SC_CLOSE = 61536

CONST MF_BYCOMMAND = 0

hMenu=GetSystemMenu(hWnd, FALSE )

IF hMenu > 0 THEN

DeleteMenu hMenu,SC_CLOSE ,MF_BYCOMMAND DrawMenuBar hWnd

END IF 

InsertMenuA hMenu,SC_CLOSE, MF_BYCOMMAND,SC_CLOSE, "&Close~tAlt+F4" ) 

----------------XXXXXXX------------------

InsertMenuA hmenu, -1, MF_STRING Or MF_BYPOSITION,uidFirstCmd, "SimpleShlExt Test Item"

SetMenuItemBitmaps hmenu, uidFirstCmd, MF_BITMAP Or MF_BYCOMMAND,hBitmap,hBitmap

----------------------------------

Public Type WNDCLASSEXA
cbSize As Long
style As Long
'lpfnWndProc
hIcon As Long 'A handle to the class icon
hCursor As Long
hbrBackground As Long
lpszMenuName As String
lpszClassName As String
hIconSm As Long 'A handle to a small 'icon that is associated with the window 'class.
End Type

VK_F1=&H70
WM_KWYDOWN=&H100

'Lib user32
SetClassLongPtrA hWnd,nIndex,dwNewLong

nIndex :
GCLP_HICONSM=-34 'small icon GCL_STYLE=-26
GCLP_WNDPROC=-24
GCLP_HICON=-14
GCLP_HCURSOR=-12
GCLP_ HBRBACKGROUND=-10

WndProc :
Select Case uMsg
Case WM_KEYDOWN
Select Case wParam
Case VK_F1
newBrush=CreatePatternBrush(newBMP)

oldBrush=SetClassLongPtrA(hwnd, GCLP_HBRBACKGROUND,newBrush)
DeleteObject oldBrush
InvalidateRect hwnd,Null,True
End Select
End Select
DefWindowProcA hwnd,uMsg,wParam,lParam

ساخت دیالوگ باکس Open که به کاربر اجازه انتخاب Drive ، Directory و نام یک فایل یا مجموعه ای از فایل هایی که باز می شوند را می دهند.

'Lib Comdlg32  

 GetOpenFileNameA LPOPENFILENAMEA 

البته اول بایدپارامتر LPOPENFILENAMEA تنظیم شود در داکیومنت آفیس بدان اشاره شده مطالعه کنید.

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

GetSaveFileNameA LPOPENFILENAMEA

------------------CREATEFILEA---------------

'C#
hVolume = CreateFile(@"\\.\A:", GENERIC_READ,
                                FILE_SHARE_READ | FILE_SHARE_WRITE, IntPtr.Zero,
                                OPEN_EXISTING, 0, IntPtr.Zero);

hCom = CreateFile(
    "COM1",
    GENERIC_READ | GENERIC_WRITE,
    0,
    NULL,
    OPEN_EXISTING,
    0,
    NULL
);

GetCommState hFile,lpDCB 'Lib Kernel32

Public Type DCB
DCBlength As Long ' Len(DCB)
BaudRate As Long  '9600
fParity As Long  'True
End Type

Public Declare Ptrsafe Function SetCommState Lib "Kernel32" (Byval hFile As LongPtr,Byval lpDCB As DCB)

CloseHandle  hFile  ' Lib  kernel32

############

Public Declare Ptrsafe Function SetCommState Lib "Kernel32" (Byval hFile As LongPtr,Byval lpDCB As DCB)

CreateFile Comm
Sleep 1000
'After CreateFileA Use SetupComm
'to set the communications parameters 'for the device.
'SetupCommhFile,dwInQueue,dwOutQueue
SetupComm Comm, 128, 128
DCB. DCBlength=Len(DCB)
GetCommState Comm, dcb

dcb.BaudRate = 9600
dcb.ByteSize = 8
dcb.fBinary = TRUE
dcb.fParity = FALSE
dcb.Parity = NOPARITY
dcb.StopBits = ONESTOPBIT
dcb.fAbortOnError = TRUE
SetCommState Comm, dcb

'Set the event mask
'SetCommMask hFile,dwEvtMask 'kernel32
'EV_RXCHAR=&H1: A character was 'received and placed in the input buffer

SetCommMask Comm, EV_RXCHAR
DWORD dwMask = EV_RXCHAR

Sleep 1000
'Send the message to Module
WriteFile Comm,msg,len(msg),0, NULL

'Wait Response from module
'WaitCommEvent 'hFile,lpEvtMask,lpOverlapped
WaitCommEvent Comm, &dwMask, NULL

sBuffer=String(128,"")
ReadFile Comm, sBuffer,8,0, NULL

انتخاب رنگ استفاده از ChooseColor

ChooseColor : ms646912(v=vs.85)

DLL : Comdlg32.dll

LIB is Required 

If Use 64 bit windowse , before Function use PtrSafe

در لینک زیر نحوه استفاده و فراخوانی دیالوگ باکس ها مثل رنگ ، فونت ، پرینت بیان شده و می توانید به نحو احسنت و دلخواه فیض ببرید DLL آنهم در بالا گفته شده حتما در فراخوانی باید از LIB استفاده شود مثل 

Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long

توابع Api ویندوز را با همان نام و حروف کوچک و بزرگش فراخوانی کنید فرضا در GetWindow اگر getWindow تایپ کنید خطا می دهد. برای ویندوز 64 بیت قبل از Function از PtrSafe استفاده کنید و بعضی از آرگومانها مثل hWnd هم باید بجای دیتا تایپ Long از LongPtr استفاده کرد.

using-common-dialog-boxes

CHOOSECOLOR cc ' common dialog box structure static COLORREF acrCustClr[16] ' array of custom colors

HWND hwnd 'owner window

HBRUSH hbrush 'brush handle

static DWORD rgbCurrent 'initial color selectionInitialize CHOOSECOLOR ZeroMemory(&cc, sizeof(cc)); cc.lStructSize = sizeof(cc); cc.hwndOwner = hwnd; cc.lpCustColors = (LPDWORD) acrCustClr; cc.rgbResult = rgbCurrent; cc.Flags = CC_FULLOPEN | CC_RGBINIT;

See the link >>>>> choosecolora

typedef struct tagCHOOSECOLORA { 

 DWORD lStructSize; 

 HWND hwndOwner; 

 HWND hInstance; 

 COLORREF rgbResult; 

 COLORREF *lpCustColors; 

 DWORD Flags; 

 LPARAM lCustData; 

 LPCCHOOKPROC lpfnHook; 

 LPCSTR lpTemplateName; 

 LPEDITMENU lpEditInfo; } 

CHOOSECOLORA, *LPCHOOSECOLORA;

در لینک کاربرد هر کدام مفصل بیان شده که بعضی به کار کنونی ما ربط پیدا می نماید.

در بالا اول استراکچری تعریف شده که مقادیری را در خودش نگه می دارد 

Pubic Type ChooseColor

#if win64 Then

lStructSize As LongPtr

hwndOwner As LongPtr

lpCustColors() As LongPtr

rgbResult As LongPtr

Flags As LongPtr

#Else

lStructSize As Long

hwndOwner As Long

lpCustColors() As Long

rgbResult As Long

Flags As Long

#End if

End Type

 تابعی به اسم dlgColor تعریف شده و از نوع Long ... اگر رنگ دیفالتی قرار است تعریف شود در تابع می توانید بکار ببرید مثل Oprional iDefault As Long 

Dim cc As ChooseColor

Dim lRet As Long

Static CustomColors(16) As Long

'If yoy want to use

CustomColors(1)=RGB(255,255,255)

With cc

.lstructSize=LenB(cc)

.hwndOwner=Application.hWndAccessApp

.flags=

.lpCustcolors=VarPtr(CustomColors(0))

End With

lRet=ChooseColor(cc)

If lRet=0 Then '  کنسل توسط کاربر

dlgColor=RGB(255,255,255) ' سفید

Else

dlgColor=cc.rgbResult

End If 

اگر rgbResult صفر یا CC_RGBINIT تنظیم نشده باشد رنگ انتخاب شده اصلی مشکی است . اگر کاربر باتن OK را بفشارد rgbResult انتخاب کاربر خواهد بود.از RGB ماکرو استفاده کنید.

برای flags در استراکچر بالا از CC_ANYCOLOR Or CC_FULLOPEN Or CC_PREVENTFULLOPEN Or CC_RGBINIT استفاده بنمائید که باز کردن دیالوگ باکس هم درونش وجود دارد.

lpCustColors نشانگری است به آرایه (16) ای که حاوی مقادیر قرمز سبز آبی  برای جعبه رنگ در دیالوگ باکس است .اگر کاربر در این رنگ ها  تغییراتی بدهد سیستم آرایه را به مقادیر جدیدی به روز رسانی خواهد کرد برای نگهداری این به روز رسانی و  استفاده از آن در تابع بایستی حافظه Static را برای این آرایه تخصیص بدهید مثل Static CustomColors(16) As Long . برای ساختن COLORREF از ماکرو RGB استفاده بنمائید. 

لینک زیر هوک کردن دیالوگ باکس البته پیشنهاد نمیشود و درون آن پنجره هم CHILD یا زیر پنجره هایی وجود دارد و توصیه شده از GETPARENT استفاده بنمائید.

 چرخش در زنجیره ی هوک  commdlg-lpofnhookproc

Lpofnhookproc; UINT_PTR Lpofnhookproc( HWND unnamedParam1, UINT unnamedParam2, WPARAM unnamedParam3, LPARAM unnamedParam4 )

رویه HOOK میتواند تابع PostMessage را برای ارسال پیام 

WM_COMMAND با مقدار IDCANCEL به رویه دیالوگ باکس فرابخواند.ارسال IDCANCEK این پنجره را می بندد و باعث می شود تابع FALSE را برگرداند.

اگر پیام WM_CTLCOLORDLG به پنجره ارسال شود و همچین پیامی داشته باشد آن بایستی یک هندل BRUSH معتبری برای رنگ کردن  پیش زمینه دیالوگ باکس را برگشت دهد. 

WM_CTLCOLORDLG : 

wParam

A handle to the device context for the dialog box.

lParam

A handle to the dialog box.

Public Function DlgProc(ByVal hwnd As longPtr,ByVal Umsg As Long, ByVal wParam As LongPtr,Byval lParam As LongPtr)

Select Case Umsg
 Case WM_INITDIALOG
SetDlgItemText(hwnd, IDC_FROM, "Start address")
SetDlgItemText(hwnd, IDC_TO, "Destination address")
Case WM_COMMAND
Select Case Left(wparam, )

.

End Select
Case WM_CTLCOLORDLG
.
End Select
.
End Select

DlgProc=False
End Function

Public WindowProc(ByVal hWindow As LongPtr,ByVal uMsg As Long ,ByVal wParam As LongPtr,ByVal lParam As LongPtr)
Select Case uMsg
case WM_CLOSE DestroyWindow(hWindow)
case WM_DESTROY
PostQuitMessage(0)
End Select
Ret=DefWindowProc(hWindow, uMsg, wParam, lParam)
WindowProc=False
End Function

یک اپلیکیشن می تواند قبل از بستن پنجره پیامی را توسط کامپیوتر ارسال کند ( Prompt ) ، توسط فرآیند پیام WM_CLOSE و فراخوانی تابع DestroyWindow تنها اگر کاربر انتخاب را تائید کند. (یعنی اگر کاربر IDCANCEL را بفشارد تابع DestroyWindow با پیام WM_CLOSE که به پنجره می فرستد منجر به بستن آن خواهد شد.)

بصورت دیفالت تابع DefWindowProc تابع DestroyWindow برای بستن پنجره فرا می خواند ( Call ) ... برای تایع بالا گفته شده

Public lpPrevWindProc As LongPtr

GWL_WNDPROC=(-4)

در HOOK برای DLG می توان از   SetWindowLongPtr   استفاده کرد و به fnWindProc آدرس داد و در آنجا پیام هایی را به پنجره ارسال کرد.

Function fnWindProcWrapper(ByVal hWnd As LongPtr, _ ByVal uMessage As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) _ As Long
' [Add your code here]
CallWindowProc lpPrevWindProc, hWnd, uMessage, wParam, lParam

End Function 

پنجره اکسس در اینجا hook شده ولی توصیه نمیشود چون اگر پنجره ای دیگر باز شود اگر نتوانید هندل آنها را بدست آورید به آنها ارسال خواهد شد و ممکن است سیستم هنگ کند و مجبور به End Process از پنجره Task Manager شوید.

Function HookWindProc()

MsgBox "Hook WinProc"

lpPrevWindProc = SetWindowLongPtr(Application.hWndAccessApp, GWL_WNDPROC, AddressOf fnWindProc)

End Function

مثال دیگر از WINDOWPROC : 

تابع زیر در ویندوز 32 بیت برای 64 باید از دیتا تایپ LONGPTR یا LONGLONG و قبل از FUNCTION نیز PTRSAFE بکار برده شود در نظر داشته باشید استعمال این توابع توصیه نمی شود چون واقعا UNSAFE می شود.

Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcA" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long


Public pVBProc As Long
' pointer to Window procedure
' The above variable defaults to 0 automatically

Public Function WindowProc (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' Call the default window procedure and return its result.
WindowProc = (hWnd, uMsg, wParam, lParam)
End Function
کد زیر را در هر کجا که مایل هستید قرار دهید

Dim retval As Long
' return value
If pVBProc = 0 Then
pVBProc = SetWindowLong(Form1.hWnd, GWL_WNDPROC,AddressOf WindowProc)
Else
retval=SetWindowLong(Form1.hWnd, GWL_WNDPROC, pVBProc)
pVBProc = 0
End If 

گرفتن HANDLE پنجره هایی که داخل پنجره اصلی قرار دارند

Declare Function EnumChildWindows Lib "user32" (byval hWndParent as Long, byval lpEnumFunc as Long, byval lParam as Long) as Long
Declare Function GetParent Lib "user32" (byval hwnd as Long) as Long


public Function VB_WndEnumProc(byval hwnd as Long, byval lParam as Long) as Long

'onerror resume next

Debug.Print hwnd & ";" & lParam
'Loop
WndEnumProc = 1

End Function

CENTER MESSAGEBOX :

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

Public hhk As Long
Private Type Rect
x As long
y As Long
End Type

Public Function CBTMessageBox(ByVal hwnd As Long,ByVal lpText As String,ByVal lpCaption As String,uType As Lonh)
hhk=SetWindowsHookEx(WH_CBT, AddressOf CBTProc,0, GetCurrentThreadId())
CBTMessageBox=MessageBox(hwnd, lpText,lpCaption,uType)
End Function

Public Function CBTProc(ByVal nCode As Long,ByVal wParam As Long,lParam As Long)

Dim hParentWnd As Long
Dim hChildWnd As Long
'msgbox is "child"
Dim rParent,rChild,rDesktop As Rect
Dim pCenter, pStart As POINTAPI
Dim nWidth, nHeight As Long

'window handle is wParam

if nCode = HCBT_ACTIVATE Then
'set window handles
hParentWnd = GetForegroundWindow()
hChildWnd = wParam

if ((hParentWnd <> 0) And (hChildWnd <> 0) And (GetWindowRect(GetDesktopWindow(), &rDesktop) <>0) And (GetWindowRect(hParentWnd, &rParent) <>0) And (GetWindowRect(hChildWnd, &rChild) <>))  Then


'calculate message box dimensions nWidth = (rChild.right - rChild.left) nHeight = (rChild.bottom - rChild.top) 'calculate parent window center point pCenter.x = rParent.left+((rParent.right - rParent.left)/2)
pCenter.y = rParent.top+((rParent.bottom - rParent.top)/2)
'calculate message box starting point pStart.x = (pCenter.x - (nWidth/2)) pStart.y = (pCenter.y - (nHeight/2))


'adjust if message box is off desktop if(pStart.x < 0) Then pStart.x = 0
if(pStart.y < 0) ThenpStart.y = 0
if(pStart.x + nWidth > rDesktop.right) Then
pStart.x = rDesktop.right - nWidth
End If
if(pStart.y + nHeight > rDesktop.bottom) Then
pStart.y = rDesktop.bottom - nHeight
End If

'move message box MoveWindow(hChildWnd,pStart.x, pStart.y,nWidth,nHeight,FALSE)
'exit CBT hook UnhookWindowsHookEx(hhk)

Else
CallNextHookEx(hhk, nCode, wParam, lParam)
End if
End if
CBTProc=False
End Function

Ribbon

 tabs

"TabHomeAccess"

 tabs

ribbon

backstage   : button & Tab

  "FileSaveAsCurrentFileFormat"

  "FileOpen" visible="false"

  "FileCloseDatabase"

  "TabInfo"

  "FileSave"

  "TabPrint"

  "TabHelp"

  "ApplicationOptionsDialog"

DoCmd.ShowToolbar "Ribbon", acToolbarNo

    DoCmd.NavigateTo("acNavigationCategoryObjectType")
    'select the navigation pange
    'hide the selected object
    DoCmd.RunCommand(acCmdWindowHide)




Hide کردن تب Home اگر Group داخلش باشه Group باید اضافه شده و Disable شود 

Public Function CustomRibbon()
    Dim customXML As String

    customXML = "<customUI xmlns=""http://schemas.microsoft.com/office" _
                & "/2009/07/customui"">" _
                & "  <ribbon startFromScratch=""false"">" _
                & "    <tabs>" _
                & "      <tab idMso=""TabHomeAccess"" visible=""false"" />" _
                & "    </tabs>" _
                & "  </ribbon>" _
                & "</customUI>"

    Application.LoadCustomUI "HideHome", customXML
End Function

Windows management instrumentations

"winmgmts:"

win32-networkadapterconfiguration

 IPENABLED دارد که دیتا تایپ آن BOOLEAN است و میشود IPADDRESS های فعال که دیتا تایپ String دارد و باید بعد از استفاده از متد ExecutedQuery آبجکت WMI در آن لوپ زده شود.

Set objQuery = objWMI.ExecQuery("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True")

win32-process

کلاس Win32_Pocess فرآیندهایی که در سیستم کاری وجود دارد. متد Terminate دارد که می توانید به اجرای فرآیند خاتمه دهید شامل آیتم هایی است که در لینک مشاهده کنید یکی از آنها Name است می توانید در Select از آن استفاده کنید و فرضا مسیر Excel.Exe را در آن بگذارید و بعد از Set کردن Variable به آبجکت آنرا Terminate نمائید.

Set objQuery = objWMI.ExecQuery("Select * from Win32_Process Where Name= .....")

With objQuery

.Terminate

End With 

win32-logicaldisk

کلاس Win32_logicaldisk شامل اطلاعاتی درباره درایوها است و آیتم هایی دارد مثل گرفتن سریال نامبر

VolumeSerialNumber

win32-diskdrive

کلاس Win32_Diskdrive شامل اطلاعات درایوها ست و آیتم هایی دارد مثل SerialNumber که لوپ زده میشود و مقدار را بدست می آوریم.

Set ColItems = objWMIService.ExecQuery( _ "SELECT * FROM Win32_DiskDrive") Dim i As Integer 

'For Each ObjItem In ColItems

win32-networkconnection

Get MACAddress win32-networkadapter

Get MACAddress win32-networkadapterconfiguration

IPEnabled / IPAddress  / MACAddress

Win32_OperatingSystem

SerialNumber

Method : Reboot ( Shut & Restart )

API : 

nf-fileapi-getvolumeinformationa

----------------------------------------

Get serial number for hard disks

wmic diskdrive get serialnumber

Example:

c:\>wmic diskdrive get serialnumber
SerialNumber
FR3AG13032430BC13S

Get serial number for mother boards

wmic baseboard get serialnumber

See also get-disk-drive-information-in-windows-10-with-this-command/amp/

MotherBoard  command/Windows/wmic/en-us/wmicBASEBOARD

See Also to minimze or maximize window of application win32/shell/shell-shellexecute

ShellExecute

Dim objShell
Set objShell = CreateObject("WScript.Shell")
objShell.Run "cmd /c dir > test.txt"


'Create shell object
Dim objShell
Set objShell = CreateObject("WScript.Shell")
'call Notepad program
objShell.Run "notepad.exe",1,true
MsgBox "I know what you wrote :-)"

"Wscript.Shell"  SendKeys  2b56c24affdd

Wscript.Shell

Run

SpecialFolders("strfoldername")

CreateShortCut

Save

strFolderName : One of the following special folders 
                   (not all are available to all flavors of Windows)
      AllUsersDesktop
      AllUsersStartMenu
      AllUsersPrograms
      AllUsersStartup
      Desktop
      Favorites
      Fonts
      MyDocuments
      NetHood
      PrintHood
      Programs
      Recent
      SendTo
      StartMenu
      Startup
      Templates

ShutDown Message " 

Shell "Cmd /c Shutdown -s -t "

shutdown -L

You cannot hide the cmd window with any batch file command. You can launch the batch file from a vbscript and have it run as a background process which hides the cmd window. You could put powershell -window hidden -command "" in your script

"wmic diskdrive get model,serialNumber,index,media > C:\path\to\text.txt"

--------------

I made log table, I have the back-end database on a server, and a few front-end files in the office, and i want to log all the users who access the back-end.

I used the Environ function, it provides me the computer name / user name and anything else i need, but it doesn't show the IP address. The functions I made are working, all I need is to get the IP address..

'ExecQuery

'Win32_NetworkAdapterConfiguration Where

'IPEnabled = True

For Each itm In myobj

  getMyIP = itm.IPAddress(0)

  Exit Function

Next

The "wscript.Network" object

Provides access to the shared resources on the network to which your computer is connected.

Properties :
.UserName
.ComputerName

Methods :
.SetDefaultPrinter
'SetDefaultPrinter "\\research\library1"
.AddWindowsPrinterConnectiob
'AddWindowsPrinterConnection(PrinterPath)
.RwmoveNetworkDrive


GetUser=CreateObject("wscript.Network").UserName

------------

getmac /v /fo csv > T:\macaddresses.csv

"HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Access\File MRU\Quick Access Display", iShow, "REG_DWORD"

iShow=0 Or 1

'USysRibbon

<backstage>
<tabidMso ="TabRecent" visible="false"/>
</backstage>

اضافه کردن All به کمبو باکس

Sub GetComboBoxList()
Dim strList, strSQL As String

strList = "<All>;"
With cboState
     With CurrentDb.OpenRecordset(.RowSource)
        Do Until .EOF
           strList = strList & !State & ";"
           .MoveNext
        Loop
End With
.RowSourceType = "Value List"
.RowSource = strList
End With
End Sub

در کد بالا از پراپرتی RowSourceType آبجکت کمبو باکس  برای باز شدن در RecordSet استفاده شده ، در رکوردست لوپ زده و گفته تا زمانیکه به انتهای فایل نرسیده All و مقادیر داخل فیلد State را در StrList موقتا ذخیره کند ( چون پابلیک تعریف نشده  فقط در همین رویه استفاده می شود و فرمان که تمام شد از بین میرود) و در آخر RowSource  شده StrList 

البته با union query هم می توان All را با آیتم های کمبو باکس همراه کرد ، fieldtobedataforcombo نام فیلدی که رکوردها یش باید در کمبو نمایش داده شوند.

Cbo1.RowSource="

Select distinct fieldtobedataforcombo from table1 

Union

Select "ALL" 

Group by fieldtobedataforcombo

Order by fieldtobedataforcombo" 

Cbo1.RowSourceType="Table/Query"

CurrentDb.Properties

Name 

Connect 

Transactions 

Updatable

CollatingOrder

QueryTimeout

Version

RecordsAffected

ReplicaID

DesignMasterID

Connection

ANSIQuery Mode 

Themed Form Controls

AccessVersion

Build

ProjVer

StartUpForm

StartUpShowDBWindow

StartUpShowStatusBar

AllowShortcutMenus

AllowFullMenus

AllowBuiltInToolbars

AllowToolbarChanges

AllowSpecialKeys

UseAppIconForFrmRpt

Track Name AutoCorrect Info

Perform Name AutoCorrect 

AppTitle

AppIcon

تنظیم پراپرتی های موجود در دیتابیس با کد زیر که از سایت خارجی استخراج شده اگر درست کار کند.

FunctionName(Name,Type,Value) As Boolean


On Error Resume Next

Set dbs = CurrentDb
On Error GoTo Change_Err
dbs.Properties(strPropName) =varPropValue
ChangeProperty = True


If err=3270 Then ' Not Found
Set prp=dbs.CreateProperty(strPropName, varPropType, varPropValue)
dbs.Properties.Append prp
Else
ChangeProperty = False
Exit Function
End If
End Function

Application.RefreshTitleBar

2003 :

You can set the StartupShowDBWindow property to False to hide the Database window so the user can't see the tables, queries, macros, and modules within your database

Application.SetOption : 

Application.SetOption "Selection Behavior", 1

set-options-from-visual-basic

SendIcon : 

hWnd = Application.hWndAccessApp

    lcon = ExtractIcon(0, sIcon, 0)

    If lcon > 1 Then

        SendMessage(hWnd, WM_SETICON, True, Icon)

        SendMessage(hWnd, WM_SETICON, False, lIcon)

    End If

محدود کردن تعداد رکورد در فرم کانتینیوس

:Oncurrent

Me.AllowAdditions = (Me.Recordset.RecordCount <20)

تا زمانیکه پراپرتی RecordCount در آبجکت رکوردست برابر 19 است  پراپرتی AllowAdditions فرم True است و شما اجازه اضافه کردن به آن را دارید درصورتیکه تعداد رکوردها بیست شد پراپرتی به False تنظیم و از اضافه کردن جلوگیری خواهد نمود. 

Report Properties رکورد خالی

در گزارش برای ایجاد ردیف دو نوع Running Sum وجود دارد یکی OverAll بصورت کلی  و دیگری OverGroup  جمع در هر گروه و اگر مقدار گروه عوض شد دوباره از یک شروع میشود 

You can create a text box with a running sum over group and control source of =1. Name the text box txtGrpRunSum. The text box does not need to be visible.

MoveLayout: if False, prints on top of what was printed last;

NextRecord: if False, prints the same record again;

PrintSection: if False, doesn't print any data.

سه تا از پراپرتی های گزارش زمان استفاده از پراپرتی NextRecord در Detail_OnPrint اگر False باشد همان رکورد را پرینت میکند در صفحه ( یعنی رکورد تکرار میشود ) . اگر PrintSection نیز False باشد هیچ داده ای پرینت نمی شود.

در PageHeader_OnFormat می توان متغیری را تعریف  و مقدار آنرا False کنیدبرای NextRecord. و متغیری هم برای شمارش لاین ها ولی در اینجا مقدارش به صفر تنظیم و در OnPrint دیتیل اگر PrintCount  برابر یک بود لاین هم افزایشی میشود.

متغیرها باید در خارج از Event تعریف شده باشند 

مثال زیر نشان می دهد چگونه می توان از پراپرتی PrintCount استفاده نمود تا مطمئن شوید مقدار کنترل OrderAmount فقط یکبار به running total اضافه شده.

Running Total می تواند متغیر public باشد یا نام یک کنترل unbound که هر بار که section پرینت میشود به آن اضافه شود 

Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)

If PrintCount = 1 Then 

RunningTotal = RunningTotal + OrderAmount

End If

End Sub

هر بار که OnPrint  اجرا میشود PrintCount نیز افزایشی میشود و همانطور که سکشن بعدی پرینت می شود ( در صفحه منظور نه ارسال به پرینتر !!! ) ، اکسس پراپرتی PrintCount را به 0 بر می گرداند یا باصطلاح Reset میشود.

نمونه ای از بکارگیری NextRecord و PrintSection اگر دومی استفاده نشود چه اتفاقی خواهد افتاد ؟ 

در زیر تعریف شده که در هر پیج 22 لاین نمایش داده شود و بقیه به پیج های بعدی منتقل شود.

متغیر MaxL تعریف شده یعنی حداکثر لاین در Page 

متغیر C تعریف شده یعنی Count کوئری که در گزارش فیلتر شده فرضا از OpenReport در فرم Launch شده.و در رویداد Open گزارش قرار داده شده.

OnPrint:

If PrintCount=1 Then L=L+1

Option Compare Database

Option Explicit

Const MaxL As Integer = 22 'Lines

Private C As Integer 'Total

Private Sub Report_Open(Cancel As Integer) 

' get total record count

C= DCount("*", "qryData") 

End Sub

متغیری باید تعریف کرد که در هر بار مقداری افزایشی به آن نسبت داده شود مثل L

فرضا در کوئری 28 رکورد نمایش داده می شود در حالیکه گفته شده  تنها 22 رکورد ( MaxL ) در هر Page باشد.

زمانیکه L Mod 22 برابر صفر شود و اگر L مخالف RLines شود PageBreak که در سکشن دیتیل قرار داده True  شده و بقیه رکوردها به صفحه بعد میرود.

محاسبه تعداد کلی خطوط : 

'calculate the total number of lines 'required.

RLines = ((C \ L) + 1) * L

زمان نمایش رکوردهای تکرار شده تا پایان صفحه که پر میشود می توانید پراپرتی ForeColor کنترل ها را به VbWhite تغییر داد.

برای نمایش تعداد 20 رکورد از هر گروه در گزارش می توانید شرطی در کوئری بگذارید.

سه فیلد State ، Town ، Pop از جدول MyTable را انتخاب کرده البته 20 رکورد از هر State  در گروپ گزارش می آید.

SELECT  State, 

        Town, 

        Pop 

FROM    MyTable 

WHERE   Pop In 

        (SELECT Top 20 Pop 

        FROM    MyTable As T2 

        WHERE   T2.State = MyTable.State 

        ORDER BY Pop Desc

ImageProcess Object ( تغییرات روی تصویر )

پست زیر درباره  مواردی که می توان روی Image انجام داد مثل تغییر سایز ( Scale ) یا Rotation و  Resolusion

ImageProcess : 

مدیریت زنجیره ی Filter . آبجکت ImageProcess می تواند با استفاده از  WIA.ImageProcess ساخته شود.

ImageProcess.FilterInfos Property : 

مجموعه ای از تمام فیلترهای موجود را فراخوانی میکند . هر عکسی شامل یکسری داده است مثل ارتفاع ، رزلوشن که اینها در زنجیره فیلتر جمع آوری یا Collect شده اند. شما به اینها دسترسی پیدا می کنید و هر کدام که ReadOnly  نباشد می توانید تغییر و ذخیره کنید.

برای لود یک فایل یا ذخیره از آبجکت ImageFile استفاده میشود و برای ساختش از عبارت WIA.ImageFile داخل CreateObject و تنظیم آن به یک Variable استفاده میشود یا می توانید از رفرنس هایی که در Vba وجود دارد تیک آنرا بزنید و دیگر از CreateObject استفاده کنید.

Set Img=CreateObject("WIA.ImageFile")

Img.LoadFile(path & filename)

Method : LoadFile , SaveFile 

آبجکت ImageFile یک ظرف است که Image هایی را که به کامپیوتر ارسال می کنید در آن نگهداری میشود و دارای دو متد بالاست و پراپرتی هایی از جمله Width و Height و ....

آبجکت ImageProcess حاوی FilterInfos مجموعه ای از تمام فیلترهای موجود ,  Filters مجموعه فیلترهایی که باید به یک ImageFile    اعمال شود .و  متد Apply برای اقدام و انجام.

پس با توجه به یادداشت بالا می بایست از Add استفاده کنیم برای اضافه کردن FilterInfos به مجموعه Filters.

Set IP=CreateObject("WIA.ImageProcess")

'Assign Filters

'Appends or inserts a new Filter of the 'specified FilterID into a Filters collection.

'Method Add ( اضافه یا درج فیلتر جدید داخل مجموعه فیلتر)

IP.Filters.Add IP.FilterInfos("Scale").FilterID

'Retrieves the FilterID (FilterInfo) for this filter.

IP.Filters(1).Properties("MaximumWidth")=

IP.Filters(1).Properties("MaximumHeigth")=

'Filter APPLY On Inage

Set Img=IP.Apply(Img)

Img.SaveFile(.....)

wingdi-createcompatiblebitmap

.

Label Behind The Button

در رویداد MouseDown کنترل ..... cmdClose 

Me.cmdClose.BackStyle = 0 'transparent

در رویداد MouseUp کنترل ...... cmdClose

  Me.cmdClose.BackStyle = 1 'Normal

.

کامند باتن Rectangle و MouseMove

این مطلب توسط نویسنده‌اش رمزگذاری شده است و برای مشاهده‌ی آن احتیاج به وارد کردن رمز عبور دارید.