Avatar billede egede Nybegynder
07. juli 2003 - 20:46 Der er 10 kommentarer og
1 løsning

Forskellige fonte i samme listboks?

Er det muligt at bruge forskellige fonte i samme listboks?
I så fald, hvordan?
Avatar billede stueplanten Nybegynder
07. juli 2003 - 21:33 #1
hmm det tror jeg ikke men listboxe er ikke lige det jeg bruger mest.

men alligevel: det tror jeg ikke man kan :(
Avatar billede stueplanten Nybegynder
07. juli 2003 - 21:34 #2
det er jeg 99% sikker på man ikke kan men det kan være der er en der ka et "trick"...
Avatar billede stueplanten Nybegynder
07. juli 2003 - 21:35 #3
nu har jeg ikke vb installeret på den pc jeg sidder ved nu, ellers ville jeg gerne prøve, men du kan jo vente på at der er nogen andre der svarer :)
Avatar billede egede Nybegynder
07. juli 2003 - 22:03 #4
Jeg har selv heller ikke lige fantasi til at forestille mig det, men jeg tænkte egentlig også at det måske var muligt at finde en der kunne lave et "trick". Så jeg tror jeg venter og ser om der er det... :-)
Avatar billede martin_moth Mester
08. juli 2003 - 10:10 #5
Ikke muligt!

Men - som altid, det er lettere at sige hvad man KAN frem for hvad man IKKE kan. Så jeg er kun 99,99999% sikker.
Avatar billede martin_moth Mester
08. juli 2003 - 10:11 #6
På den anden side - hvad kan du bruge kommentarer som dem fra mig og stueplanten til? Det er jo bare spild af tid - lad os vente og se, om der er nogen der med sikkerhed VED det og ikke bare tror at de vistnok ved det :o)
Avatar billede hiks Nybegynder
08. juli 2003 - 12:40 #7
Aloooo

Har brugt det her engang...

Kan ikke lige helt huske hvordan det går - men du kan da forsøge...:

In a Module:


code:--------------------------------------------------------------------------------Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private 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

Private Type TEXTMETRIC
        tmHeight As Long
        tmAscent As Long
        tmDescent As Long
        tmInternalLeading As Long
        tmExternalLeading As Long
        tmAveCharWidth As Long
        tmMaxCharWidth As Long
        tmWeight As Long
        tmOverhang As Long
        tmDigitizedAspectX As Long
        tmDigitizedAspectY As Long
        tmFirstChar As Byte
        tmLastChar As Byte
        tmDefaultChar As Byte
        tmBreakChar As Byte
        tmItalic As Byte
        tmUnderlined As Byte
        tmStruckOut As Byte
        tmPitchAndFamily As Byte
        tmCharSet As Byte
End Type

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

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private 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
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private 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
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
Private Declare Function GetTextFace Lib "gdi32" Alias "GetTextFaceA" (ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String) As Long

Private Const COLOR_HIGHLIGHT = 13
Private Const COLOR_HIGHLIGHTTEXT = 14
Private Const COLOR_BACKGROUND = 1
Private Const COLOR_WINDOW = 5

Private Const LB_GETTEXT = &H189
Private Const LB_GETITEMDATA = &H199

Private Const LBS_OWNERDRAWFIXED = &H10&

Private Const WM_DRAWITEM = &H2B
Private Const GWL_WNDPROC = (-4)
Private Const GWL_STYLE = (-16)

Private Const ODS_FOCUS = &H10
Private Const ODT_LISTBOX = 2

Private Const FW_BOLD = 700
Private Const FW_EXTRABOLD = 800

Private lPrevWndProc As Long

Public Sub SubClassForm(ByVal hWnd As Long)
    'Subclass the "Form", to Capture the Listbox Notification Messages
    lPrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf SubClassedList)
End Sub

Public Sub ReleaseSubClass(ByVal hWnd As Long)
    Call SetWindowLong(hWnd, GWL_WNDPROC, lPrevWndProc)
End Sub

Private 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 tPic As DRAWITEMSTRUCT
    Dim sBuff As String * 255
    Dim sItem As String
    Dim lBack As Long
    Dim lFont As Long, lOldFont As Long
    Dim sFont As String
    Dim tMETRICS As TEXTMETRIC
   
   
    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 set up:
        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.itemData Then
                sFont = Space(255)
                sFont = Left(sFont, GetTextFace(tItem.hdc, 255, ByVal sFont))
                Call GetTextMetrics(tItem.hdc, tMETRICS)
                With tMETRICS
                    lFont = CreateFont(.tmHeight, .tmAveCharWidth, 0, 0, FW_BOLD, .tmItalic, .tmUnderlined, .tmStruckOut, .tmCharSet, 0, 0, 0, .tmPitchAndFamily, sFont)
                End With
                lOldFont = SelectObject(tItem.hdc, lFont)
            End If
           
            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 + 1, ByVal sItem, Len(sItem)
                DrawFocusRect tItem.hdc, tItem.rcItem
            Else
                'Item Doesn't Have Focus
                'Create a Brush using the Window Color
                lBack = CreateSolidBrush(GetSysColor(COLOR_WINDOW))
                Call FillRect(tItem.hdc, tItem.rcItem, lBack)
                'Set the Text Colors
                Call SetBkColor(tItem.hdc, GetSysColor(COLOR_WINDOW))
                Call SetTextColor(tItem.hdc, vbBlack)
                'Display the Item Text
                TextOut tItem.hdc, tItem.rcItem.Left, tItem.rcItem.Top + 1, ByVal sItem, Len(sItem)
            End If
            ' If the Font was changed, restore the original font settings and destroy the Font object
            If tItem.itemData Then
                Call SelectObject(tItem.hdc, lOldFont)
                Call DeleteObject(lFont)
            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--------------------------------------------------------------------------------
In the Form with a Listbox (Set Style to "1 - Checkbox"):
code:--------------------------------------------------------------------------------Private Sub Form_Load()
    Dim I As Integer
    Randomize Timer
    For I = 1 To 10
        List1.AddItem "List Item " & I
        ' Set the List Items "ItemData" to a Non-Zero value to make it appear in the List in Bold.
        List1.itemData(List1.NewIndex) = Int(Rnd * 10) Mod 2
    Next
    SubClassForm hWnd
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'Release the SubClassing, Very Import to Prevent Crashing!
    'When running in the IDE, NEVER hit the "Stop" button.
    'Close the Form properly with either "Unload" or Clicking the "X"
    ReleaseSubClass hWnd
End Sub

Det er taget herfra:

http://www.vbforums.com/showthread.php?s=&threadid=115684&highlight=listbox+different+font

/hiks
Avatar billede hiks Nybegynder
08. juli 2003 - 12:41 #8
det er vist her istedet - det link der virker vist ikke...

http://vbforums.com/showthread.php?s=&threadid=83988&highlight=

/hiks
Avatar billede egede Nybegynder
08. juli 2003 - 13:40 #9
tak for det, der var godt nok lidt mere kode til det trick end jeg havde regnet med, men det virker jo fint :-)
Avatar billede hiks Nybegynder
08. juli 2003 - 13:48 #10
ja dejligt ikke... :)

takker for points!

/hiks
Avatar billede martin_moth Mester
08. juli 2003 - 15:54 #11
Alt kan jo lade sig gøre med API ;o)
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Kurser inden for grundlæggende programmering

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester