Visualizzazione dei risultati da 1 a 8 su 8

Discussione: Command Button

  1. #1

    Command Button

    Ciao a tutti
    volevo dapere se è possibile cambiare il colore del font di un pulsante.
    il pulsante ha uno style a 1(grafical).

    se sì, come posso fare?

    Grazie Sara

  2. #2
    Utente di HTML.it L'avatar di Markooo
    Registrato dal
    Mar 2003
    Messaggi
    247
    In un modulo inserisci:

    codice:
    Option Explicit
    
    Private colButtons  As New Collection
    Private Const KeyConst As String = "K"
    Private Const PROP_COLOR As String = "SMDColor"
    Private Const PROP_HWNDPARENT As String = "SMDhWndParent"
    Private Const PROP_LPWNDPROC As String = "SMDlpWndProc"
    Private Const GWL_WNDPROC As Long = -4
    Private Const ODA_SELECT As Long = &H2
    Private Const ODS_SELECTED As Long = &H1
    Private Const ODS_FOCUS As Long = &H10
    Private Const ODS_BUTTONDOWN As Long = ODS_FOCUS Or ODS_SELECTED
    Private Const WM_DESTROY As Long = &H2
    Private Const WM_DRAWITEM As Long = &H2B
    
    Private Type RECT
       Left As Long
       Top As Long
       Right As Long
       Bottom As Long
    End Type
    
    Private Type Size
       cx As Long
       cy 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 Declare Function CallWindowProc Lib "User32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, lParam As DRAWITEMSTRUCT) As Long
    Private Declare Function GetParent Lib "User32.dll" (ByVal hWnd As Long) As Long
    Private Declare Function GetProp Lib "User32.dll" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
    Private Declare Function GetTextExtentPoint32 Lib "Gdi32.dll" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpSz As String, ByVal cbString As Long, lpSize As Size) As Long
    Private Declare Function RemoveProp Lib "User32.dll" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
    Private Declare Function SetProp Lib "User32.dll" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function SetTextColor Lib "Gdi32.dll" (ByVal hDC As Long, ByVal crColor As Long) As Long
    Private Declare Function SetWindowLong Lib "User32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function TextOut Lib "Gdi32.dll" 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 Function ButtonColorProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, lParam As DRAWITEMSTRUCT) As Long
        Dim lpWndProC As Long
        Dim bProcessButton As Boolean
        Dim sButtonKey As String
        bProcessButton = False
        If uMsg = WM_DRAWITEM Then
            'Per trovare il bottone, cerca un riferimento all'elemento nella "Collection".
            sButtonKey = GetKey(lParam.hWndItem)
            bProcessButton = FindButton(sButtonKey)
        End If
        If bProcessButton Then
            ProcessButton hWnd, uMsg, wParam, lParam, sButtonKey
        Else
            lpWndProC = GetProp(hWnd, PROP_LPWNDPROC)
            ButtonColorProc = CallWindowProc(lpWndProC, hWnd, uMsg, wParam, lParam)
            If uMsg = WM_DESTROY Then RemoveForm hWnd
       End If
    End Function
    
    Private Function FindButton(sKey As String) As Boolean
       Dim cmdButton As CommandButton
       On Error Resume Next
       Set cmdButton = colButtons.Item(sKey)
       FindButton = (Err.Number = 0)
    End Function
    
    
    Private Function GetKey(hWnd As Long) As String
       GetKey = KeyConst & hWnd
    End Function
    
    
    Private Function ProcessButton(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, lParam As DRAWITEMSTRUCT, sKey As String) As Long
       Dim cmdButton As CommandButton
       Dim bRC As Boolean
       Dim lRC As Long, x As Long, y As Long, lpWndProC As Long, lButtonWidth As Long, lButtonHeight As Long, lPrevColor As Long, lColor As Long
       Dim TextSize As Size
       Dim sCaption As String
       Const PushOffset = 2
       Set cmdButton = colButtons.Item(sKey)
       sCaption = cmdButton.Caption
       lColor = GetProp(cmdButton.hWnd, PROP_COLOR)
       lPrevColor = SetTextColor(lParam.hDC, lColor)
       lRC = GetTextExtentPoint32(lParam.hDC, sCaption, Len(sCaption), TextSize)
       lButtonHeight = lParam.rcItem.Bottom - lParam.rcItem.Top
       lButtonWidth = lParam.rcItem.Right - lParam.rcItem.Left
       'Se il bottone è premuto, modifica il testo in modo da simulare la pressione.
        If lParam.itemAction = ODA_SELECT And lParam.itemState = ODS_BUTTONDOWN Then
            cmdButton.SetFocus
            DoEvents
            x = (lButtonWidth - TextSize.cx + PushOffset) \ 2
            y = (lButtonHeight - TextSize.cy + PushOffset) \ 2
        Else
            x = (lButtonWidth - TextSize.cx) \ 2
            y = (lButtonHeight - TextSize.cy) \ 2
        End If
        lpWndProC = GetProp(hWnd, PROP_LPWNDPROC)
        'Elabora il messaggio.
        ProcessButton = CallWindowProc(lpWndProC, hWnd, uMsg, wParam, lParam)
        'Scrive la caption del bottone.
        bRC = TextOut(lParam.hDC, x, y, sCaption, Len(sCaption))
        lRC = SetTextColor(lParam.hDC, lPrevColor)
        Set cmdButton = Nothing
    End Function
    Private Sub RemoveForm(hWndParent As Long)
        Dim hWndButton As Long
        Dim i As Integer
        UnsubclassForm hWndParent
        On Error GoTo RemoveForm_Exit
        For i = colButtons.Count - 1 To 0 Step -1
            hWndButton = colButtons(i).hWnd
            If GetProp(hWndButton, PROP_HWNDPARENT) = hWndParent Then
                RemoveProp hWndButton, PROP_COLOR
                RemoveProp hWndButton, PROP_HWNDPARENT
                colButtons.Remove i
            End If
       Next i
    RemoveForm_Exit:
       Exit Sub
    End Sub
    
    
    Private Function UnsubclassForm(hWnd As Long) As Boolean
        'Disattiva il subclassing del form.
        Dim lpWndProC As Long
        lpWndProC = GetProp(hWnd, PROP_LPWNDPROC)
        If lpWndProC = 0 Then
            UnsubclassForm = False
        Else
            Call SetWindowLong(hWnd, GWL_WNDPROC, lpWndProC)
            RemoveProp hWnd, PROP_LPWNDPROC
            UnsubclassForm = True
       End If
    End Function
    
    
    
    
    Public Function RegisterButton(Button As CommandButton, Forecolor As Long) As Boolean
        Dim hWndParent As Long
        Dim lpWndProC As Long
        Dim sButtonKey As String
        'Crea il valore "colButtons".
        sButtonKey = GetKey(Button.hWnd)
        'Se si conoscono già le proprietà del bottone, si limita a cambiare il colore del testo, altrimenti esegue tutta la procedura.
        If FindButton(sButtonKey) Then
            SetProp Button.hWnd, PROP_COLOR, Forecolor
            Button.Refresh
        Else
            'Recupera l'handle del form che possiende il bottone.
            hWndParent = GetParent(Button.hWnd)
            'Se non riesce a recuperare l'handle, esce.
            If (hWndParent = 0) Then
                RegisterButton = False
                Exit Function
            End If
            'Il form proprietario è stato trovato.
            colButtons.Add Button, sButtonKey
            SetProp Button.hWnd, PROP_COLOR, Forecolor
            SetProp Button.hWnd, PROP_HWNDPARENT, hWndParent
            'Controlla se il form è già stato subclassato.
            lpWndProC = GetProp(hWndParent, PROP_LPWNDPROC)
            If lpWndProC = 0 Then
                'E' un nuovo form; lo subclassa ed aggiunge l'indirizzo della "Windows procedure" alla "Collection".
                lpWndProC = SetWindowLong(hWndParent, GWL_WNDPROC, AddressOf ButtonColorProc)
                SetProp hWndParent, PROP_LPWNDPROC, lpWndProC
            End If
        End If
        RegisterButton = True
    End Function
    Public Function UnregisterButton(Button As CommandButton) As Boolean
        Dim hWndParent As Long
        Dim sKeyButton As String
        sKeyButton = GetKey(Button.hWnd)
        If (FindButton(sKeyButton) = False) Then
            UnregisterButton = False
            Exit Function
        End If
        hWndParent = GetProp(Button.hWnd, PROP_HWNDPARENT)
        UnregisterButton = UnsubclassForm(hWndParent)
        colButtons.Remove sKeyButton
        RemoveProp Button.hWnd, PROP_COLOR
        RemoveProp Button.hWnd, PROP_HWNDPARENT
    End Function
    Nel form inserisci:

    codice:
    Option Explicit
    
    Private Const vbDarkRed As Long = &H90&
    Private Const vbDarkBlue As Long = &H900000
    Private Sub Form_Load()
       
        RegisterButton Command1(0), vbRed
        RegisterButton Command1(1), vbBlue
        
    End Sub
    Command1(0) e Command1(1) sono una matrice di commandbutton; poi altri colori sono: vbgreen (verde);vbyellow(giallo) ecc.ecc.
    Non saprei

  3. #3
    Utente di HTML.it L'avatar di Markooo
    Registrato dal
    Mar 2003
    Messaggi
    247
    I command devono avere lo style a 1 (grafical)
    Non saprei

  4. #4

  5. #5
    ops...problema...mi da un errore proprio sulle matrici..numero erato di argomenti o assegnazione di proprietà non valida

  6. #6
    Utente di HTML.it L'avatar di Markooo
    Registrato dal
    Mar 2003
    Messaggi
    247
    In che modo crei questa matrice? L'unica cosa da fare è quella di creare la matrice; occhio ai nomi dei command e a queste cose qua...
    Non saprei

  7. #7
    umm come si fa???

  8. #8
    Utente di HTML.it L'avatar di Markooo
    Registrato dal
    Mar 2003
    Messaggi
    247
    Metti un commandbutton sul form; click destro su questo commandbutton e selezioni la voce copia ; ora in un punto vuoto del form click destro e selezioni incolla; ti verrà chiesto di creare una matrice e tu dai ok! Ricorda lo style a 1!
    Non saprei

Permessi di invio

  • Non puoi inserire discussioni
  • Non puoi inserire repliche
  • Non puoi inserire allegati
  • Non puoi modificare i tuoi messaggi
  •  
Powered by vBulletin® Version 4.2.1
Copyright © 2025 vBulletin Solutions, Inc. All rights reserved.