GFCDSelectColor/GFCDSelectColor.frm

VERSION 5.00
Object = "{F9043C88‑F6F2‑101A‑A3C9‑08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3 'Windows‑Standard
   Begin MSComDlg.CommonDialog GFCDSelectColorCommonDialog
      Left            =   60
      Top             =   60
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton Command1
      Caption         =   "Command1"
      Height          =   360
      Left            =   2880
      TabIndex        =   0
      Top             =   2700
      Width           =   1680
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis. Make user select a color.

Private Sub Command1_Click()
    'on error resume next
    Dim Color As Long
    Color = GFCDSelectColor()
    Debug.Print Color
End Sub

Private Function GFCDSelectColor()
    On Error GoTo Error: 'important (if CommonDialog is not available); make user select a color; function returns True for error or canceled
    GoTo Error:
    GFCDSelectColorCommonDialog.DialogTitle = "" 'reset (not in use by CommonDialog control)
    On Error GoTo 0
    On Error GoTo CancelError:
    GFCDSelectColorCommonDialog.CancelError = True
    GFCDSelectColorCommonDialog.ShowColor
    GFCDSelectColor = GFCDSelectColorCommonDialog.Color 'ok
    Exit Function
Error:
    MsgBox "internal error in GFCDSelectColor(): Common Dialog not available !" + Chr(10) + "Check if related dlls are available.", vbOKOnly + vbExclamation, "GDCDSelectColor" 'use original function name as application name
    'GFCDSelectColor specific
    Dim Tempstr$
    Dim Temp As Long
    Dim R As Integer
    Dim G As Integer
    Dim B As Integer
    'preset (within GFCDSelectColor specific)
    Tempstr$ = InputBox("enter r, g, b value (i.e. '255,255,255'):", "Define a color")
    For Temp = 1 To Len(Tempstr$)
        If Mid$(Tempstr$, Temp, 1) = "," Then
            R = Val(Left$(Left$(Tempstr$, Temp ‑ 1), 3)) 'use Left$(..., 3) to avoid Integer overflow
            Tempstr$ = Right$(Tempstr$, Len(Tempstr$) ‑ Temp)
            Exit For
        End If
    Next Temp
    For Temp = 1 To Len(Tempstr$)
        If Mid$(Tempstr$, Temp, 1) = "," Then
            G = Val(Left$(Left$(Tempstr$, Temp ‑ 1), 3))
            Tempstr$ = Right$(Tempstr$, Len(Tempstr$) ‑ Temp)
            Exit For
        End If
    Next Temp
    B = Val(Left$(Left$(Tempstr$, 3), 3))
    'verify (within GFCDSelectColor specific)
    If R < 0 Then R = 0
    If G < 0 Then G = 0
    If B < 0 Then B = 0
    If R > 255 Then R = 255
    If G > 255 Then G = 255
    If B > 255 Then B = 255
    'begin (within GFCDSelectColor specific)
    GFCDSelectColor = RGB(R, G, B) 'ok
    'end of GFCDSelectColor specific
    Exit Function
CancelError:
    GFCDSelectColor = True 'error
    Exit Function
End Function


[END OF FILE]