加入一个TextBox控件,一个Command控件
成都创新互联公司长期为上千多家客户提供的网站建设服务，团队从业经验10年，关注不同地域、不同群体，并针对不同对象提供差异化的产品和服务；打造开放共赢平台，与合作伙伴共同营造健康的互联网生态环境。为深泽企业提供专业的网站设计制作、做网站，深泽网站改版等技术服务。拥有十余年丰富建站经验和众多成功案例,为您定制开发。
代码:
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Sub Command1_Click()
Dim Color As Long
WindowDC = GetWindowDC(0) '获取屏幕的设备场景
Color = GetPixel(WindowDC, 500, 100) '获指定点的颜色
'分解RGB颜色值
R = (Color Mod 256) '红色
b = (Int(Color \ 65536)) '蓝色
G = ((Color - (b * 65536) - R) \ 256) '绿色
Text1.BackColor = RGB(R, G, b)
End Sub
Using b As New Bitmap(1, 1)
Using g As Graphics = Graphics.FromImage(b)
g.CopyFromScreen(New Point(300, 300), New Point, New Size(1, 1))
PictureBox1.BackColor = b.GetPixel(0, 0)
End Using
End Using
复制当前屏幕左上角位置（300,300）的一个点，取其颜色
我有个笨办法，先用API抓图到内存里，然后再在根据你点鼠标的屏幕工作区坐标，去那图里取色。
-----------------------
'抓图所需的API
Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Integer) As Integer
Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer) As Integer
Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
Private Declare Function BitBlt Lib "GDI32" (ByVal srchDC As Integer, ByVal srcX As Integer, ByVal srcY As Integer, ByVal srcW As Integer, ByVal srcH As Integer, ByVal desthDC As Integer, ByVal destX As Integer, ByVal destY As Integer, ByVal op As Integer) As Integer
Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Integer) As Integer
Private Declare Function DeleteObject Lib "GDI32" (ByVal hObj As Integer) As Integer
Declare Function GetDC Lib "user32" Alias "GetDC" (ByVal hwnd As Integer) As Integer
Const SRCCOPY As Integer = HCC0020
'抓图的部分
Dim hDC, hMDC As Integer
Dim hBMP, hBMPOld As Integer
Dim sw, sh As Integer
hDC = GetDC(0)
hMDC = CreateCompatibleDC(hDC)
sw = Screen.PrimaryScreen.Bounds.Width
sh = Screen.PrimaryScreen.Bounds.Height
hBMP = CreateCompatibleBitmap(hDC, sw, sh)
hBMPOld = SelectObject(hMDC, hBMP)
BitBlt(hMDC, 0, 0, sw, sh, hDC, 0, 0, SRCCOPY)
hBMP = SelectObject(hMDC, hBMPOld)
Dim bmp As Bitmap = Image.FromHbitmap(New IntPtr(hBMP))
DeleteDC(hDC)
DeleteDC(hMDC)
DeleteObject(hBMP)
......
'取点的颜色
bmp.GetPixel(e.X, e.Y)
----------------------------
关键就是这些你自己组合吧，你分给的太少了，很麻烦，恕我不帮你改全了。如果要仔细帮你改，请另开高分贴，不要用新马甲来
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
MsgBox "你选取的颜色是" Hex(Point(X, Y))
End Sub
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbAlpha As Byte '透明通道
End Type
Private Type BITMAPINFOHEADER
biSize As Long '位图大小
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer '信息头长度
biCompression As Long '压缩方式
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Sub Command1_Click()
Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, r As Long, hDCSrc As Long, hPal As Long, hPalPrev As Long
Dim LeftSrc As Long, TopSrc As Long, WidthSrc As Long, HeightSrc As Long, bytDataOut() As Byte, lngOut() As Long
Dim BitInfo As BITMAPINFO
Dim i As Long, j As Long
'修改下面4个参数就可以调整画面范围
LeftSrc = 0
TopSrc = 0
WidthSrc = 1024
HeightSrc = 768
hDCSrc = GetWindowDC(0) '(hWndSrc)
hDCMemory = CreateCompatibleDC(hDCSrc)
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
hBmpPrev = SelectObject(hDCMemory, hBmp)
r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
ReDim bytDataOut(2, WidthSrc - 1, HeightSrc - 1)
ReDim lngOut(WidthSrc - 1, HeightSrc - 1)
With BitInfo.bmiHeader
.biBitCount = 24
.biCompression = 0
.biPlanes = 1
.biSize = Len(BitInfo.bmiHeader)
.biWidth = WidthSrc
.biHeight = -HeightSrc
End With
GetDIBits hDCMemory, hBmp, 0, HeightSrc, bytDataOut(0, 0, 0), BitInfo, 0
hBmp = SelectObject(hDCMemory, hBmpPrev)
r = DeleteDC(hDCMemory)
r = ReleaseDC(hWndSrc, hDCSrc)
DeleteObject hBmp
For i = LeftSrc To WidthSrc - 1
For j = TopSrc To HeightSrc - 1
lngOut(i, j) = RGB(bytDataOut(0, i, j), bytDataOut(1, i, j), bytDataOut(2, i, j))
Next
Next
MsgBox "数据已存放在lngOut数组里面" lngOut(5, 5)
End Sub
修改了下,这次没问题啦
R/G/B值最小是0最大是255属Byte值类型
Dim cr As Color = 控件.BackColor '获取控件背景色
Dim alpha As Byte = cr.A '透明度
Dim R As Byte = cr.R 'R值
Dim G As Byte = cr.G 'G值
Dim B As Byte = cr.B 'B值
Dim outAcr As Color = Color.FromArgb(alpha, R, G, B) '创建带有透明通道的ARGB颜色
Dim outcr As Color = Color.FromArgb(R, G, B) '创建不透明的RGB颜色
重庆分公司
重庆分公司
