MultiSelection Microsoft Access

ComboBox.ItemData property (Access) :

expression.ItemData (Index)

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

با استفاده از مجموعه ItemSelected می توانید تعیین کنید که کدام ردیف یا ردیف ها در لیست باکس آن انتخاب شده 

باید پراپرتی MultiSelect لیست یاکس به Simple یا Extended تنظیم شود تا کاربر قادر به انتخاب بیشتر از یک ردیف باشد.

از پراپرتی Column هم می توانید استفاده کنید که داده کدام ستون و ردیف برگردانده شود.

ListBox.ItemsSelected property (Access) :

مجموعه ItemSelected دو پراپرتی Count و Item دارد بدون داشتن هیچ متدی البته

Dim frm As Form, ctl As Control

Dim varItm As Variant

Set frm = Forms!Contacts

Set ctl = frm!Names

For Each varItm In ctl.ItemsSelected

Debug.Print ctl.ItemData(varItm)

Next varItm

مثال بالا مقدار باند کالمن هر ردیف انتخاب شده را چاپ میکند در پنجره immidiate window

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

Private Sub cmdOpenReport_Click()

    Dim varItem As Variant

    Dim strEmployeeIDList As String

    Dim strCriteria As String

    Dim ctrl As Control    

    Set ctrl = Me.lstEmployees    

با پراپرتی کانت چک میکند که حداقل یک گزینه از لیست باکس انتخاب شده باشد.

    If ctrl.ItemsSelected.Count > 0 Then

در کد For Each....Next  داده آیتم یا آیتم های انتخاب شده را با پراپرتی ItemData ی کنترل میگیرد ، بین آنها کاما گذاشته و به متغیر strEmployerIDList میدهد

        For Each varItem In ctrl.ItemsSelected

            strEmployeeIDList = strEmployeeIDList & "," & ctrl.ItemData(varItem)

        Next varItem

      چون یک کاما قبل از اولین آیدی گرفته شده ( متغیر)  قرار می گیرد با تابع Mid گفته که عبارت بعد از کاما در متغیر قرار گیرد در نتیجه آن کاما حذف میشود.

        ' remove leading comma

        strEmployeeIDList = Mid(strEmployeeIDList, 2)     

حال نوبت به نوشتن شرط یا Criteria است که در  آرگومان WhereCondition  قرار داده شده  in هم کلمه ای است رزرو شده که در عبارات sql استفاده میشود و بیان نموده که strEmployeeIDList هایی که در فیلد EmployeeID ( دیتا تایپ نامبر است ) موجود است فهرست شوند .... چون ID نامبراست احتیاجی نیست که بین هر داده گرفته شده کوتیشن قرار گیرد ولی اگر دیتا تایپ فیلد تکست بود می بایست بین هر داده ای که از لیست باکس گرفته میشود غیر از همرا بودن با کاما ، تک کوتیشن نیز در ابتدا و انتهای آن قرار گیرد.

        strCriteria = "EmployeeID In(" & strEmployeeIDList & ")"

در کد زیر دستور باز شدن گزارش rptEmployees با چشم انداز Preview و شرط strCriteria داده شدس.

        DoCmd.OpenReport "rptEmployees", _

            View:=acViewPreview, _

            WhereCondition:=strCriteria

    Else

اگر هیچ آیتمی در لیست باکس انتخاب نشده باشد پیغامی را با Msgbox رایز میکند با پرامپت هیچ کارمندی انتخاب نشده.

        MsgBox "No employees selected", vbInformation, "Warning"

    End If

   

End Sub

expression.Column (Index, Row)

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

.Column(1,2)

زمانیکه پراپرتی MultiSelect کنترل لیست باکس به None تنظیم شود فقط یک آیتم می تواند انتخاب شود و پراپرتی Selected می تواند به True تنظیم شود.وقتی پراپرتی MultiSelect کنترل لیست باکسی به Simple یا Extended تنظیم شود هر کدام یا تمام آیتم های انتخاب شده می تواند پراپرتی Selected برابر True خودش را داشته باشد. پس مشخص شد با Selected می توانید مشخص کنید کدام آیتم یا آیتم ها Select شده اگر True باشد انتخاب میشود و اگر به False تنظیم شود از حالت انتخاب در می آید.

لیست باکس چند انتخابی یا Multi-Selection باند شده به فیلدی همیشه دارای پراپرتی Value مساوی با Null است . می توان از پراپرتی Selected یا مجموعه ItemSelected برای بازیابی اطلاعات آیتم هایی که انتخاب شده اند ، استفاده نمود.

 عبارت زیر پنجمین آیتم در لیست را انتخاب ( Select ) می نماید

نام کنترل لیست باکس در اینجا ListBox1 است

 Me!Listbox1.Selected(4)=True

ComboBox.LimitToList property (Access) :

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

Forms("Order Entry").Controls("States").LimitToList = True 

اگر بخواهید پیغام خودتان را نشان دهد در رویداد NotInList می توانید Response را مساوی صفر و پیام مورد نظرتان را در Msgbox قرار دهید

ComboBox.ListCount property (Access) :

تعیین تعداد ردیف های لیست باکس قسمتی از کمبو باکس ( کمبو باکس همانطور که در یادداشت های دیگر گفته شده یک قسمت تکست باکس و یک قسمت DropDown دارد.

اگر  پراپرتی ColumnHeads به True تنظیم شود این ردیف هم اضافه میشود یعنی ایندکس آن صفر است

ComboBox.ListRows property (Access) :

برای تنظیم حداکثر تعداد ردیف هایی که در لیست باکس قسمت کمبو باکس نمایش داده شود کاربرد دارد.

ComboBox.Locked property (Access) :

پراپرتی Locked مشخص میکند که می توان داده را در کنترلی در فرم ویرایش کرد.دیفالت True است

و این تنظیم اجازه ویرایش ، حذف و اضافه کردن داده را می دهد.

ComboBox.ListIndex property (Access) : 

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

مقدار پراپرتی ListIndex با تنظیم پراپرتی BoundColumn به صفر در دسترس است. اگر پراپرتی BoundColumn مقدار صفر بگیرد فیلدی که به کمبو یا لیست باکس باند شده حاوی همان مقداری خواهد شد که پراپزتی ListIndex تنظیم شده.

Here is the code to take data from a list box to a table...

Code:

کد زیر برای بردن داده از یک لیست باکس به یک جدول  و از کوئری Append استفاده شده البته Sql آن .

Private Sub Command14_Click()

Dim varName As Variant

Dim varItem As Variant

Dim strSQL As String

Dim undSQL As String

Dim CmbValue As String 

CmbValue = Me.Combo0.Value 

With Me.List9 

For Each varItem In .ItemsSelected

در عبارت Sql زیر در Insert into نام جدول و بعد داخل پرانتز نام فیلدهایی که باید داده به آن اضافه شوند و بعد Values و داخل پرانتز داده ها برای داده های فیلد از نوع دیتا تایپ تکست از تک کوتیشن در ابتدا و انتهای متغیر استفاده می شود . به پرانتزها و فواصل توجه کنید وگرنه خطای Syntax یا نوشتاری خواهید گرفت.

strSQL = "INSERT INTO tlbTempRecordset (UnderwriterName, ST_CODE) VALUES ('" & .Column(0) & "','" & .ItemData(varItem) & "');"

DoCmd.RunSQL (strSQL)

عبارت زیر حتما باید اعمال گردد وگرنه مقادیر تکرار و تکرار میشوند چون در لوپ هستیم   و اتومات Reset  نمی شود عزیزان

strSQL = ""

Next varItem 

End With 

Me.List9.Value = Null 

End Sub

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

is

DRAWITEM ... LISTBOX

Type NCCALCSIZEPARAM

rgrc(3) As RECT

lpos As WINDOWPOS

End Type

lParam

If wParam is TRUE, lParam points to an NCCALCSIZE_PARAMS structure that contains information an application can use to calculate the new size and position of the client rectangle.

If wParam is FALSE, lParam points to a RECTstructure. On entry, the structure contains the proposed window rectangle for the window. On exit, the structure should contain the screen coordinates of the corresponding window client area

Function fnListSubClass(ByVal hwnd As LongPtr,ByVal msg As Long,ByVal wParam As LongPtr,ByVal lParam As LongPtr)

Select Case msg

case WM_NCCALCSIZE

CallWindowProc listboxProc,hwnd,msg, wParam, lParam
'what is doing???
RECT* pRect = (RECT*)lParam
pRect->left+=4;
pRect->top+=23;
pRect->bottom+=23;
return 0;

case WM_NCPAINT

hdc=GetDC(hwnd) GetClientRect hwnd,rect
SetRect rect,0,0,4, rect.bottom brush=LoadBitmap(GetModuleHandle(0), MAKEINTRESOURCE(IDB_BORDER))
newBrush=CreatePatternBrush(brush)
oldBrush=SelectObject(hdc, newBrush) FillRect hdc,rect,newBrush SelectObject hdc, oldBrush
DeleteObject newBrush
DeleteObject oldBrush
DeleteObject brush
UpdateWindow hwnd
ReleaseDC hwnd, hdc
Exit Function



fnListSubClass=CallWindowProc(listboxProc, hwnd

(msg, wParam, lParam,

End Function 

Function WinProc(ByVal hwnd As LongPtr,ByVal msg As Long,ByVal wParam As LongPtr,ByVal lParam As 

(LongPtr

CASE WM_SHOWWINDOW,WM_CREATE 

listboxProc=SetWindowLongPtrA(listbox, GWL_WNDPROC,AddressOf fnListSubClass)

SendMessage listbox,WM_SETFONT, CreateFont=tahoma16, true

Case WM_DRAWITEM

Dim pdis AS DRAWITEMSTRUCT

CopyMemory pdis,ByVal lParam,40

if pdis.itemID=-1 Then Exit Function

Dim txt As String*40

SendMessage pdis.hwndItem,LB_GETTEXT,pdis.itemID, text

(itemLength=Len(text

if(pdis.itemAction=ODA_FOCUS Or pdis.itemState And ODS_FOCUS) Then 

(SetTextColor pdis.hDC,RGB(255,255,255

(SetBkColor pdis.hDC,RGB(51,94,168

FillRect pdis.hDC,pdis.rcItem

((CreateSolidBrush(RGB(51,94,168,

  

Else

(SetTextColor pdis.hDC,RGB(0,0,0

(SetBkColor pdis.hDC,RGB(255,255,255

FillRect pdis.hDC,pdis.rcItem

((CreateSolidBrush(RGB(255,255,255,

End if 

DrawTextExW pdis.hDC,text,itemLength, pdis.rcItem,DT_CENTER Or DT_END_ELLIPSIS,0

if(pdis.itemState=ODS_FOCUS) Then DrawFocusRect pdis.hDC,pdis.rcItem

End if 

CopyMemory ByVal lParam,pdis,40

Case WM_DESTROY

SetWindowLongPtrA hwnd,GWL_WNDPROC,listboxProc

WM_NCCREATE

We handle WM_NCCREATE because we want to associate so data with the LISTBOX and make a minor modification to the LISTBOX style. Creating our data is a simple and store in the window properties.

We modify the style by adding the WS_HSCROLL if the LISTBOX doesn't already have it. Without this style the horizontal scrollbar won't show no matter what we do.

WM_NCDESTROY

Here we simply destroy our data structure and remove it from the window properties. Nothing exciting.

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

Code:

Private Sub Form_Load()
 Dim I As Integer
    
 For I = 15 To 0 Step -1
   'Load a List of 0 to 15 with the Item Data
   'Set to the QBColors 0 - 15
   List1.AddItem "Color " & I
   List1.itemData(List1.NewIndex) = QBColor(I)
 Next
    
 For I = 0 To 15
   'Load a List of 0 to 15 with the Item Data
   'Set to the QBColors 0 - 15
   List2.AddItem "Color " & I
   List2.itemData(List2.NewIndex) = QBColor(I)
 Next
    
 'Subclass the "Form", to Capture the Listbox Notification Messages
 lPrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf SubClassedList)
End Sub

Private Sub Form_Unload(Cancel As Integer)
 'Release the SubClassing, Very Import to Prevent Crashing!
 Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevWndProc)
End Sub

.BAS Code

Code:

Option Explicit

Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Public Type DRAWITEMSTRUCT
        CtlType As Long
        CtlID As Long
        itemID As Long
        itemAction As Long
        itemState As Long
        hwndItem As Long
        hdc As Long
        rcItem As RECT
        itemData As Long
End Type

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Public Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Public Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Public Const COLOR_HIGHLIGHT = 13
Public Const COLOR_HIGHLIGHTTEXT = 14
Public Const COLOR_WINDOW = 5
Public Const COLOR_WINDOWTEXT = 8
Public Const LB_GETTEXT = &H189
Public Const WM_DRAWITEM = &H2B
Public Const GWL_WNDPROC = (-4)
Public Const ODS_FOCUS = &H10
Public Const ODT_LISTBOX = 2

Public lPrevWndProc As Long

Public Function SubClassedList(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 Dim tItem As DRAWITEMSTRUCT
 Dim sBuff As String * 255
 Dim sItem As String
 Dim lBack As Long
    
 If Msg = WM_DRAWITEM Then
   'Redraw the listbox
   'This function only passes the Address of the DrawItem Structure, so we need to
   'use the CopyMemory API to Get a Copy into the Variable we setup:
   Call CopyMemory(tItem, ByVal lParam, Len(tItem))
        
   'Make sure we're dealing with a Listbox
   If tItem.CtlType = ODT_LISTBOX Then
     'Get the Item Text
     Call SendMessage(tItem.hwndItem, LB_GETTEXT, tItem.itemID, ByVal sBuff)
            
     sItem = Left(sBuff, InStr(sBuff, Chr(0)) - 1)
            
     If (tItem.itemState And ODS_FOCUS) Then
       'Item has Focus, Highlight it, I'm using the Default Focus
       'Colors for this example.
       lBack = CreateSolidBrush(GetSysColor(COLOR_HIGHLIGHT))
                
       Call FillRect(tItem.hdc, tItem.rcItem, lBack)
       Call SetBkColor(tItem.hdc, GetSysColor(COLOR_HIGHLIGHT))
       Call SetTextColor(tItem.hdc, GetSysColor(COLOR_HIGHLIGHTTEXT))
       TextOut tItem.hdc, tItem.rcItem.Left, tItem.rcItem.Top, ByVal sItem, Len(sItem)
       DrawFocusRect tItem.hdc, tItem.rcItem
     Else
       'Item Doesn't Have Focus, Draw it's Colored Background
       'Create a Brush using the Color we stored in ItemData
       lBack = CreateSolidBrush(tItem.itemData)
       'Paint the Item Area
       Call FillRect(tItem.hdc, tItem.rcItem, lBack)
                
       'Set the Text Colors
       Call SetBkColor(tItem.hdc, tItem.itemData)
       Call SetTextColor(tItem.hdc, IIf(tItem.itemData = vbBlack, vbWhite, vbBlack))
       
       'Display the Item Text
       TextOut tItem.hdc, tItem.rcItem.Left, tItem.rcItem.Top, ByVal sItem, Len(sItem)
     End If
            
     Call DeleteObject(lBack)
     
     'Don't Need to Pass a Value on as we've just handled the Message ourselves
     SubClassedList = 0
     Exit Function
   End If
 End If
    
 SubClassedList = CallWindowProc(lPrevWndProc, hwnd, Msg, wParam, lParam)
End Function

فقط در CopyMemory سایز ۴۰ را به آرگومان سومش تخصیص دهید و از ByVal lParam استفاده کنید.

در مورد LB_GETTEXT  : 

Return value

The return value is the length of the string, in TCHARs, excluding the terminating null character. If wParam does not specify a valid index, the return value is LB_ERR.

     Remarks

If the list box has an owner-drawn style but not the LBS_HASSTRINGS style, the buffer pointed to by the lParam parameter receives the value associated with the item (the item 

(data

ListBox در InputBox

Vb Uses Unicode For Text String hence delcare SendMessageW instead Of SendMessageA****

: Important Notes

Use -----> LBS_OWNERDRAWFIXED Or LBS_HASSTRINGS 

use -----> SendMessageW,   /   TextoutW

 To Add Item it is important to Use SendMessageA And Byval  "Item" you want to add like 

"SendMessageA hlist, &H180, 0, ByVal "FFF

case WM_DRAWITEM

Dim Buff As String * 255 ' important

GetClientRect pdis.hwndItem, pdis.rcItem

    r = pdis.rcItem

    l = SendMessageW(pdis.hwndItem, LB_GETTEXT, pdis.itemID, ByVal Buff

    SendMessageA pdis.hwndItem, LB_GETITEMRECT, pdis.itemID, r

    TextOutW pdis.hdc, r.Left, r.Top, ByVal Buff, l

"SendMessageA hlist, &H180, 0, ByVal "FFF

       "SendMessageA hlist, &H180, 0, ByVal "HHT

       "SendMessageA hlist, &H180, 0, ByVal "123E

       "سلام" SendMessageA hlist, &H180, 0, ByVal 

        "حاجی"SendMessageA hlist, &H180, 0, ByVal

if pdis.itemid mod 2=. then SetTextColor Else SetTextColor

If pdis.itemAction = ODA_SELECT Then

    ( l = SendMessageW(pdis.hwndItem, LB_GETTEXT, pdis.itemID, ByVal Buff

     SetWindowTextW hwnd, ByVal Buff

     End If

Static OldRect

If pdis.itemAction = ODA_SELECT Then

         ( l = SendMessageW(pdis.hwndItem, LB_GETTEXT, pdis.itemID, ByVal Buff

          SetWindowTextW hwnd, ByVal Buff

          r.Left = r.Left + 15

          (FillRect pdis.hdc, r, GetSysColorBrush(0

          InvalidateRect pdis.hwndItem, OldRect, 1

          OldRect = r

    End If

%WS_CHILD Or %LBS_OWNERDRAWFIXED Or %LBS_MULTICOLUMN Or %LBS_NOTIFY Or %WS_TABSTOP Or %WS_HSCROLL, %WS_EX_CLIENTEDGE
    

ListBox در InputBox

vb Uses Unicode for text string so use SendMessageW instead Of SendMessageA Function 

The list box has the LBS_OWNERDRAWFIXED and LBS_HASSTRINGS styles, in addition to the standard list box styles.

LBS_HASSTRINGS

Specifies that a list box contains items consisting of strings. The list box maintains the memory and addresses for the strings so that the application can use the LB_GETTEXT message to retrieve the text for a particular item. By default, all list boxes except owner-drawn list boxes have this style. You can create an owner-drawn list box either with or without this style.

کاملا به دو نکته ی زیر توجه شود : 

To obtain the exact length of the text, use the WM_GETTEXT, LB_GETTEXT, or CB_GETLBTEXT messages, or the GetWindowText function

LB_GETTEXT

The return value is the length of the string, in TCHARs, excluding the terminating  

(null character  ( hence buff+1

If the list box has an owner-drawn style but not the LBS_HASSTRINGS style, the buffer pointed to by the lParam parameter receives the value associated  with the item the item data

Means Use Byval

If the list box has WS_HSCROLL style and you insert a string wider than the list box, send an LB_SETHORIZONTALEXTENT message to ensure the horizontal scroll bar appears.

---

Case WM_MEASUREITEM

Case WM_DRAWITEM

    Dim pdis As DRAWITEMSTRUCT

    Dim tm As TEXTMETRIC

    Dim hDCMem As LongPtr

 CopyMemory pdis, ByVal lParam, 40

Select Case pdis.itemAction

          Case ODA_SELECT, ODA_DRAWENTIRE

Dim p As RECT

         GetClientRect pdis.hwndItem, pdis.rcitem

BitBlt pdis.hdc

SetBkMode pdis.hdc, 0

                        SetTextColor pdis.hdc, vbRed

                        TextOutA pdis.hdc, pdis.rcitem.Left,pdis.rcitem.Top, buffer$, 5

CopyMemory lParam, pdis,40

End Select 

---

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

LB_GETCOUNT message

Gets the number of items in a list box


wParam,lParam

Not used; must be zero


Dim index As Integer
Dim textBuff As String
(textBuff = Space(255
(NumItems=SendMessage(hWndList,LB_GETCOUNT,0,0

index use GETCURSEL'

Gets the index of the currently selected item)'

(if any, in a single-selection list box'

SendMessageW hWndList, LB_GETTEXT,index, textBuff
MsgBox textBuff 

docs.microsoft.com/enmeasureitemstruct

مثالی از کشیدن نقطه چین دور آیتم سلکت شده به زبان دیگر 

if  lpdis->itemState & ODS_SELECTED

* Set RECT coordinates to surround only the'

* bitmap.

rcBitmap.left=lpdis->rcItem.left

rcBitmap.top=lpdis->rcItem.top

rcBitmap.right=lpdis->rcItem.left+XBITMAP

rcBitmap.bottom=lpdis->rcItem.top + YBITMAP

* Draw a rectangle around bitmap to indicate'

* the selection.

DrawFocusRect lpdis->hDC, &rcBitmap

---

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

 Display the text associated with the item'

SendMessage lpdis->hwndItem

LB_GETTEXT,lpdis->itemID, (LPARAM) tchBuffer,

GetTextMetrics lpdis->hDC, &tm

GetClientRect lpdis.hwnditem,lpdis.rcItem'

-y=(lpdis->rcItem.bottom+lpdis->rcItem.top

tm.tmHeight) / 2

6+TextOutA lpdis->hDC,XBITMAP

(y,tchBuffer,len(tchBuffer,

SelectObject hdcMem, hbmpOld

DeleteDC hdcMem

---

The GetTextMetrics function fills the specified buffer with the metrics for the currently selected font

BOOL GetTextMetrics( HDC hdc, LPTEXTMETRIC lptm );

Parameters

hdc

A handle to the device context

lptm

A pointer to the TEXTMETRIC structure that receives the text metrics.


Type TEXTMETRICA
tmHeight As Long
tmWeight As Long
tmItalic As Long
tmMaxCharWidth As Long
tmUnderlined As Long
tmCharSet As Long
End Type

 : case WM_MEASUREITEM
;lpmis = (LPMEASUREITEMSTRUCT) lParam
;lpmis->itemHeight=20
;return TRUE

(DrawEntire(LPDRAWITEMSTRUCT lpDStruct

;(CRect rect(lpDStruct->rcItem
;HDC dc =lpDStruct->hDC
;MYLISTITEM *a = (MYLISTITEM*)lpDStruct->itemData

TextOut(dc,rect.left+20,rect.top+2,a->title,strlen(a-

;((title<

(if (lpDStruct->itemState & ODS_FOCUS

}

;(DrawFocusRect(dc,rect

{

clean up //

;(SelectObject(dc,hOldFont

;(SelectObject(dc,oldpen

;(SelectObject(dc,oldbrush

;logFont.lfHeight = 16

;logFont.lfWeight = FW_BOLD

;("strcpy(logFont.lfFaceName,"courier

;(hFont = CreateFontIndirect(&logFont

(hOldFont = (HFONT)SelectObject(dc,hFont

ListBox

Const LBN_SELCHANGE = 1

Const LBN_DBLCLK = 2

Const LBN_SELCANCEL = 3

Const LBN_SETFOCUS = 4

Const LBN_KILLFOCUS = 5

Const LB_ADDSTRING = &H180

Const LB_SETSEL = &H185

Const LB_SETCURSEL = &H186 Const LB_GETSEL = &H187

Const LB_GETCURSEL = &H188

Const LB_GETTEXT = &H189

Const LB_GETTEXTLEN = &H18A

Const LB_GETCOUNT = &H18B

Const LB_SELECTSTRING = &H18C

Const LB_GETITEMRECT = &H198

Const LB_GETITEMDATA = &H199

Const LB_SETITEMDATA = &H19A

Const LB_SELITEMRANGE = &H19B

Const LB_SETITEMHEIGHT = &H1A0

Const LB_GETITEMHEIGHT = &H1A1

private Const WM_NOTIFY=&H4E

public Const WM_COMMAND=&H111

Const WM_DRAWITEM =&H2B

Const ODA_FOCUS = &H4

Const ODS_FOCUS = &H10

Const ODS_SELECTED = &H1

?private lpListBox as ListBox

?set lpListBox = lpLB

?m_LBHwnd = lpListBox.hwnd

private Function LBSubcls_WndProc_V3(byval hwnd as Long, byval Msg as Long, byval wParam as Long, byval lParam as Long) as Long

Dim lCurind as Long

Select Case Msg 

Case WM_COMMAND

If lParam = m_LBHwnd then

LongInt2Int wParam, iHw, iLW

(Select Case (iHw

Case LBN_SELCHANGE

lCurind=SendMessage(lParam, LB_GETCURSEL,0,byval 0&)

If (lCurind Mod 3) = 0 then

lCurind = SendMessage(lParam, LB_SETCURSEL, lCurind + 1, byval 0&)

End If 

Debug.print " sendmessage returned:" & Hex$(lCurind)

Case LBN_SELCANCEL

lCurind=SendMessage(lParam, LB_GETCURSEL,0,byval 0&) 

Debug.print " lbnselcancel for:"; Hex$(lCurind)

End Select 

End If

Case WM_DRAWITEM

If LB_Drawitem(lParam) = 0 then 

LBSubcls_WndProc_V3 = 0 

Exit Function 

End If

Case else 

End Select

LBSubcls_WndProc_V3=CallWindowProc(oldWndProc,hwnd,Msg, wParam, lParam)

End Function

private Function LB_Drawitem(byval lParam as Long) as Integer

Dim drawstruct as DRAWITEMSTRUCT 

Dim szBuf(256) as Byte

CopyMemory drawstruct,byval lParam, len(drawstruct)

Dim i as Integer

Dim hbrGray as Long,hbrback as Long,szListStr as string ' * 256

Dim crback as Long,crtext as Long,lbuflen as Long

Select Case (drawstruct.CtlType)

   Case ODT_LISTBOX

lbuflen=SendMessagedrawstruct.hwndItem,LB_GETTEXTLENdrawstruct.itemID,byval 0&)

Redim szBuf(lbuflen+2)

lbuflen=SendMessage(drawstruct.hwndItem,LB_GETTEXT,drawstruct.itemID,szBuf(0))

i = drawstruct.itemID

If i Mod 3=0 then

hbrGray = CreateSolidBrush(GetSysColor(COLOR_GRAYTEXT))

 

GrayString drawstruct.hdc, hbrGray,byval 0&,szListStr, len(szListStr),drawstruct.rcItem.Left,drawstruct.rcItem.Top, 0,0

DeleteObject hbrGray 

crback=RGB(180, 180, 180) crtext=RGB(60, 60, 60) 

else

If (drawstruct.itemState And ODS_SELECTED)=ODS_SELECTED then 

crback=GetSysColor(COLOR_HIGHLIGHT)

crtext=GetSysColor(COLOR_HIGHLIGHTTEXT)

ElseIf (drawstruct.itemState And ODS_FOCUS)=ODS_FOCUS then

crback=GetSysColor(COLOR_WINDOW)

crtext=vbRed

else

End if 

If (drawstruct.itemState And ODS_FOCUS)= 

ODS_FOCUS then

crtext=vbRed

End If

End If

hbrback=CreateSolidBrush(crback)

FillRect drawstruct.hdc, drawstruct.rcItem,hbrback 

DeleteObject hbrback

SetBkColor drawstruct.hdc, crback

SetTextColor drawstruct.hdc, crtext 

TextOut drawstruct.hdcdrawstruct.rcItem.Left,drawstruct.rcItem.Top, szListStr,len(szListStr) 

TextOutBStr drawstruct.hdc, drawstruct.rcItem.Left,drawstruct.rcItem.Top,szBuf(0),lbuflen

If (drawstruct.itemState And ODS_FOCUS) then

DrawFocusRect drawstruct.hdc, drawstruct.rcItem

End If

LB_Drawitem = 1

End Select

End Function

private Function LBSubcls_WndProc_V4(byval hwnd as Long,byval Msg as Long, byval wParam as Long,byval lParam as Long) as Long

Dim iHw as Integer,iLW as Integer

Dim lCurind as Long

Select Case Msg 

Case WM_LBUTTONDOWN, WM_LBUTTONDBLCLK

LongInt2Int lParam, iHw, iLW

Debug.print " Mouse down at(" & iHw & "," & iLW &  ")"

lCurind=SendMessage(hwnd, LB_ITEMFROMPOINT,byval 0, byval lParam)

Debug.print "Index of btn down:" & Hex$(lCurind)

If (lCurind Mod 3) = 0 then 

LBSubcls_WndProc_V4 = 1

Exit Function

End If

,Case WM_KEYDOWN

LongInt2Int wParam, iHw, iLW 

Select Case (iLW)

Case vbKeyDown

lCurind=SendMessage(hwnd, LB_GETCARETINDEX,0,byval 0&) 

Debug.print " Keydown With Itemid :" & Hex$(lCurind) 

If ((lCurind + 1) Mod 3) = 0 then 

lCurind=SendMessage(hwnd, LB_SETCARETINDEX,lCurind + 1, byval 0&)

End If 

lCurind = SendMessage(hwnd, LB_GETCURSEL, 0, byval 0&) 

Debug.print " Keydown With Itemid :" & Hex$(lCurind)

If ((lCurind + 1) Mod 3) = 0 then

lCurind = SendMessage(hwnd, LB_SETCURSEL, lCurind + 1, byval 0&)

End If 

Case vbKeyUp 

lCurind = SendMessage(hwnd, LB_GETCARETINDEX,0,byval 0&) 

Debug.print " KeyUp With Itemid :" & Hex$(lCurind)

If ((lCurind - 1) Mod 3) = 0 then

lCurind = SendMessage(hwnd, LB_SETCARETINDEX,lCurind - 1, byval 0&)

End If 

lCurind = SendMessage(hwnd, LB_GETCURSEL,0,byval 0&) 

Debug.print " KeyUp With Itemid :" & Hex$(lCurind)

If ((lCurind - 1) Mod 3) = 0 then

lCurind = SendMessage(hwnd, LB_SETCURSEL, lCurind - 1, byval 0&)

End If 

End Select 

Case else 

End Select

LBSubcls_WndProc_V4 = CallWindowProc(LBProc1, hwnd, Msg, wParam, lParam)

End Function 

public Function LongInt2Int(byval lLongInt as Long,byref iHiWord as Integer, byref iLowWord as Integer) as Boolean 

Dim tmpHW as Integer,tmpLW as Integer

CopyMemory tmpLW,lLongInt, len(tmpLW)

tmpHW =(lLongInt / TwoPower16) 

iHiWord = tmpHW 

iLowWord = tmpLW 

End Function 

TwoPower16=2^16 : 65536

public Function MakeLParam(byval iHiWord as Integer, byval iLowWord as Integer) as Long 

MakeLParam=(iHiWord * TwoPower16) + iLowWord

End Function

---

WS_BORDRR,WS_EX_CLIENDEDGE

"SendMessageA hlist, &H180, 0, ByVal "D

       "SendMessageA hlist, &H180, 0, ByVal "E

       "SendMessageA hlist, &H180, 0, ByVal "FFF

      " SendMessageA hlist, &H180, 0, ByVal "HHT

       "SendMessageA hlist, &H180, 0, ByVal "123E

    "سلام  " SendMessageA hlist, &H180, 0, ByVal

"حاجی " SendMessageA hlist, &H180, 0, ByVal 

در Subclassing

Case WM_KEYDOWN

    Select Case wParam

      Case &H11, &H1

      Dim c, ll

      Dim buf As String

      Dim Idx

     ( Idx = SendMessageA(hwnd, LB_GETCURSEL, 0, 0

     ( c = SendMessageA(hwnd, LB_GETCOUNT, 0, 0

      (textcount = SendMessageA(hwnd, LB_GETTEXTLEN, i, 0

buffer$ = Space$(textcount + 255)

      $SendMessageA hwnd, LB_GETTEXT, Idx, ByVal buffer

  $ SetWindowTextA GetParent(hwnd), c & "... Idx : " & Idx & "...." & l & buffer

     End Select