home *** CD-ROM | disk | FTP | other *** search
Option Explicit ' 'prevent needless paints Dim resizing% Global nl$ 'types Type rect left As Integer top As Integer right As Integer bottom As Integer End Type 'each list needs a caption and bitmap, so declare a simple structure Type ITEMDATA text As String pic As Integer End Type 'variable data for each window - each instance of the list is created 'by declaring a listdata structure Type LISTDATA cellwidth As Integer 'w,h of each item cellheight As Integer picx As Integer 'x,y offset of bmp picy As Integer picwidth As Integer picheight As Integer textrect As rect 'x,y offset,r,b offset of caption bcolor As Long 'window background color fcolor As Long 'window text hilitebcolor As Long ' hilitefcolor As Long ' toprow As Integer 'client area's top itemcount As Integer 'total items active As Integer 'active item cols As Integer rows As Integer visrows As Integer Width As Integer tx As Integer ty As Integer End Type 'API constants and types==================== Global Const black = &H0 Global Const white = &HFFFFFF Global Const lgrey = &HC0C0C0 Global Const PATPAINT = &HFB0A09 Global Const PATCOPY = &HF00021 Global Const SRCCOPY = &HCC0020 Global Const GWW_HINSTANCE = (-6) Global Const WM_USER = &H400 Global Const GWL_STYLE = (-16) 'draw text Global Const DT_CALCRECT = &H400 Global Const DT_CENTER = &H1 Global Const DT_NOPREFIX = &H800 Global Const DT_VCENTER = &H4 Global Const DT_WORDBREAK = &H10 Global Const DT_INTERNAL = &H1000 Global Const DT_SINGLELINE = &H20 Global Const DT_LEFT = &H0 Global Const DT_GETRECT = DT_CALCRECT Or DT_NOPREFIX Or DT_CENTER Or DT_WORDBREAK Global Const DT_ICONCAP = DT_NOPREFIX Or DT_WORDBREAK Or DT_CENTER Global Const DT_LISTCAP = DT_NOPREFIX Or DT_LEFT ' Or DT_WORDBREAK Or DT_SINGLELINE Global Const DT_ICONTITLE = DT_NOPREFIX Or DT_CENTER Or DT_WORDBREAK 'Or DT_VCENTER Declare Function bitblt% Lib "GDI" (ByVal hDestDC%, ByVal x%, ByVal y%, ByVal nWidth%, ByVal nHeight%, ByVal hSrcDC%, ByVal XSrc%, ByVal YSrc%, ByVal dwRop&) Declare Function CreateDC Lib "GDI" (ByVal lpDriverName As String, ByVal lpDeviceName As Any, ByVal lpOutput As Any, ByVal lpInitData As Any) As Integer Declare Function CreateSolidBrush% Lib "GDI" (ByVal crColor&) Declare Function DeleteDC Lib "GDI" (ByVal hDC As Integer) As Integer Declare Function DeleteObject% Lib "GDI" (ByVal hObject%) Declare Function DrawText% Lib "User" (ByVal hDC%, ByVal lpStr$, ByVal nCount%, lpRect As rect, ByVal wFormat%) Declare Function DrawIcon Lib "USER" (ByVal lpHandle As Integer, ByVal xcoord As Integer, ByVal ycoord As Integer, ByVal hicon As Integer) As Integer Declare Function ExtractIcon Lib "shell" (ByVal lpHandle As Integer, ByVal lpExe As String, ByVal lpiconindex As Integer) As Integer Declare Function GetSysColor& Lib "User" (ByVal nIndex%) Declare Function GetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer Declare Function SetTextColor& Lib "GDI" (ByVal hDC%, ByVal crColor&) Declare Function PatBlt% Lib "GDI" (ByVal hDC%, ByVal x%, ByVal y%, ByVal nWidth%, ByVal nHeight%, ByVal dwRop&) Declare Function SelectObject% Lib "GDI" (ByVal hDC%, ByVal hObject%) Sub InitializeList (ld As LISTDATA, L As PictureBox) Dim i%, s$ ld.bcolor = GetSysColor(5) ld.fcolor = GetSysColor(8) ld.hilitebcolor = GetSysColor(13) ld.hilitefcolor = GetSysColor(14) ld.tx = screen.TwipsPerPixelX ld.ty = screen.TwipsPerPixelY ld.toprow = 0 ld.active = 1 ld.textrect.right = ld.cellwidth - 2 * ld.textrect.left ld.textrect.bottom = ld.cellheight - ld.textrect.top End Sub Sub ItemClick (F As Form, ld As LISTDATA, txt() As ITEMDATA, x!, y!, L As PictureBox) Dim n%, old% Dim tr As rect, hr As rect '===set focus to clicked item===================== y = y \ ld.cellheight: 'Debug.Print x, y 'determine relative item # n = y + 1'Debug.Print n 'determine absolute item # n = n + ld.toprow'Debug.Print n 'set active item If n <= ld.itemcount Then 'old is a 1-based index; the draw routine uses a 0-base old% = ld.active - 1 ld.active = n End If 'erase old hilite hr.left = ld.picx + ld.picwidth hr.right = ld.Width tr.left = ld.picx + ld.picwidth + ld.textrect.left tr.right = ld.Width - ld.textrect.left 'valid index? If old >= 0 And old < ld.itemcount Then 'is it still visible? n = old - ld.toprow If n >= 0 And n < ld.visrows Then 'size of text rect: tr.top = n * ld.cellheight + ld.textrect.top tr.bottom = (n + 1) * ld.cellheight ' 'size of hilite rect hr.top = n * ld.cellheight hr.bottom = tr.bottom + 2 PaintHilite 0, txt(old + 1).text, tr, hr, ld, L End If End If 'draw new hilite n = ld.active - 1 - ld.toprow: 'Debug.Print "rel" & n 'check if its visible:'Debug.Print "total" & ld.visrows * ld.cols If n < 0 Or n > ld.visrows - 1 Then Exit Sub 'size of text rect: tr.top = n * ld.cellheight + 8 tr.bottom = (n + 1) * ld.cellheight 'Debug.Print hr.left, hr.top, hr.right, hr.bottom 'size of hilite rect hr.top = tr.top - 8 hr.bottom = tr.bottom + 2 PaintHilite -1, txt(ld.active).text, tr, hr, ld, L End Sub Sub PaintHilite (op%, s$, tr As rect, hr As rect, ld As LISTDATA, L As PictureBox) Dim bkgcolor&, txtcolor&, r% Dim offset%'offset of icon caption Dim hbrOld%, hbr%, cOld& 'api stuff ' 'n = 0 erase hilite; n = -1 paint hilite If op Then bkgcolor& = ld.hilitebcolor txtcolor& = ld.hilitefcolor Else bkgcolor& = ld.bcolor txtcolor = ld.fcolor End If 'paint a hilite rectangle: hbr = CreateSolidBrush(bkgcolor&) hbrOld = SelectObject(L.hDC, hbr) r = PatBlt(L.hDC, hr.left, hr.top, hr.right - hr.left, hr.bottom - hr.top, PATCOPY) L.Line (0, hr.top)-(ld.picwidth + 1, hr.top + ld.cellheight), bkgcolor&, B 'paint hilite text: cOld = SetTextColor(L.hDC, txtcolor&) r = DrawText(L.hDC, s, Len(s), tr, DT_LISTCAP) 'cleanup cOld = SetTextColor(L.hDC, cOld) hbr = SelectObject(L.hDC, hbrOld) r = DeleteObject(hbr) End Sub Sub PaintList (ld As LISTDATA, txt() As ITEMDATA, p As PictureBox, L As PictureBox) Dim i%, r% Dim y% 'y pos to draw icon Dim ypos% 'y pos of item Dim pstart%, pend% 'indexes of first and last visible icons Dim hr As rect, tr As rect 'for drawing text 'calculate which icons to show: pstart% = ld.toprow + 1': Debug.Print pstart pend% = pstart% + ld.visrows - 1 If pend% > ld.itemcount Then pend% = ld.itemcount: Debug.Print pend ' L.Cls 'draw the icons: y = -ld.cellheight + 2 For i = pstart% To pend% y = y + ld.cellheight'(new row) r = bitblt(L.hDC, ld.picx, y + ld.picy, ld.picwidth, ld.picheight, p.hDC, txt(i).pic * ld.picwidth, 0, SRCCOPY) Next y = -ld.cellheight tr.left = ld.picx + ld.picwidth + ld.textrect.left tr.right = ld.Width' - tr.left For i = pstart% To pend% y = y + ld.cellheight'(new row) 'define the rect to draw text in: tr.top = y + ld.textrect.top tr.bottom = y + ld.cellheight ' If i = ld.active Then hr.left = ld.picx + ld.picwidth hr.top = y hr.bottom = y + ld.cellheight hr.right = L.ScaleWidth Debug.Print txt(i).text PaintHilite -1, txt(i).text, tr, hr, ld, L Else Debug.Print txt(i).text r = DrawText(L.hDC, txt(i).text, Len(txt(i).text), tr, DT_LISTCAP) End If Next Exit Sub ' paintlisterr: MsgBox "Err: " & Err & nl & Error(Err), , "UNABLE TO PAINT WINDOW" Exit Sub End Sub Sub ResizeList (F As Form, ld As LISTDATA, L As PictureBox) 'Dim x%, y% 'Dim r As rect Debug.Print "Resizing" resizing = -1 ' ld.rows = ld.itemcount If ld.rows < 1 Then ld.rows = 1 ld.cols = 1 ld.visrows = L.ScaleHeight \ ld.cellheight + 1 Debug.Print ld.rows, ld.visrows 'F.vs.Enabled = 0 ' If ld.rows > ld.visrows Then 'F.vs.Move L.ScaleWidth - F.vs.Width, 0, F.vs.Width, F.ScaleHeight F.vs.Enabled = -1 F.vs.Max = ld.rows - ld.visrows Else ld.toprow = 0 F.vs.Enabled = 0 End If ld.Width = L.ScaleWidth ' resizing = 0 ld.textrect.right = L.Width - (ld.picx + ld.picwidth + ld.textrect.left) End Sub 
