ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 283|回复: 13

[求助] 歪贴求助

[复制链接]

TA的精华主题

TA的得分主题

发表于 2024-6-10 20:04 | 显示全部楼层 |阅读模式
本帖最后由 风雨相随3 于 2024-6-10 20:06 编辑

保存未命名 p.rar (1.24 MB, 下载次数: 8) 歪贴求助?寻!!!! 保存未命名 -1.rar (1.12 MB, 下载次数: 5)

TA的精华主题

TA的得分主题

发表于 2024-6-10 20:24 | 显示全部楼层
cdr是什么文件格式啊。不懂问一下。

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-6-10 20:52 | 显示全部楼层
ykcbf1100 发表于 2024-6-10 20:24
cdr是什么文件格式啊。不懂问一下。

coreldraw谢谢老师。

TA的精华主题

TA的得分主题

发表于 2024-6-10 20:53 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助

这个真不会。

TA的精华主题

TA的得分主题

发表于 2024-6-10 20:57 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
请问发一个绘图文件到办公软件的VBA板块区域,是想干什么???

TA的精华主题

TA的得分主题

发表于 2024-6-10 21:00 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
电脑上只有这俩低版本,打开看不到内容。 image.png

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2024-6-10 21:01 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
ww87725244 发表于 2024-6-10 20:57
请问发一个绘图文件到办公软件的VBA板块区域,是想干什么???

coreldraw也有VBA接口。

TA的精华主题

TA的得分主题

 楼主| 发表于 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

猜是吸管座标和形状座标不统一,出现位置偏差。

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-6-11 07:33 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
ww87725244 发表于 2024-6-10 20:57
请问发一个绘图文件到办公软件的VBA板块区域,是想干什么???

这也是VBA啊!

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-6-11 07:35 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-6-16 05:17 , Processed in 1.064119 second(s), 24 queries , Gzip On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表