VB中自定义一个调色板

最新推荐文章于 2025-06-08 11:37:47 发布

原创最新推荐文章于 2025-06-08 11:37:47 发布 · 2.8k 阅读

2 ·

CC 4.0 BY-SA版权

文章标签：

#vb #colors #图形 #c

这是一个关于在VB中创建和使用自定义调色板的代码示例。通过`CreateColorPal`函数可以将一个对象设置为调色板，`GetPicColor`函数用于从调色板中获取指定位置的颜色值。此外，还包含设置按钮颜色和图片复制的功能。

' 
'图形颜色类' 
Option Explicit
Dim Colors() As Variant
Dim ColorToUse As Long
' 
'建立一个调色板. 
'函数名: CreateColorPal 
'入口参数: ColorPic As Object 
'说明:ColorPic 欲设置成调色板的对象名 
'作用: 将一个对象设置成一个调色板 
Public Sub CreateColorPal(ColorPic As Object)
    Dim I As Long
    ColorPic.AutoRedraw = True
    ColorPic.Scale (0, 0)-(16, 3)
    Colors = Array(16777215, 14737632, 12632319, 12640511, _
                   14745599, 12648384, 16777152, 16761024, _
                   16761087, 192, 16576, 49344, _
                   49152, 12632064, 12582912, 12583104, _
                   12632256, 4210752, 8421631, 8438015, _
                   8454143, 8454016, 16777088, 16744576, _
                   16744703, 128, 16512, 32896, _
                   32768, 8421376, 8388608, 8388736, _
                   8421504, 0, 255, 33023, _
                   65535, 65280, 16776960, 16711680, _
                   16711935, 64, 4210816, 16448, _
                   16384, 4210688, 4194304, 4194368)
    
    For I = 0 To 15
        ColorPic.Line (I, 0)-(I + 1, 1), Colors(I), BF
        ColorPic.Line (I, 1)-(I + 1, 2), Colors(I + 16), BF
        ColorPic.Line (I, 2)-(I + 1, 3), Colors(I + 32), BF
        If I > 0 Then
            ColorPic.Line (I, 0)-(I, 3)
        End If
    Next I
    ColorPic.Line (0, 1)-(16, 1)
    ColorPic.Line (0, 2)-(16, 2)
End Sub
' 
'从调色板中取颜色. 
'函数名: GetPicColor 
'入口参数: ColorPic As Object, x As Single, y As Single 
'返回值:该点的颜色值 
'说明:ColorPic已设置成调色板的对象名:(X,Y)该点坐标. 
'作用: 从调色板中取(x,y)点颜色值 
'*注: 请在MouseDown 或 MouseUp事件中使用 
Public Function GetPicColor(ColorPic As Object, X As Single, Y As Single) As Long
    On Error Resume Next
    Dim W As Long, h As Long, c As Long
    
    W = ColorPic.ScaleWidth
    h = ColorPic.ScaleHeight
    If (X <= 0) Or (X >= W) Or (Y <= 0) Or (Y > h) Then
         Exit Function
    End If
    c = Fix(X) + Fix(Y) * 16
    ColorToUse = Colors(c)
    GetPicColor = ColorToUse
End Function
Private Sub Class_Initialize()
    Dim T As New ClsRev
    Call T.GetIniVal
    Set T = Nothing
End Sub
' 
'设置按钮颜色. 
'函数:SetComFore 
'参数:ObjWin 目标窗体名.FontColor 按钮的字体颜色,PTwidth 如果存在图片,设置图片与文件字间距. 
'返回值:无 
Public Function SetComFore(ObjWin As Object, Optional FontColor As Long = 0, Optional PTwidth As Long = 0)
       Dim Frm As Form
       Set Frm = ObjWin
       
       With SetFrmCom
            Call .ChComFcolor(Frm, .CjhPicToComm, .CjhFontSize, .CjhPicSize, FontColor, PTwidth)
       End With
       Unload SetFrmCom
       Set SetFrmCom = Nothing
End Function
' 
'图片到图片复制.. 
'函数:PicToPic 
'参数:BigWidth 最大宽度.BigHeight 最大高度,SourPic 源图片框,ObjPic 目标图片框. 
'返回值:无 
Public Function PicToPic(BigWidth As Long, BigHeight As Long, ByRef SourPic As Object, ByRef ObjPic As Object)
    Dim RName As String
    Dim Pw As Long
    Dim Ph As Long
    Dim T1 As Double
    Dim T2 As Double
    
    Pw = SourPic.Width: Ph = SourPic.Height
    
    If SourPic.Picture <> 0 Then
       ObjPic.Visible = False
       T2 = Pw / Ph
       T1 = BigWidth / BigHeight
       If Pw > BigWidth Or Ph > BigHeight Then
            If T2 > T1 Then
               ObjPic.Width = BigWidth
               ObjPic.Height = BigWidth / T2
            Else
               ObjPic.Width = BigHeight * T2
               ObjPic.Height = BigHeight
            End If
       Else
            ObjPic.Width = Pw
            ObjPic.Height = Ph
       End If
       ObjPic.Picture = SourPic.Picture
       ObjPic.Move (BigWidth - ObjPic.Width) / 2, (BigHeight - ObjPic.Height) / 2
       ObjPic.Visible = True
    End If
End Function