CD Actual Thematic 25: Programming/pc_actual_25.iso/Basic/GridOne/setup.EXE/CCOLORCOMBO.CLS

Visual Basic class definition | 2001-09-09 | 16.9 KB | 519 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CColorCombo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'-----------------------------------------------------------------------------
' This is a part of the BeeGrid ActiveX control.
' Copyright ⌐ 2000 Stinga
' All rights reserved.
'
' You have a right to use and distribute the BeeGrid sample files in original
' form or modified, provided that you agree that Stinga has no warranty,
' obligations, or liability for any sample application files.
'-----------------------------------------------------------------------------
Option Explicit

Private WithEvents SGGrid As SGGrid
Attribute SGGrid.VB_VarHelpID = -1
Private marColors(63) As Long
Private marWebColors() As String

Private Const CELL_WIDTH = 260
Private Const CELLS_BORDER_WIDTH = 45
Private Const TAB_WIDTH = 43

Implements IsgGridCustomDraw

Private rcTab As RECT

Private miCurrent As Integer

Public Event GetColor(lColor As OLE_COLOR)


Const WEB_COLORS = "Aliceblue#16775408;" & _
   "Antiquewhite#14150650;Aqua#16776960;Aquamarine#13959039;Azure#16777200;Beige#14480885;Bisque#12903679;Black#0;Blanchedalmond#13495295;Blue#16711680;Blueviolet#14822282;" & _
   "Brown#2763429;Burlywood#8894686;Cadetblue#10526303;Chartreuse#65407;Chocolate#1993170;Coral#5275647;Cornflower#15570276;Cornsilk#14481663;Crimson#3937500;Cyan#16776960;" & _
   "Darkblue#9109504;Darkcyan#9145088;Darkgoldenrod#755384;Darkgray#11119017;Darkgreen#100;Darkkhaki#7059389;Darkmagenta#9109643;Darkolivegreen#3107669;Darkorange#36095;Darkorchid#13382297;" & _
   "Darkred#139;Darksalmon#8034025;Darkseagreen#9157775;Darkslateblue#9125192;Darkslategray#5197615;Darkturquoise#13749760;Darkviolet#148;Deeppink#9639167;Deepskyblue#16760576;Dimgray#6908265;" & _
   "Dodgerblue#16748574;Firebrick#2237106;Floralwhite#15792895;Forestgreen#2263842;Fuchsia#16711935;Gainsboro#14474460;Ghostwhite#16775416;Gold#55295;Goldenrod#2139610;Gray#8421504;" & _
   "Green#128;Greenyellow#3145645;Honeydew#15794160;Hotpink#11823615;Indianred#6053069;Indigo#8519755;Ivory#15794175;Khaki#9234160;Lavender#16443110;Lavenderblush#16118015;" & _
   "Lawngreen#64636;Lemonchiffon#13499135;Lightblue#15128749;Lightcoral#8421616;Lightcyan#16777184;Lightgoldenrodyellow#13826810;Lightgreen#9498256;Lightgray#13882323;Lightpink#12695295;Lightsalmon#8036607;" & _
   "Lightseagreen#11186720;Lightskyblue#16436871;Lightslategray#10061943;Lightsteelblue#14599344;Lightyellow#14745599;Lime#65280;Limegreen#3329330;Linen#15134970;Magenta#16711935;Maroon#128;" & _
   "Mediumaquamarine#11193702;Mediumblue#13434880;Mediumorchid#13850042;Mediumpurple#14381203;Mediumseagreen#7451452;Mediumslateblue#15624315;Mediumspringgreen#10156544;Mediumturquoise#13422920;Mediumvioletred#8721863;Midnightblue#7346457;" & _
   "Mintcream#16449525;Mistyrose#14804223;Moccasin#11920639;Navajowhite#11394815;Navy#32896;Oldlace#15136253;Olive#32896;Olivedrab#2330219;Orange#42495;Orangered#17919;" & _
   "Orchid#14053594;Palegoldenrod#11200750;Palegreen#10025880;Paleturquoise#15658671;Palevioletred#9662683;Papayawhip#14020607;Peachpuff#12180223;Peru#4163021;Pink#13353215;Plum#14524637;" & _
   "Powderblue#15130800;Purple#8388736;Red#255;Rosybrown#9408444;Royalblue#9464129;Saddlebrown#1262987;Salmon#7504122;Sandybrown#6333684;Seagreen#5737262;Seashell#15660543;" & _
   "Sienna#2970272;Silver#12632256;Skyblue#15453831;Slateblue#13458026;Slategray#9470064;Snow#16448255;Springgreen#8388352;Steelblue#11829830;Tan#9221330;Teal#8421504;" & _
   "Thistle#14204888;Tomato#4678655;Turquoise#13688896;Violet#15631086;Wheat#11788021;White#16777215;Whitesmoke#16119285;Yellow#65535;Yellowgreen#3329434"





Private Sub InitColors()
   Const PAL_COLORS = "255,255,255;255,192,192;255,224,192;255,255,192;192,255,192;" & _
      "192,255,255;192,192,255;255,192,255;224,224,224;255,128,128;255,192,128;255,255,128;" & _
      "128,255,128;128,255,255;128,128,255;255,128,255;192,192,192;255,0,0;255,128,0;255,255,0;" & _
      "0,255,0;0,255,255;0,0,255;255,0,255;128,128,128;192,0,0;192,64,0;192,192,0;0,192,0;" & _
      "0,192,192;0,0,192;192,0,192;64,64,64;128,0,0;128,64,0;128,128,0;0,128,0;0,128,128;0,0,128;" & _
      "128,0,128;0,0,0;64,0,0;128,64,64;64,64,0;0,64,0;0,64,64;0,0,64;64,0,64"
   Dim arAllColors() As String
   Dim arCurColor() As String
   Dim i As Integer

   arAllColors = Split(PAL_COLORS, ";")

   For i = 0 To UBound(arAllColors)
      arCurColor = Split(arAllColors(i), ",")
      marColors(i) = RGB(arCurColor(0), arCurColor(1), arCurColor(2))
   Next

   For i = UBound(arAllColors) + 1 To UBound(marColors)
      marColors(i) = vbWhite
   Next
End Sub


Private Sub ReturnColor()
   If miCurrent = 0 Then
      RaiseEvent GetColor(SGGrid.CurrentCell.Style.BackColor)
   Else
      RaiseEvent GetColor(CLng(SGGrid.CurrentCell.Value))
   End If
   SGGrid.Visible = False
End Sub

Private Sub SetPallete()
   Dim i As Integer, j As Integer, iColor As Integer
   Dim cell As SGCell

   With SGGrid
      .Styles.RemoveAll
      .Columns.RemoveAll True
      .GridLines = sgGridLineFlat
      .FocusRect = sgFocusRectSolid
      .ScrollBars = sgSBNone
      .SpecialMode = sgModeNone
      .FitLastColumn = False
      .HeadingColCount = 0
      .HeadingRowCount = 0
      .SelectionMode = sgSelectionNone
      .BackColor = vbButtonFace

      .DataColCount = 10
      .DataRowCount = 9

      For i = 1 To 8
         With .Rows.At(i)
            .Height = CELL_WIDTH
            .Style.Borders = sgCellBorderAll
            .Style.BorderSize = 1
            .Style.BorderColor = vbButtonShadow
            For j = 1 To 8
               .Cells(j).Style.BackColor = marColors(iColor)
               iColor = iColor + 1
            Next
         End With
         With .Columns.At(i)
            .Width = CELL_WIDTH
            .Style.Borders = sgCellBorderAll
            .Style.BorderSize = 1
            .Style.BorderColor = vbButtonShadow
         End With
      Next

      For i = 0 To 9 Step 9
         With .Columns.At(i)
            .Width = CELLS_BORDER_WIDTH
            .Style.BackColor = vbButtonFace
            .AllowFocus = False
            .Style.Borders = sgCellNoBorder
         End With
      Next

      With .Rows.At(0)
         .Height = CELLS_BORDER_WIDTH
         .Style.BackColor = vbButtonFace
         .AllowFocus = False
         For Each cell In .Cells
            cell.Style.Borders = sgCellNoBorder
         Next
      End With
      .Col = 1
      .Row = 1
   End With
End Sub

Private Sub SetWebColor()
   Dim ar As SGArray
   Dim i As Long

   Dim arc() As String

   With SGGrid
      .Styles.RemoveAll
      .Columns.RemoveAll True
      .FitLastColumn = True
      .DataRowCount = 0
      .DataRowCount = UBound(marWebColors) + 1
      .DataColCount = 1
      .ScrollBars = sgSBVertical
      .GridLines = sgGridLineNone
      .FocusRect = sgFocusRectDotted
      .SpecialMode = sgModeListBox
      .SelectionMode = sgSelectionByRow
      .BackColor = vbWhite
      .FlatScrollBars = sgSBEncartaMode

      With .Columns.At(0)
         .Style.Format = "FormatText Event"
         .Style.CustomDraw = sgDrawAfterCellBkg
      End With
      Set ar = .Array
   End With

   For i = 0 To UBound(marWebColors)
      arc = Split(marWebColors(i), "#")
      ar.Value(i, 0) = arc(1)
   Next

   Set ar = Nothing
End Sub


Private Sub SetSysColor()
   Dim ar As SGArray
   Dim i As Long

   With SGGrid
      .Styles.RemoveAll
      .Columns.RemoveAll True
      .FitLastColumn = True
      .DataRowCount = 0
      .DataRowCount = 25
      .DataColCount = 1
      .ScrollBars = sgSBVertical
      .GridLines = sgGridLineNone
      .FocusRect = sgFocusRectDotted
      .SpecialMode = sgModeListBox
      .SelectionMode = sgSelectionByRow
      .BackColor = vbWhite
      .FlatScrollBars = sgSBEncartaMode

      With .Columns.At(0)
         .Style.Format = "FormatText Event"
         .Style.CustomDraw = sgDrawAfterCellBkg
      End With
      Set ar = .Array
   End With

   For i = 0 To 24
      ar.Value(i, 0) = GetSysColor(i)
   Next

   Set ar = Nothing
End Sub



Public Sub Show(Left As Single, Top As Single)
   SGGrid.Move Left, Top
   SGGrid.Visible = True
   SGGrid.SetFocus
End Sub

Private Sub Class_Initialize()
   InitColors
   marWebColors = Split(WEB_COLORS, ";")
End Sub

Private Sub Class_Terminate()
   Set SGGrid = Nothing
End Sub


Private Sub IsgGridCustomDraw_DrawCell(ByRef drawInfo As sgGridCustomDraw, _
                                       response As sgCustomDrawResponse)
   Dim hPen As Long
   Dim hOldPen As Long
   Dim sData As String

   response = sgDoDefault

   ' Ignore heading cells
   If drawInfo.Heading <> 0 Then Exit Sub

   If drawInfo.DrawStage = sgDrawAfterCellBkg Then
      If drawInfo.ColIndex = 1 Then
         ' Draw left positioned color box and adjust content rect
         ' so grid's default painting will not overwrite our color box
         ' Get color
         Dim clr As Long

         clr = CLng(drawInfo.Data)

         ' Draw rectangle
         DrawRectangle drawInfo.DC, clr, drawInfo.Left + 4, drawInfo.Top + 2, _
                                          drawInfo.Left + (drawInfo.Bottom - drawInfo.Top), drawInfo.Bottom - 2

         drawInfo.Left = drawInfo.Left + 26
      End If
   End If
End Sub


Private Sub IsgGridCustomDraw_DrawGridBkg( _
   drawInfo As sgGridCustomDraw, _
   response As sgCustomDrawResponse)

   Dim hBrush As Long, i%, sText As String
   Dim plf As LOGFONT, hFont&, hfontOld&
   Dim lBtnStyle As Long, lBtnFlag As Long

   Dim rc As RECT

   If drawInfo.DrawStage = sgDrawAfterGridCaption Then
      SetFonts plf

      hFont = CreateFontIndirect(plf)
      hfontOld = SelectObject(drawInfo.DC, hFont)

      rc.Left = drawInfo.Left + 3
      rc.Top = drawInfo.Top + 2
      rc.Right = drawInfo.Left + TAB_WIDTH
      rc.Bottom = drawInfo.Bottom - 5
      rcTab = rc

      For i = 0 To 2
         lBtnStyle = IIf(i = miCurrent, BDR_RAISEDINNER, BDR_SUNKENOUTER)
         lBtnFlag = IIf(i = miCurrent, BF_TAB, BF_RECT)

         DrawEdge drawInfo.DC, rc, lBtnStyle, lBtnFlag

         sText = Choose(i + 1, "Pallete", "System", "Web")
         Call DrawText(drawInfo.DC, sText, Len(sText), rc, _
            DT_CENTER Or DT_SINGLELINE Or DT_VCENTER)
         rc.Left = rc.Right
         rc.Right = rc.Left + TAB_WIDTH
      Next

      rc.Top = -9
      rc.Right = drawInfo.Right + 2
      DrawEdge drawInfo.DC, rc, BDR_SUNKENOUTER, BF_BOTTOM
      rc.Left = 0: rc.Right = 6
      DrawEdge drawInfo.DC, rc, BDR_SUNKENOUTER, BF_BOTTOM + BF_LEFT
      'delete fonts
      Call SelectObject(drawInfo.DC, hfontOld)
      Call DeleteObject(hFont)
   End If

   response = sgDoDefault
End Sub

Private Sub SetFonts(plf As LOGFONT)
   Dim i%, byLett As Byte
   Const FONT_NAME = "MS Sans Serif"

   For i = 0 To 32
      plf.lfFaceName(i) = 0
   Next

   For i = 0 To Len(FONT_NAME) - 1
      byLett = Asc(Mid$(FONT_NAME, i + 1, 1))
      plf.lfFaceName(i) = byLett
   Next

   plf.lfHeight = 13
   plf.lfWeight = 400

End Sub





Private Sub SGGrid_DblClick()

   If miCurrent = 0 Then
      If (SGGrid.MouseCol < 1 Or SGGrid.MouseCol > 8) Or _
         SGGrid.MouseRow < 1 Then Exit Sub
   Else
      If SGGrid.MouseCol = -1 Or SGGrid.MouseRow = -1 Then Exit Sub
   End If

   ReturnColor
End Sub

Private Sub SGGrid_FormatText(ByVal RowKey As Long, ByVal ColIndex As Long, ByVal CellKind As sgCellKind, Value As Variant)
   Dim iRowPos As Integer

   iRowPos = SGGrid.Rows(RowKey).Position

   If miCurrent = 1 Then
      Select Case iRowPos
         Case COLOR_SCROLLBAR: Value = "Scroll Bars"
         Case COLOR_BACKGROUND: Value = "Desktop"
         Case COLOR_ACTIVECAPTION: Value = "Active Title Bar"
         Case COLOR_INACTIVECAPTION: Value = "Inactive Title Bar"
         Case COLOR_MENU: Value = "Menu Bar"
         Case COLOR_WINDOW: Value = "Window Background"
         Case COLOR_WINDOWFRAME: Value = "Window Frame"
         Case COLOR_MENUTEXT: Value = "Menu Text"
         Case COLOR_WINDOWTEXT: Value = "Window Text"
         Case COLOR_CAPTIONTEXT: Value = "Active Title Bar Text"
         Case COLOR_ACTIVEBORDER: Value = "Active Border"
         Case COLOR_INACTIVEBORDER: Value = "Inactive Border"
         Case COLOR_APPWORKSPACE: Value = "Application Workspace"
         Case COLOR_HIGHLIGHT: Value = "Highlight"
         Case COLOR_HIGHLIGHTTEXT: Value = "Highlight Text"
         Case COLOR_BTNFACE: Value = "Button Face"
         Case COLOR_BTNSHADOW: Value = "Button Shadow"
         Case COLOR_GRAYTEXT: Value = "Disabled Text"
         Case COLOR_BTNTEXT: Value = "Button Text"
         Case COLOR_INACTIVECAPTIONTEXT: Value = "Inactive Title Bar Text"
         Case COLOR_BTNHIGHLIGHT: Value = "Button Highlight"
         Case COLOR_3DDKSHADOW: Value = "Button Dark Shadow"
         Case COLOR_3DLIGHT: Value = "Button Light Shadow"
         Case COLOR_INFOTEXT: Value = "ToolTip Text"
         Case COLOR_INFOBK: Value = "ToolTip"
      End Select
   ElseIf miCurrent = 2 Then
      Dim iPos As Integer

      iPos = InStr(marWebColors(iRowPos), "#")
      Value = Left$(marWebColors(iRowPos), iPos - 1)
   End If
End Sub

Private Sub SGGrid_KeyDown(KeyCode As Integer, Shift As Integer)
   If KeyCode = vbKeyReturn Then ReturnColor

   If KeyCode = vbKeyTab And Shift = vbCtrlMask Then
      miCurrent = IIf(miCurrent = 0, 1, 0)

      If miCurrent = 0 Then
         SetPallete
      Else
         SetSysColor
      End If

      SGGrid.Redraw
   End If
End Sub

Private Sub SGGrid_LostFocus()
   SGGrid.Visible = False
End Sub


Private Sub SGGrid_MouseDown( _
   Button As Integer, Shift As Integer, _
   x As Single, Y As Single)

   On Error Resume Next

   If miCurrent = 0 And Button = 2 Then
      Dim lRowKey As Long, cell As SGCell
      Dim sColKey As String

      If SGGrid.HitTestEx(x, Y, lRowKey, sColKey, sgCellStandard) = sgHitCell Then
         Set cell = SGGrid.cell(lRowKey, sColKey)

         If (cell.Row.Position = 7 Or cell.Row.Position = 8) And _
            (cell.Column.Position > 0 And cell.Column.Position < 9) Then
            Dim oCommDlg As Object

            Set oCommDlg = CreateObject("MSComDlg.CommonDialog")

            oCommDlg.CancelError = True
            oCommDlg.ShowColor
            If Err = 0 Then
               cell.Style.BackColor = oCommDlg.Color
               marColors(cell.Row.Position * 8 - (8 - cell.Column.Position) - 1) = _
                  oCommDlg.Color
               cell.Redraw
            End If
            Set oCommDlg = Nothing
         End If

         Set cell = Nothing
      End If
   End If
End Sub

Private Sub SGGrid_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
   If SGGrid.HitTest(x, Y) = sgHitCaption Then
      Dim xpx As Long, ypx As Long
      Dim rc As RECT, i%

      xpx = x / Screen.TwipsPerPixelX
      ypx = Y / Screen.TwipsPerPixelY
      rc = rcTab

      For i = 0 To 2
         If PtInRect(rc, xpx, ypx) <> 0 Then
            If miCurrent <> i Then
               miCurrent = i
               If miCurrent = 0 Then
                  SetPallete
               ElseIf miCurrent = 1 Then
                  SetSysColor
               ElseIf miCurrent = 2 Then
                  SetWebColor
               End If
            End If
            SGGrid.Redraw
            Exit Sub
         End If
         rc.Left = rc.Right
         rc.Right = rc.Left + TAB_WIDTH
      Next
   End If
End Sub



Public Property Get Grid() As SGGrid
   Set Grid = SGGrid
End Property

Public Property Set Grid(ByVal vNewValue As SGGrid)
   Dim lCaptionHeight As Long

   Set SGGrid = vNewValue

   Set SGGrid.PaintObject = Me

   With SGGrid
      .Visible = False
      .ZOrder 0
      .CustomBkgDraw = sgDrawBeforeGridBkg
      .Appearance = sgFlat
      .CellsBorderVisible = False

      .Styles("Caption").Font.Size = 14
      .Caption = " "
      .AllowEdit = False
      .GroupByBoxVisible = False

      SetPallete

      lCaptionHeight = .Height - .ClientHeight

      .Width = CELL_WIDTH * 8 + (CELLS_BORDER_WIDTH * 2)
      .Height = CELL_WIDTH * 8 + lCaptionHeight + CELLS_BORDER_WIDTH
   End With
End Property