|
|
楼主 |
发表于 2024-6-10 21:43
来自手机
|
显示全部楼层
本帖最后由 风雨相随3 于 2024-6-11 07:32 编辑
EHGOOD 发表于 2024-6-10 21:01
coreldraw也有VBA接口。
2021版本，这两个版本要用自定义安装才有VBA功能。
#If VBA7 Then
Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function FindWindow Lib "user32" Alias "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")
Dim cdrDoc As Object
Set cdrDoc = cdrApp.ActiveDocument
Dim shape As shape
Set shape = cdrDoc.ActiveLayer.Shapes(1)
'检查形状是否存在
If 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.PositionX
y = shape.PositionY
Left = shape.LeftX
top = shape.TopY
Right = shape.RightX
Bottom = shape.BottomY
'获取屏幕设备上下文句柄
hdc = GetDC(hwnd)
'获取指定坐标处色值
color = GetPixel(hdc, x, y)
'释放幕设备上下文句柄
ReleaseDC hwnd, hdc
'在消息框中显示吸取的颜色值
MsgBox "坐标 (" & x & ", " & y & ") 的颜色为：" & Hex(color)
MsgBox Hex(color)
'填充状
'检查CorelDRAW应用程序是否处于活动状态
If cdrApp Is Nothing Then
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
猜是吸管座标和形状座标不统一，出现位置偏差。
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-6-10 20:04
