VB中自定义一个调色板

 

1. '
2. '图形颜色类'
4. Option Explicit
6. Dim Colors() As Variant
7. Dim ColorToUse As Long
9. '
10. '建立一个调色板.
11. '函数名: CreateColorPal
12. '入口参数: ColorPic As Object
13. '说明:ColorPic 欲设置成调色板的对象名
14. '作用: 将一个对象设置成一个调色板
15. Public Sub CreateColorPal(ColorPic As Object)
16.     Dim I As Long
17.     ColorPic.AutoRedraw = True
18.     ColorPic.Scale (0, 0)-(16, 3)
19.     Colors = Array(16777215, 14737632, 12632319, 12640511, _
20.                    14745599, 12648384, 16777152, 16761024, _
21.                    16761087, 192, 16576, 49344, _
22.                    49152, 12632064, 12582912, 12583104, _
23.                    12632256, 4210752, 8421631, 8438015, _
24.                    8454143, 8454016, 16777088, 16744576, _
25.                    16744703, 128, 16512, 32896, _
26.                    32768, 8421376, 8388608, 8388736, _
27.                    8421504, 0, 255, 33023, _
28.                    65535, 65280, 16776960, 16711680, _
29.                    16711935, 64, 4210816, 16448, _
30.                    16384, 4210688, 4194304, 4194368)
31.     
32.     For I = 0 To 15
33.         ColorPic.Line (I, 0)-(I + 1, 1), Colors(I), BF
34.         ColorPic.Line (I, 1)-(I + 1, 2), Colors(I + 16), BF
35.         ColorPic.Line (I, 2)-(I + 1, 3), Colors(I + 32), BF
37.         If I > 0 Then
38.             ColorPic.Line (I, 0)-(I, 3)
39.         End If
40.     Next I
41.     ColorPic.Line (0, 1)-(16, 1)
42.     ColorPic.Line (0, 2)-(16, 2)
43. End Sub
45. '
46. '从调色板中取颜色.
47. '函数名: GetPicColor
48. '入口参数: ColorPic As Object, x As Single, y As Single
49. '返回值:该点的颜色值
50. '说明:ColorPic已设置成调色板的对象名:(X,Y)该点坐标.
51. '作用: 从调色板中取(x,y)点颜色值
52. '*注: 请在MouseDown 或 MouseUp事件中使用
53. Public Function GetPicColor(ColorPic As Object, X As Single, Y As Single) As Long
54.     On Error Resume Next
55.     Dim W As Long, h As Long, c As Long
56.     
57.     W = ColorPic.ScaleWidth
58.     h = ColorPic.ScaleHeight
59.     If (X <= 0) Or (X >= W) Or (Y <= 0) Or (Y > h) Then
60.          Exit Function
61.     End If
62.     c = Fix(X) + Fix(Y) * 16
63.     ColorToUse = Colors(c)
64.     GetPicColor = ColorToUse
65. End Function
68. Private Sub Class_Initialize()
69.     Dim T As New ClsRev
70.     Call T.GetIniVal
71.     Set T = Nothing
72. End Sub
74. '
75. '设置按钮颜色.
76. '函数:SetComFore
77. '参数:ObjWin 目标窗体名.FontColor 按钮的字体颜色,PTwidth 如果存在图片,设置图片与文件字间距.
78. '返回值:无
79. Public Function SetComFore(ObjWin As Object, Optional FontColor As Long = 0, Optional PTwidth As Long = 0)
80.        Dim Frm As Form
81.        Set Frm = ObjWin
82.        
83.        With SetFrmCom
84.             Call .ChComFcolor(Frm, .CjhPicToComm, .CjhFontSize, .CjhPicSize, FontColor, PTwidth)
85.        End With
86.        Unload SetFrmCom
87.        Set SetFrmCom = Nothing
88. End Function
90. '
91. '图片到图片复制..
92. '函数:PicToPic
93. '参数:BigWidth 最大宽度.BigHeight 最大高度,SourPic 源图片框,ObjPic 目标图片框.
94. '返回值:无
95. Public Function PicToPic(BigWidth As Long, BigHeight As Long, ByRef SourPic As Object, ByRef ObjPic As Object)
96.     Dim RName As String
97.     Dim Pw As Long
98.     Dim Ph As Long
99.     Dim T1 As Double
100.     Dim T2 As Double
101.     
102.     Pw = SourPic.Width: Ph = SourPic.Height
103.     
104.     If SourPic.Picture <> 0 Then
105.        ObjPic.Visible = False
106.        T2 = Pw / Ph
107.        T1 = BigWidth / BigHeight
108.        If Pw > BigWidth Or Ph > BigHeight Then
109.             If T2 > T1 Then
110.                ObjPic.Width = BigWidth
111.                ObjPic.Height = BigWidth / T2
112.             Else
113.                ObjPic.Width = BigHeight * T2
114.                ObjPic.Height = BigHeight
115.             End If
116.        Else
117.             ObjPic.Width = Pw
118.             ObjPic.Height = Ph
119.        End If
120.        ObjPic.Picture = SourPic.Picture
121.        ObjPic.Move (BigWidth - ObjPic.Width) / 2, (BigHeight - ObjPic.Height) / 2
122.        ObjPic.Visible = True
123.     End If
124. End Function