翻出来以前写的一篇文章: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