翻出来以前写的一篇文章：Cg色彩精灵，这是用vb6来写的
搞图像创作都有那么个难题，就是在上色时候老是配不好颜色，不是显得红了就是偏蓝，不得不参考别人的配色或者翻看颜色参考书，为什么不尝试自己做一个保存颜色的程序，把觉得好的颜色存储起来，方便在配色时参看使用。
程序实现目标：1、程序可以配色；2、实现颜色的存储；3、屏幕取色。

第三部分：部分重点代码分析

1、模块 Module1

Public ColorId As Long				
‘公有变量，FormMain传递给FormAE的颜色编号，仅在修改颜色时有用
Public AddOrEdit As Boolean
‘公有变量，决定了FormAE窗体是增加新颜色还是修改原有颜色

Sub Main()
'这里是链接到数据库的语句，请参看源代码
FormMain.Show
End Sub

Function GetR(colorvalue As Long) As Integer    '此函数取得红色(R)基色值
GetR = colorvalue And &HFF					'colorvalue为传递的颜色值
End Function

Function GetG(colorvalue As Long) As Integer    '此函数取得绿色(R)基色值
GetG = (colorvalue And CLng("&HFF00")) / 256
End Function

Function GetB(colorvalue As Long) As Integer    '此函数取得蓝色(R)基色值
GetB = (colorvalue And &HFF0000) / 65536
End Function

2、模块 Module2

‘Api函数声明省略，请参看第二部分。

Public Function GetColor() As Long		'获得屏幕某点颜色值
    Dim Dc As Long
    Dim rret As Long
    Dim MousePos As POINTAPI
    
    Dc = GetDC(0)                	'取得整个屏幕的Dc
    rret = GetCursorPos(MousePos)  	'获取鼠标当前位置坐标
GetColor = GetPixel(Dc,MousePos.X,MousePos.Y) 
'获取鼠标当前像素点的颜色值
    rret = ReleaseDC(0,Dc)           	'释放屏幕Dc
End Function

3、窗体 FormMain

Private Sub CmdAddType_Click()			'增加颜色类型
    Strsql = "insert into colortypetable(colortype) values('" & ColorType & "')"
    Rs.Open Strsql						'ColorType是使用者输入的颜色类型名称
    ComboColor.AddItem ColorType		‘这里用到了AddItem方法
End Sub

Private Sub CmdDelType_Click()			‘删除颜色类型，确保默认的类型不被删除
If ComboColor.Text = "默认的类型" Then
    MsgBox "默认的类型不能删除"
    Exit Sub
End If
If MsgBox("删除类型，该类型下的颜色将会被置于默认的类型下" & "确定继续吗？",vbYesNo) = vbYes Then
    Strsql = "delete * from colortypetable where colortype='" & ComboColor.Text & "'"										
    Rs.Open Strsql
    Strsql = "update colornaMetable set colortype='默认的类型' where colortype='" & ComboColor.Text & "'"
    Rs.Open Strsql
    ComboColor.RemoveItem (ComboColor.ListIndex)
    ComboColor.Text = "默认的类型"
Else
    Exit Sub
End If
End Sub

Private Sub CmdDel_Click()				'删除颜色名称
Strsql = "delete * from colornaMetable where index=" & _
ListColor.ItemData (ListColor.ListIndex)
    Rs.Open Strsql						'这里删除在ListBox中选中的颜色名称
End Sub

Private Sub CmdEdit_Click()				'编辑颜色
ColorId = ListColor.ItemData(ListColor.ListIndex)
AddOrEdit = False
FormAE.Show 1
End Sub

Private Sub ComboColor_Click()		
ListColor.Clear
Strsql = "select * from ColorNaMetable where colortype='" & ComboColor.Text & "'"
Rs.Open Strsql
If Not Rs.EOF Then
    Do While Not Rs.EOF
        ListColor.AddItem Rs("colorname")
        ListColor.ItemData(ListColor.ListCount - 1) = Rs("index")   
'记录表中对应的编号
        Rs.MoveNext
    Loop
    Rs.Close
Else
    Rs.Close
End If
End Sub

Private Sub Form_Load()
Strsql = "select * from ColorTypeTable"
Rs.Open Strsql
If Not Rs.EOF Then
    Do While Not Rs.EOF
        ComboColor.AddItem Rs("colortype")
        Rs.MoveNext
    Loop
    Rs.Close
    ComboColor.Text = ComboColor.List(0)
Else
    Rs.Close
End If
End Sub

Private Sub ListColor_Click()			
Strsql = "select * from ColorNaMetable where index=" & ListColor.ItemData (ListColor.ListIndex)
Rs.Open Strsql     					 		'这里不用判断是否为EOF
    TextColorName.Text = Rs("colorname")
    PicColor.BackColor = CLng(Rs("colorvalue"))
    TextRgb10.Text = GetR(CLng(Rs("colorvalue"))) & "," & GetG(CLng(Rs("colorvalue"))) & "," & GetB(CLng(Rs("colorvalue")))
    Dim Value16() As String
    Value16 = Split(TextRgb10.Text,",")		‘这里用到了Split()函数
    TextRgb16.Text = "#" & Right("00" & Hex(Value16(0)),2) & Right("00" & Hex(Value16(1)),2) & Right("00" & Hex(Value16(2)),2)
Rs.Close
End Sub

4、窗体FormAE

Sub SaveColor()
Strsql = "insert into colornaMetable(colorname,colortype,colorvalue) values('" &          Trim(TextColorName) & "','" & ComboColor.Text & "','" & CStr(PicShow.BackColor) & "')"
Rs.Open Strsql
End Sub

Sub EditColor()
Strsql = "update colornaMetable set colorname='" & Trim(TextColorName.Text) & "',colortype='" &  ComboColor.Text & "',colorvalue='" & CStr(PicShow.BackColor) & "' where index=" & ColorId
Rs.Open Strsql
End Sub

Private Sub CmdOk_Click()
If AddOrEdit = True Then
Call SaveColor			'保存新的颜色
Else
Call EditColor			'保存修改后的颜色
End If
Unload Me
End Sub

Private Sub Form_Load()
Strsql = "select * from ColorTypeTable"
Rs.Open Strsql
Do While Not Rs.EOF         
'不用判断是否为空,因为ColorTypeTable中始终有一项，即默认的类型
    ComboColor.AddItem Rs("colortype")
    Rs.MoveNext
Loop
Rs.Close
ComboColor.Text = ComboColor.List(0)

If AddOrEdit = True Then
    Me.Caption = "增加新颜色"
    PicR.BackColor = RGB(255,0)
    PicG.BackColor = RGB(0,255,0)
    PicB.BackColor = RGB(0,255)
Else        '修改颜色
    Me.Caption = "修改颜色"
    Strsql = "select * from colornaMetable where index=" & ColorId
    Rs.Open Strsql
    If Rs.EOF Then
        MsgBox "打开数据库出错"
        Rs.Close
        Exit Sub
Else
	‘以下为获取数据，并计算RGB分量
        ComboColor.Text = Rs("colortype")
        TextColorName = Rs("colorname")
        HScrollColor(0).Value = GetR(Rs("colorvalue"))
        TextValue(0) = CStr(HScrollColor(0))
        HScrollColor(1).Value = GetG(Rs("colorvalue"))
        TextValue(1) = CStr(HScrollColor(1))
        HScrollColor(2).Value = GetB(Rs("colorvalue"))
        TextValue(2) = CStr(HScrollColor(2))
        PicR.BackColor = RGB(GetR(Rs("colorvalue")),0)
        PicG.BackColor = RGB(0,GetG(Rs("colorvalue")),0)
        PicB.BackColor = RGB(0,GetB(Rs("colorvalue")))
        Rs.Close
        
    End If
End If
End Sub

Private Sub HScrollColor_Change(Index As Integer)	
If Option1(0).Value = True Then
    TextValue(Index).Text = HScrollColor(Index).Value    
Else
    TextValue(Index).Text = Hex(HScrollColor(Index).Value)    
End If
PicShow.BackColor = RGB(HScrollColor(0).Value，HScrollColor(1).Value，HScrollColor(2).Value)
End Sub

    5、窗体FormPick
Sub SaveColor()					'此函数保存颜色
Strsql = "insert into colornaMetable(colorname,'" & CStr(PicPick.BackColor) & "')"
Rs.Open Strsql
End Sub

Private Sub CmdOk_Click()
Call SaveColor					'调用SaveColor函数来保存颜色
Unload Me
End Sub

Private Sub CmdPick_MouseDown(Button As Integer,Shift As Integer,X As Single,Y As Single)
Dim gret As Long
If Button = vbLeftButton Then
    gret = GetCapture()			'开始接受鼠标输入
    Me.MousePointer = 2		'设置鼠标指针为十字星模式
End If
End Sub

Private Sub CmdPick_MouseMove(Button As Integer,Y As Single)
Dim PickColors As Long
If Button = vbLeftButton Then   
    PickColors = GetColor()		'调用Module2中的GetColor()来获取某点颜色
    PicPick.BackColor = PickColors
End If
End Sub

Private Sub CmdPick_MouseUp(Button As Integer,Y As Single)
Dim rret As Long
rret = ReleaseCapture()			'释放鼠标捕获
Me.MousePointer = 0
End Sub

Private Sub Form_Load()			‘取色窗体载入时
Dim WindowPos As Long
WindowPos = SetWindowPos(Me.hwnd,HWND_TOPMOST,100,Me.Width / 15,Me.Height / 15,SWP_NOSIZE)
‘设置窗体为任何窗体的顶部
End Sub