Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0335: Grafische Buttons nutzen

VB 5/6-Tipp 0335: Grafische Buttons nutzen

 von Herfried K. Wagner

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GetWindowLongA (GetWindowLong), LoadImageA (LoadImage), SendMessageA (SendMessage), SetWindowLongA (SetWindowLong)

Download: Download des Beispielprojektes [16,84 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
' Die Komponente 'Microsoft Windows Common Controls 6.0 (SP6) (MSCOMCTL.OCX)' wird benötigt.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Optionsfeld-Steuerelement "Option1" auf Frame1
' Steuerelement: Optionsfeld-Steuerelement "Option2" auf Frame1
' Steuerelement: Schaltfläche "Command1" auf Frame1
' Steuerelement: Schaltfläche "Command4"
' Steuerelement: Bilderlistenelement "ImageList1"
' Steuerelement: Rahmensteuerelement "Frame2"
' Steuerelement: Kontrollkästchen-Steuerelement "Check1" auf Frame2
' Steuerelement: Schaltfläche "Command3" auf Frame2
' Steuerelement: Schaltfläche "Command2" auf Frame2
' Steuerelement: Anzeige-Steuerelement "Image1"
' Steuerelement: Anzeige-Steuerelement "Image3"
' Steuerelement: Anzeige-Steuerelement "Image2"
' Steuerelement: Anzeige-Steuerelement "Image4"

Option Explicit

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 GetWindowLong Lib "user32" Alias _
        "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex 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 LoadImage Lib "user32" Alias _
        "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, _
        ByVal iImageType As Long, ByVal cx As Long, ByVal cy As _
        Long, ByVal fFlags As Long) As Long

Const GWL_STYLE As Long = -16&

Const BM_SETIMAGE As Long = &HF7&

Const IMAGE_BITMAP As Long = 0&
Const IMAGE_ICON As Long = 1&

Const BS_ICON As Long = &H40&
Const BS_BITMAP As Long = &H80&
Const BS_RIGHT As Long = &H200&
Const BS_CENTER As Long = &H300&
Const BS_TOP As Long = &H400&

Const LR_DEFAULTCOLOR As Long = &H0&
Const LR_LOADFROMFILE As Long = &H10&
Const LR_DEFAULTSIZE As Long = &H40&

Private Sub Form_Load()
    Dim n As Long
    Dim m_hbmSave As Long
    Dim m_hbmSettings As Long
    Dim m_hbmIcon As Long
    Dim m_hbmGerman As Long
    Dim m_hbmFrench As Long
    Dim m_hbmInstall As Long
    Dim m_hbmFrame As Long
    Dim m_hbmQuit As Long
    Dim lReturn As Long
    
    n = GetWindowLong(Frame1.hwnd, GWL_STYLE)
    n = n Or BS_CENTER
    SetWindowLong Frame1.hwnd, GWL_STYLE, n
    Frame1.Refresh
    
    'Grafiken aus Res
    If Compiled = True Then
        n = GetWindowLong(Command2.hwnd, GWL_STYLE)
        n = n Or BS_ICON
        SetWindowLong Command2.hwnd, GWL_STYLE, n
        Command2.Refresh
        
        n = GetWindowLong(Frame2.hwnd, GWL_STYLE)
        n = n Or BS_BITMAP Or BS_CENTER
        SetWindowLong Frame2.hwnd, GWL_STYLE, n
        Frame2.Refresh
    End If
    
    ' Andere Grafikquellen
    ' CommandButtons
    n = GetWindowLong(Command4.hwnd, GWL_STYLE)
    n = n Or BS_BITMAP
    SetWindowLong Command4.hwnd, GWL_STYLE, n
    Command4.Refresh
    
    n = GetWindowLong(Command3.hwnd, GWL_STYLE)
    n = n Or BS_BITMAP
    SetWindowLong Command3.hwnd, GWL_STYLE, n
    Command3.Refresh
    
    n = GetWindowLong(Command1.hwnd, GWL_STYLE)
    n = n Or BS_ICON
    SetWindowLong Command1.hwnd, GWL_STYLE, n
    Command1.Refresh
    
    ' OptionButtons
    n = GetWindowLong(Option1.hwnd, GWL_STYLE)
    n = n Or BS_ICON Or BS_TOP Or BS_RIGHT
    SetWindowLong Option1.hwnd, GWL_STYLE, n
    Option1.Refresh
    
    n = GetWindowLong(Option2.hwnd, GWL_STYLE)
    n = n Or BS_ICON Or BS_TOP Or BS_RIGHT
    SetWindowLong Option2.hwnd, GWL_STYLE, n
    Option2.Refresh
    
    ' CheckBoxen
    n = GetWindowLong(Check1.hwnd, GWL_STYLE)
    n = n Or BS_BITMAP
    Call SetWindowLong(Check1.hwnd, GWL_STYLE, n)
    Check1.Refresh

    If Compiled = True Then
        ' Grafiken aus Res
        m_hbmIcon = LoadResPicture(200, vbResIcon)
        
        ' Laden von Bitmaps aus einer Ressourcendatei und zuweisen
        ' in eine Variable bringt Probleme, sie müssen zuerst der
        ' Picture-Eigenschaft eines Steuerelements zugewiesen werden.
        Image1.Picture = LoadResPicture(100, vbResBitmap)
        m_hbmFrame = Image1.Picture
        
        Call SendMessage(Command2.hwnd, BM_SETIMAGE, IMAGE_ICON, _
                         ByVal m_hbmIcon)
                         
        Call SendMessage(Frame2.hwnd, BM_SETIMAGE, IMAGE_BITMAP, _
                         ByVal m_hbmFrame)
    End If
    
    m_hbmQuit = LoadImage(0&, App.Path & "\Quit.bmp", IMAGE_BITMAP, _
                          0, 0, LR_DEFAULTSIZE Or LR_DEFAULTCOLOR _
                          Or LR_LOADFROMFILE)
                          
    m_hbmSave = Image4.Picture
    m_hbmInstall = Command1.Picture
    m_hbmGerman = Image2.Picture
    m_hbmFrench = Image3.Picture
    m_hbmSettings = ImageList1.ListImages(1).Picture
    
    ' Andere Grafikquellen
    Call SendMessage(Command1.hwnd, BM_SETIMAGE, IMAGE_ICON, _
                     ByVal m_hbmInstall)
                     
    Call SendMessage(Command3.hwnd, BM_SETIMAGE, IMAGE_BITMAP, _
                     ByVal m_hbmSave)
                     
    Call SendMessage(Command4.hwnd, BM_SETIMAGE, IMAGE_BITMAP, _
                     ByVal m_hbmQuit)
                     
    Call SendMessage(Option1.hwnd, BM_SETIMAGE, IMAGE_ICON, _
                     ByVal m_hbmGerman)
                     
    Call SendMessage(Option2.hwnd, BM_SETIMAGE, IMAGE_ICON, _
                     ByVal m_hbmFrench)
                     
    Call SendMessage(Check1.hwnd, BM_SETIMAGE, IMAGE_BITMAP, _
                     ByVal m_hbmSettings)
    
    ' Anzeigen
    Me.Show
    
    If Compiled = False Then
        MsgBox "Die Grafiken, die aus der Ressourcendatei " & _
                "geladen werden, können beim Ausführen in " & _
                "der Entwicklungsumgebung nicht geladen " & _
                "werden.", 48, App.Title
    End If
End Sub

Private Sub Check1_Click()
    'Das Deaktivieren von Steuerelementen mit Bitmap-Grafiken
    'verursacht Probleme wegen der "transparenten" Hintergrund-
    'farbe (auch GIFs). Icons funktionieren.
    
    Option1.Enabled = Check1.Value
    Option2.Enabled = Check1.Value
    Command1.Enabled = Check1.Value
End Sub

Private Sub Command4_Click()
    Unload Me
End Sub

Private Function Compiled() As Boolean
    On Error Goto NotCompiled
    
    Debug.Print 1 / 0
    Compiled = True
    
NotCompiled:
End Function
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 2 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.