Thema: Farbauswahldialog generieren, aufrufen und löschen

StandardModule: basMain

Public clrArt As Boolean

Sub ColorPicker()
  Dim dlgFarben As DialogSheet
  Dim btnOK As Button, btnCancel As Button
  Dim optInterior As OptionButton, optFont As OptionButton
  Dim txtClr As TextBox
  Dim intRow As Integer, intCol As Integer
  Dim l As Integer, t As Integer, intClr As Integer
  Application.ScreenUpdating = False
  Set dlgFarben = DialogSheets.Add
  With dlgFarben
    .Name = "dlgFarben"
    With .DialogFrame
      .Top = 0
      .Left = 0
      .Height = 200
      .Width = 170
      .Caption = "Color Picker"
    End With
    l = 15
    t = 15
    Set optInterior = .OptionButtons.Add(l, t, 75, 15)
    optInterior.Caption = "Zellhintergrund"
    optInterior.Value = xlOn
    Set optFont = .OptionButtons.Add(l + 75, t, 75, 15)
    optFont.Caption = "Schriftfarbe"
    t = t + 20
    For intRow = 1 To 7
      l = 15
      For intCol = 1 To 8
        intClr = intClr + 1
        Set txtClr = .TextBoxes.Add(l, t, 16, 16)
        With txtClr
          .Interior.ColorIndex = intClr
          .OnAction = "FarbAuswahl"
          .Name = "clr" & intClr
        End With
        l = l + 18
      Next intCol
      t = t + 18
    Next intRow
    Set btnOK = .Buttons(1)
    Set btnCancel = .Buttons(2)
    btnOK.Top = 180
    btnOK.Left = 25
    btnCancel.Top = 180
    btnCancel.Left = 100
    Worksheets(1).Select
    .Show
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
  End With
End Sub

Sub FarbAuswahl()
  Dim strAc As String
  Worksheets("Tabelle1").Select
  Application.ScreenUpdating = True
  strAc = Application.Caller
  If DialogSheets("dlgFarben").OptionButtons(1).Value = xlOn Then
    Selection.Interior.ColorIndex = CInt(Right(strAc, Len(strAc) - 3))
  Else
    Selection.Font.ColorIndex = CInt(Right(strAc, Len(strAc) - 3))
  End If
End Sub

Beiträge aus dem Excel-Forum zu den Themen Dialog und DialogSheet