کلینیک فوق تخصصی اکسس ( کاربرد vba در اکسس )

کلینیک فوق تخصصی اکسس ( کاربرد vba در اکسس )

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

کلینیک فوق تخصصی اکسس ( کاربرد vba در اکسس )

به اشتراک گذاری اطلاعات کسب شده در اکسس از سایت آفیس و سایت های تخصصی خارجی

کاربرد چند تابع 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_BITMAPMF_OWNERDRAW یا MF_STRING باشد




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

  • MF_BYCOMMAND and MF_BYPOSITION
  • MF_DISABLEDMF_ENABLED, and MF_GRAYED
  • MF_BITMAPMF_STRINGMF_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








GETWINDOWRECT نمایش باتن ساخته شده در InputBox



دادن  ابعاد مستطیل پنجره ی مشخص شده ( ابعاد در مختصات صفحه داده میشود ) در ClientRect عدد x  و y  گوشه ی بالایی صفر است 


Retrieves the dimensions of the bounding  rectangle of the specified window. The dimensions are given in screen coordinates  that are relative to the upper-left 

.corner of the screen


برای اضافه کردن باتن ازCreateWindowEx استفاده میشود . در زمان ساب کلاس کردن و قرار دادن در پیام SHOWWINDOW و استفاده از استایل WS_CHILD OR WS_VISIBLE اگر بخواهیم میتوان از BS_OWNERDRAW استفاده کرد و باتن خود را در پیام CTLCOLORBTB ( که lparam هندلی است برای هندل باتن ) ترسیم کرد .


فرضا اگر به InputBox  در زیر باتن کنسل بخواهیم باتنی اضافه کنیم می توانیم با GetWindowRect موقعیت باتن کنسل را بگیریم  منظور X و Y گوشه بالایی و با GetClientRect عرض و طول باتن Cancel را بدست آوریم  ( همانطور که گفته شد GetClientRect گوشه بالایی هر کنترلی را صفر میدهد )  


Dim WinRect As RECT 

Dim BtnWinRect As RECT 

Dim BtnClientRect As RECT

Dim CyFrame As Long 

(CyFrame=GetSystemMetrics(SM_CYFRAME

(CyCaption=GetSystemMetrics(SM_CYCAPTION

GetWindowRect Hwnd,WinRect

GetWindowRect BtnHandle,BtnRect

GetClientRect BtnHandle,BtnClientRect


ابعاد زیر میشود پارامترهایی که باید در آرگومانهای تابع CreateWindowEx قراردهیم x1,y1 میشود مختصات گوشه ی بالایی سمت چپ  و cx (  عرض ) و cy ( ارتفاع ) یا x2 و y2 میشود مختصات گوشه پایینی سمت راست 


LeftBound=(BtnWinRect.Left-WinRect.Left)+CyFrame

TopBound=(BtnWinRect.Top-WinRect.Top)+CyFrame

(CyCaption/2)+

RightBound'

Width=BtnClientRect.Rigth-BtnClientRect.Left

BottomBound'

Height=BtnClientRect.Bottom-BtnClientRect.Top





MOUSEMOVE / XPOS

WParwm : LBUTTON Or RBUTTON

lParam

Lo مختصات x کرسر را مشخص میکند . مختصات مرتبط با گوشه چپ بالایی از منطقه Client

The low-order word specifies the x-coordinate of the cursor. The coordinate is relative to the upper-left corner of the client area

ho مختصات y کرسر را مشخص میکند . مختصات  مرتبط با گوشه چپ بالایی منطقه Client

The high-order word specifies the y-coordinate of the cursor. The coordinate is relative to the upper-left corner of the client area


در کل مختصات x و y  گوشه چپ بالایی منطقه Client را مشخص می نماید. 




Case WM_MOUSEMOVE

       

         Dim rw As RECT

         Dim rc As RECT

         Dim pp As POINTAPI

         

         GetWindowRect BtnOk, rw

         pp.x = rw.left

         pp.y = rw.top

         ClientToScreen BtnOk, pp

         GetCursorPos pp

         If Not PtInRect(rw, pp) Then'

         ' MsgBox "rt'

         'End If'

         SetWindowTextA hwnd, pp.x & "," & pp.y & "...." & rw.left & "," & rw.top







اگر ازGetClientRect استفاده کنید مختصات left و Topرا صفر میدهد.


dim rw As RECT

GetWindowRect hwndBtnOk,rw

dim pp as POINTAPI

(pp.x = LoWord(lParam

        ( pp.y = HiWord(lParam

         

          MoveWindow hwndBtnOk, pp.x, pp.y, (rw.right - rw.left), (rw.bottom - rw.top), 1



The &H prefix denotes a number represented in hexadecimal (base 16) notation.

Hexadecimal digits, like decimal, start at 0, but go up to 
.(F (16

e.g. 0 1 2 3 4 5 6 7 8 9 A B C D E F, 10 11 12 13 14 15 16 17 18 19 1A 1B etc.

In C-based languages hexadecimal numbers are prefixed with 0x, eg. 0x10000. This is directly equal to 
H10000 in VB&

Hex To Decimal