求助，吸取颜色然后填充。VBA代码？

那不就

2021版本，这两个版本要用自定义安装才有VBA功能。

#If VBA7 然后
声明 PtrSafe 函数 GetPixel Lib “gdi32” （ByVal hdc As LongPtr， ByVal x As Long， ByVal y As Long） As Long
声明 PtrSafe 函数 GetDC Lib “user32” （ByVal hwnd As LongPtr） As LongPtr
声明 PtrSafe 函数 ReleaseDC Lib “user32” （ByVal hwnd As LongPtr， ByVal hdc As LongPtr） As Long
声明 PtrSafe 函数 FindWindow Lib “user32” 别名 “FindWindowA” （ByVal lpClassName 作为字符串， ByVal lpWindowName 作为字符串） 作为 LongPtr
#Else
声明函数 GetPixel Lib “gdi32” （ByVal hdc As Long， ByVal x As Long， ByVal y As Long） As Long
声明函数 GetDC Lib “user32” （ByVal hwnd As Long） As Long
声明函数 ReleaseDC Lib “user32” （ByVal hwnd As Long， ByVal hdc As Long） As Long
声明函数 FindWindow Lib “user32” 别名 “FindWindowA” （ByVal lpClassName As String， ByVal lpWindowName As String） As Long
#End If
Private Type rect
Left As Long
top as long
right as long
bottom As long
end type
sub sampleAtPoint（）
dim hwnd As LongPtr
Dim hdc As LongPtr
Dim color As Long
Dim x As Long
Dim y As Long

'获取CorelDRAW窗口句柄
hwnd = FindWindow（“CorelDRAW”， vbNullString）

'设置吸颜色的坐标
Dim CDRApp As Object
Set cdrApp = CreateObject（“CorelDRAW.Application”）
将 cdrDoc 调暗为对象
集 cdrDoc = cdrApp.ActiveDocument
将形状调暗为形状
Set shape = cdrDoc.ActiveLayer.Shapes（1）

'检查形状是否存在
如果shape Is Nothing Then
MsgBox “找不到名为S1的形状。请确保S1形状存在。“
Exit Sub
End If

'形状的位置
Dim Left As Double
Dim Top As Double
Dim Right As Double
Dim Bottom As Double
x = shape.位置X
y = 形状。位置 Y
左 = 形状。LeftX
顶部 = 形状。TopY
Right = 形状。RightX
底部 = 形状。BottomY


'获取屏幕设备上下文句柄
hdc = GetDC（hwnd）

'获取指定坐标处色值
color = GetPixel（hdc， x， y）

'释放幕设备上下文句柄
ReleaseDC hwnd， hdc

'在消息框中显示吸取的颜色值
MsgBox “坐标 （” & x & “， ” & y & “） 的颜色为：” & Hex（color）
MsgBox Hex（color）
'填充状


'检查CorelDRAW应用程序是否处于活动状态
如果 cdrApp 什么都不是，那么
MsgBox “没有找到打开的CorelDRAW实例。请确保CorelDRAW处于活状态。“
Exit Sub
End If

'获取当前活动页面
Dim cdrPage As Object
Set cdrPage = cdrApp.ActivePage

'查是否有打开的页面
If cdrPage Is Nothing Then
MsgBox ”当前没有打开的页面。请打开一个页面。“
Exit Sub
End If

'创建长方形形状
'Dim cdrShape As Object
'Set cdrShape = cdrPage.ActiveLayer.CreateRectangle（0， 0， 6， 6）

'设置形状的填充颜色为从屏幕捕的颜色
Dim hexColor As String
hexColor = color

red = Val（”&H“ & Mid（hexColor， 1， 2））
green = Val（”&H“ & Mid（hexColor， 3， 2））
blue = Val（”&H“ & Mid（hexColor， 5， 2））
'应用填充颜色
shape.Fill.UniformColor.RGBAssign red， green， blue
'cdrShape.Fill.UniformColor.RGB = RGB（color）

'cdrShape.Fill.UniformColor.RGBAssign Hex（color）

'显示结果
cdrApp.Visible = True

'清理对象
Set cdrShape = Nothing
Set cdrPage = Nothing
Set cdrApp = Nothing
End Sub
吸管吸不到需要的颜色。
猜是吸管座标和形状座标不统一，出现位置偏差。

那不就

保存未命名 -1.rar (1.12 MB)

2024-6-11 20:05 上传

点击文件名下载附件

保存未命名 p.rar (1.24 MB)

2024-6-11 20:05 上传

点击文件名下载附件

刚才附件没看到，添加。

benleijian

感谢分享，不过好像高版本的应该都可以用ctrl+shift+E吸颜色填充，不需要额外用宏，x4之类的低版本倒是需要。倒是可以把这个宏快捷键设为ctrl+shift+E和高版本统一。

benleijian

修复了一下你的代码，勉强可以开始吸颜色了，只能吸x4软件和任务栏上的，全部版本吸纯黄色都会不正确，x4额外品红吸不准，免费开源，要的赶紧了。
设置个快捷键，然后鼠标移到要吸的地方按一下，只能RGB。

那不就

benleijian 发表于 2024-6-12 17:33
修复了一下你的代码，勉强可以开始吸颜色了，只能吸x4软件和任务栏上的，全部版本吸纯黄色都会不正确，x4额 ...

我的原文件有很多没有填充的形状，想每个形状都填充它下层对应的形状中心的图片颜色，所以用到VBA。

那不就

benleijian 发表于 2024-6-12 17:33
修复了一下你的代码，勉强可以开始吸颜色了，只能吸x4软件和任务栏上的，全部版本吸纯黄色都会不正确，x4额 ...

并且是64位，32位运行错误。

红动中国

吸色每次都是按快捷键直接点，一般也不会有那么多的颜色会换色，刚试 了下X4  32精简版好像用不了

麦克雷特鑫

这个软件吸取颜色然后填充都要用到VBA

那不就

Option Explicit
Dim mousestep As POINTAPI
Dim moubegin As POINTAPI
    '获得当前光标的坐标。
    'GetCursorPos moubegin
   ' mousestep = moubegin
   '鼠标移到 SetCursorPos moubegin.X, moubegin.Y
'====================================================
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 SetDIBits Lib "gdi32" (ByVal HDC 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 Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
'左键单击
'====================================================
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long '获取句柄
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long '获取图片数据
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal HDC As Long) As Long '释放DC
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 DeleteDC Lib "gdi32" (ByVal HDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal HDC As Long, ByVal hObject As Long) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Dim intX As Long
Dim intY As Long
'颜色表
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
'图片文件头
Dim BI As BITMAPINFO
Dim BI1 As BITMAPINFO
Dim PP As New Form1

'在图片1中查找图片2，是否找出全部
Public Function FindPic(Left As Long, Top As Long, Right As Long, Bottom As Long, fileurl As String)
Dim P2 As Picture, P2W, P2H, P2Handle
Set P2 = LoadPicture(fileurl)
P2W = P2.Width
P2H = P2.Height
P2Handle = P2.Handle

Dim W As Long, H As Long, I As Long, J As Long
Dim W2 As Long, H2 As Long, I2 As Long, J2 As Long
Dim zPic() As Byte, fPic() As Byte
Dim R As Byte, G As Byte, B As Byte
'1 获得图片2数据
W2 = ScaleX(P2W, vbHimetric, vbPixels)
H2 = ScaleY(P2H, 8, 3)
With BI.bmiHeader
    .biSize = Len(BI.bmiHeader)
    .biWidth = W2
    .biHeight = -H2
    .biBitCount = 32
    .biPlanes = 1
End With
ReDim zPic(3, W2 - 1, H2 - 1)
I = GetDIBits(HDC, P2Handle, 0, H2, zPic(0, 0, 0), BI, 0)
Set P2 = Nothing
'Debug.Print I
'如果在这里处理一下，图像大的话，可能会快一点。
'2 获得图片1数据
W = Right
H = Bottom
With BI1.bmiHeader
    .biSize = Len(BI1.bmiHeader)
    .biWidth = W
    .biHeight = -H
    .biBitCount = 32
    .biPlanes = 1
End With
        For J2 = 0 To H2 - 2 '循环判断小图片
            For I2 = 0 To W2 - 2
                PP.PSet (I2, J2), RGB(zPic(2, I2, J2), zPic(1, I2, J2), zPic(0, I2, J2))
            Next I2
        Next J2
        PP.Refresh
        
ReDim fPic(3, W - 1, H - 1)
     Dim hBMPhDC
     Dim hDCmem As Long
     Dim Pic1Handle As Long
     Dim hBmpPrev As Long
     hBMPhDC = GetDC(0)
     '常规抓图代码，得到一个hBmp：
     hDCmem = CreateCompatibleDC(hBMPhDC)
     Pic1Handle = CreateCompatibleBitmap(hBMPhDC, Right, Bottom)
     hBmpPrev = SelectObject(hDCmem, Pic1Handle)
     BitBlt hDCmem, 0, 0, Right, Bottom, hBMPhDC, Left, Top, SRCCOPY
     'SelectObject hDCmem, hBmpPrev
     DeleteDC hDCmem
I = GetDIBits(hBMPhDC, Pic1Handle, 0, H, fPic(0, 0, 0), BI1, 0)
ReleaseDC 0, hBMPhDC

'Debug.Print I
'分析查找
For J = 0 To H - H2 - 1
VBA.DoEvents
    For I = 0 To W - W2 - 1
        
        For J2 = 0 To H2 - 2 '循环判断小图片
            For I2 = 0 To W2 - 2
               
                If fPic(2, I + I2, J + J2) <> zPic(2, I2, J2) Then GoTo ExitLine: 'R
                If fPic(1, I + I2, J + J2) <> zPic(1, I2, J2) Then GoTo ExitLine: 'G
                If fPic(0, I + I2, J + J2) <> zPic(0, I2, J2) Then GoTo ExitLine: 'B
            Next I2
        Next J2
        'Debug.Print "发现:", I, J
        intX = I
        intY = J
     
ExitLine:
    Next I
Next J
    '获得当前光标的坐标。
    'GetCursorPos moubegin
    'mousestep = moubegin
    '鼠标移到
End Function
Public Function MoveTo(X As Long, Y As Long)
SetCursorPos X, Y
End Function
Private Sub Cmd1_Click()
Dim TimerMsg
Dim sTimer As Single         '''定义操作时间 计时变量
sTimer = Timer               '''记录遍历图片内容的开始时间
FindPic CLng(Text1.Text), CLng(Text2.Text), CLng(Text3.Text), CLng(Text4.Text), Text5.Text
If intX > 0 And intY > 0 Then
    MoveTo intX, intY
    mouse_event &H4 Or &H2, 0, 0, 0, 0 '左键单击
    TimerMsg = "找到坐标: " & intX & "," & intY
        intX = 0
        intY = 0
    Else
    TimerMsg = "沒有找到"
End If
sTimer = Timer - sTimer      '''计时结束,并记录用时长度
TimerMsg = TimerMsg & vbCrLf & " 用时: " & sTimer * 1000 & "毫秒" '''显示异点,和耗时
Label2.Caption = TimerMsg
        
End Sub

Kira

benleijian 发表于 2024-6-12 10:48
感谢分享，不过好像高版本的应该都可以用ctrl+shift+E吸颜色填充，不需要额外用宏，x4之类的低版本倒是需要 ...

哥们，我有ctrl+shift+E如果选择对象上已经填了颜色好像不会替换，会变成另外一种颜色，这是什么原因呢?没填颜色的用ctrl+shift+E就可以直接吸填