【CBM666 的RGB取色】 - vb吧

level 13

cbm666 楼主

添加 Command1 CommonDialog1
'摘录自【CBM666 VB编程示例教材图像篇_窗体取色】
Option Explicit
Private WithEvents Picture1 As PictureBox '自定义线上添加控件picture1的声明
Private WithEvents Picture2 As PictureBox '自定义线上添加控件picture2的声明
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Dim AppDisk$, MyHwnd&, MyHdc&, Red&, Green&, Blue&, ColorVal& '变量声明与型态定义 $=String文字型 &=Long长整型
Private Sub Form_Load()
AppDisk = IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\") '判断本地路径的\ 赋值给变量AppDisk
Set Picture1 = Me.Controls.Add("VB.PictureBox", "Picture1") '线上添加picture1控件
Picture1.BorderStyle = 0 '图片框picture1设定为无边框
Picture1.Visible = True '线上添加的控件默认为不可见所以得加上这行让它可见.
Picture1.Move 5450, 7320, 4250, 495 '设定picture1的宽度与高度并移动到5450,7320的坐标位置
Set Picture2 = Me.Controls.Add("VB.PictureBox", "Picture2") '线上添加picture2控件
Picture2.BorderStyle = 0 '图片框picture2设定为无边框
Me.AutoRedraw = True '窗体自动重画为真
Me.Width = 9840: Me.Height = 8370 '定义窗体宽度与高度 (中间的冒号表示不换行,两行代码简化为一行)
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2 '窗体居于屏幕中心位置
Me.Picture = LoadPicture(AppDisk & "ColorSet.jpg") '本地路径下的ColorSet.jpg装载进窗体当背景图片
Command1.Caption = "选择图片"
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
ColorVal = GetPixel(Me.hdc, X \ 15, Y \ 15) '使用API GetPixel 获取颜色十进制值
Call GetRGB '调用颜色十进制值转换为RGB的副程序
Me.Caption = CStr(ColorVal) & "--- R:" & CStr(Red) & ",G:" & CStr(Green) & ",B:" & CStr(Blue) '窗口标题显示颜色值
Picture1.BackColor = RGB(Red, Green, Blue) '将右下角的picture1 涂上当前鼠标指向的颜色同步刷新
End Sub
Private Sub Form_Unload(Cancel As Integer)
Controls.Remove ("Picture1") '移除动态添加的控件
Controls.Remove ("Picture2")
ReleaseDC MyHwnd, MyHdc '释放影像内存
Set Form1 = Nothing '释放窗体占用内存
End '退出结束程序
End Sub
Private Sub Command1_Click()
On Error GoTo Errhandler ' 捕捉错误
With CommonDialog1
.DialogTitle = "打开图片"
.DefaultExt = ".jpg" ' 设置默认的扩展名
.Filter = "所有支持的图片格式" & "(*.bmp;*.jpg;*.gif)|" & "*.bmp;*.jpg;*.gif)"
.ShowOpen ' 显示"另存为"对话框
End With
Picture2.Picture = LoadPicture(CommonDialog1.FileName)
Me.Cls
Me.PaintPicture Picture2.Picture, 5450, 60, 4250, 3188
Errhandler:
If Err > 0 Then Exit Sub
End Sub
Sub GetRGB() '颜色十进制值转换为RGB的副程序
Red = (ColorVal And &HFF&)
Green = (ColorVal And &HFF00&) \ 256
Blue = (ColorVal And &HFF0000) \ 65536
End Sub
代码使用到的图片请保存为 Coloset.jpg