Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0428: Effektvoller Farbauswahl-Dialog

VB 5/6-Tipp 0428: Effektvoller Farbauswahl-Dialog

 von ActiveVB

Schwierigkeitsgrad:

Verwendete API-Aufrufe: ClientToScreen, GetCursorPos, GetWindowLongA (GetWindowLong), GetWindowRect, ReleaseCapture, SetCapture, SetWindowLongA (SetWindowLong), SetWindowPos

Download: Download des Beispielprojektes [5,85 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 -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Rahmensteuerelement "Frame6"
' Steuerelement: Rahmensteuerelement "fraBorder" (Index von 0 bis 1) auf Frame6
' Steuerelement: Bildfeld-Steuerelement "Picture3" (Index von 0 bis 2) auf fraBorder
' Steuerelement: Bildfeld-Steuerelement "Picture1" (Index von 0 bis 2) auf Picture3
' Steuerelement: Bildfeld-Steuerelement "Picture4" (Index von 0 bis 2) auf Picture3
' Steuerelement: Textfeld "Text1" (Index von 0 bis 2) auf Picture4
' Steuerelement: Schaltfläche "Command1" (Index von 0 bis 2) auf Picture3
' Steuerelement: Bildfeld-Steuerelement "Picture2" (Index von 0 bis 2) auf Picture3


'Dieses Beispiel enstand in Anlehnung an
'Benjamin Wilgers ColorPicker

Option Explicit
      
Dim PosX(0 To 2) As Long
Dim DrawFlag As Boolean
Dim InitFlag As Boolean

Private Sub Form_Load()
    TPX = Screen.TwipsPerPixelX
    TPY = Screen.TwipsPerPixelY
    Call Init(128, 128, 128)
End Sub

Private Sub Form_Activate()
    Call ReleaseCapture
End Sub

Private Sub Command1_MouseDown(Index As Integer, Button As _
            Integer, Shift As Integer, x As Single, y As Single)
    
    Dim diffX As Integer
    Dim mousePos As POINTAPI
    Dim PosRECT As RECT
    Dim txtVal As Integer
    Dim lx As Long
    
    If Button = 1 Then
        Idx = Index
        diffX = Form2.Width - (Form2.ScaleWidth * TPX)
        
        Call GetCursorPos(mousePos)
        
        txtVal = 255 - Val(Text1(Index).Text)
        lx = Int((txtVal / 255 * Form2.ScaleWidth))
        
        Call GetWindowRect(Picture3(Index).hwnd, PosRECT)
        
        Form2.Left = (mousePos.x - lx) * TPX - diffX \ 2
        Form2.Top = PosRECT.Bottom * TPY
        
        If LastX(Index) <> -1 Then LastX(Idx) = lx
        If Form2.Left < 0 Then
            Form2.Left = 0
        ElseIf Form2.Left + Form2.Width > Screen.Width Then
            Form2.Left = Screen.Width - Form2.Width
        End If
        
        Form2.Show
        Call SetWindowPos(Form2.hwnd, HWND_TOPMOST, 0, 0, _
                        0, 0, SWP_FLAGS)
        
        Call SetCapture(Form2.hwnd)
    End If
End Sub

Private Sub Command1_MouseUp(Index As Integer, Button As _
            Integer, Shift As Integer, x As Single, y As Single)
    
    Call ReleaseCapture
    Call SetWindowPos(Form2.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_FLAGS)
    Unload Form2
    Text1(Index).SetFocus
End Sub

Private Sub Picture1_MouseMove(Index As Integer, Button As _
            Integer, Shift As Integer, x As Single, y As Single)
    
    Dim c As Integer
    Dim T As Double
    Dim ix As Integer
    
    If Button = 1 Then
        ix = x
        
        If x > Picture1(Index).ScaleWidth - 1 Then
            ix = Picture1(Index).ScaleWidth - 1
        ElseIf ix < 0 Then
            ix = 0
        End If
        
        Picture1(Index).Line (PosX(Index), 0)-(PosX(Index), _
                            Picture1(Index).ScaleHeight)
        
        Picture1(Index).Line (ix, 0)-(ix, Picture1(Index).ScaleHeight)
        PosX(Index) = ix
        T = 259 / Picture1(0).ScaleWidth
        c = 255 - ix * T
        DrawFlag = True
        Text1(Index).Text = c
        Picture2(Index).BackColor = c * 256 ^ Index
        LastX(Index) = -1
    End If
End Sub

Private Sub Picture1_Click(Index As Integer)
    Text1(Index).SetFocus
End Sub

Private Sub Picture2_Click(Index As Integer)
    Text1(Index).SetFocus
End Sub

Private Sub Text1_Change(Index As Integer)
    Dim x As Single
    
    If DrawFlag Then
        DrawFlag = False
        Exit Sub
    End If
    
    If InitFlag Then
        x = Val(Text1(Index).Text)
        If x > 255 Then x = 255
        x = 255 - x
        Call DrawSmallBar(CInt(Index), x)
    End If
End Sub

Private Sub Text1_GotFocus(Index As Integer)
    Text1(Index).SelStart = 0
    Text1(Index).SelLength = Len(Text1(Index).Text)
End Sub

Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
    Dim Erlaubt As String, aa As String
    
    Erlaubt = "0123456789" & Chr$(8)
    aa = Chr$(KeyAscii)
    If InStr(1, Erlaubt, aa) = 0 Then KeyAscii = 0
End Sub

Private Sub Text1_LostFocus(Index As Integer)
    Dim x As Single
    
    x = Val(Text1(Index).Text)
    If x = 0 Then Text1(Index).Text = "0"
End Sub

Private Sub Init(R1 As Byte, G1 As Byte, B1 As Byte)
    Dim x As Integer
    
    ReDim LastX(0 To 2)
    For x = 0 To Picture1.UBound
        PosX(x) = -1
        LastX(x) = -1
        Picture1(x).Picture = LoadPicture("")
        Picture1(x).Refresh
    Next x
    
    Call FillColors
    
    Picture2(0).BackColor = R1
    Picture2(1).BackColor = G1 * 256 ^ 1
    Picture2(2).BackColor = B1 * 256 ^ 2
    
    Text1(0).Text = R1
    Text1(1).Text = G1
    Text1(2).Text = B1
    
    Call DrawSmallBar(0, CSng(R1))
    Call DrawSmallBar(1, CSng(G1))
    Call DrawSmallBar(2, CSng(B1))
End Sub

Private Function FillColors()
    Dim c As Integer
    Dim T As Double
    Dim x As Byte
    
    T = Picture1(0).ScaleWidth / 256
    For c = 0 To 255
        Picture1(0).Line (T * c, 0)-(T * c, Picture1(0).ScaleHeight), _
                         RGB(255 - c, 0, 0)
        
        Picture1(1).Line (T * c, 0)-(T * c, Picture1(1).ScaleHeight), _
                         RGB(0, 255 - c, 0)
        
        Picture1(2).Line (T * c, 0)-(T * c, Picture1(2).ScaleHeight), _
                         RGB(0, 0, 255 - c)
    Next c
    
    For x = 0 To Picture1.UBound
        Picture1(x).DrawMode = vbNotXorPen
    Next x
End Function

Public Function DrawSmallBar(Index&, Color As Single)
    Dim c As Integer
    Dim T As Double
    Dim x As Integer
    
    T = Picture1(Index).ScaleWidth / 256
    c = (Color)
    
    If PosX(Index) <> -1 Then
        Picture1(Index).Line (PosX(Index), 0)-(PosX(Index), _
                            Picture1(Index).ScaleHeight)
    End If
    
    Picture1(Index).Line (Int(T * c), 0)-(Int(T * c), _
                           Picture1(Index).ScaleHeight)
                           
    PosX(Index) = Int(T * c)
End Function
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Formular "Form2" alias Form2.frm  ---------


'Dieses Beispiel enstand in Anlehnung an
'Benjamin Wilgers ColorPicker

Option Explicit

Private Sub Form_Load()
    Dim diffX As Integer, diffY As Integer
    
    diffX = Me.Width - (Me.ScaleWidth * TPX)
    diffY = Me.Height - (Me.ScaleHeight * TPY)
    Me.Width = (256 * TPX) + diffX
    Me.Height = (15 * TPY) + diffY
    Call DrawBar
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _
                           x As Single, y As Single)
  
  Call SetCapture(Me.hwnd)
  Call Form_MouseMove(Button, Shift, x, y)
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
                           x As Single, y As Single)
  
    Dim ix As Single, iy As Single
    Dim nVal As Integer
    
    If Button = 1 Then
        ix = x
        If ix > 255 Then
            ix = 255
        ElseIf ix < 0 Then
            ix = 0
        End If
        
        Me.Line (LastX(Idx), 0)-(LastX(Idx), Me.ScaleHeight), 255
        Me.Line (ix, 0)-(ix, Me.ScaleHeight), 255
        
        Call Form1.DrawSmallBar(Idx, ix)
        LastX(Idx) = ix
        
        Form1.Picture2(Idx).BackColor = (255 - ix) * 256 ^ Idx
        ix = Int(ix / (Me.ScaleWidth - 1) * 255)
        Form1.Text1(Idx).Text = Int(255 - ix)
        
    End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, _
                         x As Single, y As Single)
    
    Call ReleaseCapture
    Unload Me
End Sub

Private Function DrawBar()
    Dim c As Integer, x As Integer
    Dim T As Double
    
    T = Me.ScaleWidth / 256
    Me.DrawMode = vbCopyPen
    
    Select Case Idx
        Case 0
            For c = 0 To 255
                Me.Line (T * c, 0)-(T * c, Me.ScaleHeight), RGB(255 - c, 0, 0)
            Next c
            
        Case 1
            For c = 0 To 255
                Me.Line (T * c, 0)-(T * c, Me.ScaleHeight), RGB(0, 255 - c, 0)
            Next c
            
        Case 2
            For c = 0 To 255
                Me.Line (T * c, 0)-(T * c, Me.ScaleHeight), RGB(0, 0, 255 - c)
            Next c
    End Select
    
    Me.DrawMode = vbNotXorPen
    Me.Line (LastX(Idx), 0)-(LastX(Idx), Me.ScaleHeight), 255
End Function
'---------- Ende Formular "Form2" alias Form2.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------

Option Explicit

Public Declare Function SetCapture Lib "user32" _
        (ByVal hwnd As Long) As Long
        
Public Declare Function ReleaseCapture Lib "user32" () _
        As Long
        
Public Declare Function SetWindowPos Lib "user32" _
       (ByVal hwnd As Long, ByVal hWndInsertAfter As _
       Long, ByVal x As Long, ByVal y As Long, ByVal _
       cx As Long, ByVal cy As Long, ByVal wFlags As _
       Long) As Long
              
Public Declare Function ClientToScreen Lib "user32" _
       (ByVal hwnd As Long, lpPoint As POINTAPI) 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 GetWindowLong Lib "user32" Alias _
       "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As _
       Long) As Long

Public Declare Function GetCursorPos Lib "user32" _
       (lpPoint As POINTAPI) As Long
      
Public Declare Function GetWindowRect Lib "user32" _
       (ByVal hwnd As Long, lpRect As RECT) As Long

Public Type POINTAPI
    x As Long
    y As Long
End Type

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

Public LastX() As Long

Public Const SWP_NOMOVE As Long = 2&
Public Const SWP_NOSIZE As Long = 1&
Public Const SWP_FLAGS As Long = SWP_NOMOVE Or SWP_NOSIZE
Public Const HWND_TOPMOST As Long = -1&
Public Const HWND_NOTOPMOST As Long = -2&

Public TPX As Integer
Public TPY As Integer
Public Idx As Long

'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 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.