请问一下，想给在CAD中画好的封闭图形，填充RGB颜色应该更改哪里。谢谢。
本帖最后由 也许有一天 于 2020-9-14 17:35 编辑Dim AcadDoc As Object
Dim HatchObj As AcadHatch
Dim PatternName As String
Dim PatternType As Long
Dim bAssociativity As Boolean
PatternType = 0
PatternName = "ANGLE"
bAssociativity = True
Set AcadDoc = ThisDrawing
Set HatchObj = AcadDoc.ModelSpace.AddHatch(PatternType, PatternName, bAssociativity, 0)
HatchObj.color = 1 '红色
Dim outerLoop(0 To 0) As AcadEntity
Dim syu(0 To 9) As Double
syu(0) = 0: syu(1) = 0
syu(2) = 200: syu(3) = 0
syu(4) = 200: syu(5) = 200
syu(6) = 0: syu(7) = 200
syu(8) = 0: syu(9) = 0
Set outerLoop(0) = AcadDoc.ModelSpace.AddLightWeightPolyline(syu)
HatchObj.AppendOuterLoop (outerLoop)
HatchObj.Evaluate
AcadDoc.Regen True
也许有一天 发表于 2020-9-15 08:50
麻烦您了，谢谢谢谢。我是17，刚才那个16写错了。
改完了，在4楼 HatchObj.color = 1 '红色
改为
Dim MyColor As New AcadAcCmColor
MyColor.SetRGB 255, 0, 0
HatchObj.TrueColor = MyColor
woaishuijia 发表于 2020-9-14 19:22
HatchObj.color = 1 '红色
改为
麻烦再问一下，需要再添加一句Set MyColor = AcadDoc.ModelSpace.GetInterfaceObject("AutoCAD.AcCmColor.16")吗？？我添加了之后也不可以，不添加也不可以，怎么回事呢？？麻烦您帮忙看看。
‘更改之后的
Dim acadapp As AcadApplication
Dim AcadDoc As AcadDocument
Dim obj_Acad As Object, obj_Doc As Object, obj_ModelSpace As Object
Private Sub Command3_Click()
On Error Resume Next '如果目前系统中已执行autocad，则取得已执行autocad物件
Set acadapp = GetObject(, "AutoCAD.Application.17") '检查AutoCAD是否已经打开
If Err Then '没有打开
Err.Clear '如果目前系统中尚未执行autocad，则建立autocad物件
Set acadapp = CreateObject("AutoCAD.Application.17") '打开CAD
If Err Then
MsgBox "连接错误" '打开失败显示连接错误
End If
End If
acadapp.Visible = True '显示CAD
Set AcadDoc = acadapp.ActiveDocument'使用acaddoc变量引用当前的AutoCAD图形
Dim HatchObj As AcadHatch '定义hatchobj为CAD里面填充对象
Dim PatternName As String 'PatternName图案填充名称
Dim PatternType As Long 'PatternType表示图案填充类型的索引，它有三个可选值，acHatchPatternTypePreDefined用AutoCAD标注图案文件Acad.Pat定义的图案进行填充。acHatchPatternTypeDefined用当前线型定义的填充线填充，acHatchPatternTypeCustomDefined用用户自定义的图案文件进行填充。
Dim bAssociativity As Boolean 'Associativity表示图案填充是否与边界关联，如果为true则填充关联边界，边界改变则填充也改变，如果为false则填充不关联边界
Dim MyColor As AcadAcCmColor
PatternType = 0
PatternName = "ANGLE"
bAssociativity = True
Set AcadDoc = ThisDrawing
Set HatchObj = AcadDoc.ModelSpace.AddHatch(PatternType, PatternName, bAssociativity, 0)
Set MyColor = AcadDoc.ModelSpace.GetInterfaceObject("AutoCAD.AcCmColor.16")
MyColor.SetRGB 80, 100, 244
HatchObj.TrueColor = MyColor
' HatchObj.color = 1
Dim Ld1(0 To 0) As AcadEntity '定义outerLoop为CAD里面的实体
Dim syu(0 To 9) As Double'定义syu为CAD里面轻便多义线通过的点
syu(0) = 0: syu(1) = 0
syu(2) = 800: syu(3) = 0
syu(4) = 800: syu(5) = 200
syu(6) = 0: syu(7) = 200
syu(8) = 0: syu(9) = 0
Set Ld1(0) = AcadDoc.ModelSpace.AddLightWeightPolyline(syu) '将建立的实体赋给outerLoop
HatchObj.AppendOuterLoop (Ld1)
HatchObj.Evaluate
AcadDoc.Regen True
End Sub 本帖最后由 woaishuijia 于 2020-9-15 09:23 编辑
我靠，你这程序里问题太多了，下面是改过的程序
Dim acadapp As AcadApplication
Dim AcadDoc As AcadDocument
Dim obj_Acad As Object, obj_Doc As Object, obj_ModelSpace As Object '这一行声明的变量程序中没有用到，不知是做什么用的。但声明变量时要尽可能声明为需要的类，简单声明为Object后面编程时就没有提示了
Private Sub Command3_Click()
On Error Resume Next '如果目前系统中已执行autocad，则取得已执行autocad物件
Set acadapp = GetObject(, "AutoCAD.Application.24") '检查AutoCAD是否已经打开
If Err Then '没有打开
Err.Clear '如果目前系统中尚未执行autocad，则建立autocad物件
Set acadapp = CreateObject("AutoCAD.Application.17") '打开CAD
If Err Then
MsgBox "连接错误" '打开失败显示连接错误
End If
End If
On Error GoTo 0 '这行是增加的：取消错误陷阱。没有这一行，调试时你后面程序中的错误无法发现
acadapp.Visible = True '显示CAD
Set AcadDoc = acadapp.ActiveDocument'使用acaddoc变量引用当前的AutoCAD图形
Dim HatchObj As AcadHatch '定义hatchobj为CAD里面填充对象
Dim PatternName As String 'PatternName图案填充名称
Dim PatternType As Long 'PatternType表示图案填充类型的索引，它有三个可选值，acHatchPatternTypePreDefined用AutoCAD标注图案文件Acad.Pat定义的图案进行填充。acHatchPatternTypeDefined用当前线型定义的填充线填充，acHatchPatternTypeCustomDefined用用户自定义的图案文件进行填充。
Dim bAssociativity As Boolean 'Associativity表示图案填充是否与边界关联，如果为true则填充关联边界，边界改变则填充也改变，如果为false则填充不关联边界
Dim MyColor As AcadAcCmColor
PatternType = 0
PatternName = "ANGLE"
bAssociativity = True
' Set AcadDoc = ThisDrawing'这一行莫名其妙，前面已经为变量赋值了
Set HatchObj = AcadDoc.ModelSpace.AddHatch(PatternType, PatternName, bAssociativity, 0)
' Set MyColor = AcadDoc.ModelSpace.GetInterfaceObject("AutoCAD.AcCmColor.16")'GetInterfaceObject是AcadApplication对象的方法，不是Block对象的。版本号到底是17还是16？你可以在CAD命令行输入“ACADVER”系统变量，看下自己到底是哪个版本。
Set MyColor = acadapp.GetInterfaceObject("AutoCAD.AcCmColor.17") '这里按你前面的17改了版本号
MyColor.SetRGB 80, 100, 244
HatchObj.TrueColor = MyColor
' HatchObj.color = 1
Dim Ld1(0 To 0) As AcadEntity '定义outerLoop为CAD里面的实体
' Dim syu(0 To 9) As Double'画矩形不需要5个顶点
Dim syu(0 To 7) As Double'定义syu为CAD里面轻便多义线通过的点
syu(0) = 0: syu(1) = 0
syu(2) = 800: syu(3) = 0
syu(4) = 800: syu(5) = 200
syu(6) = 0: syu(7) = 200
' syu(8) = 0: syu(9) = 0
Set Ld1(0) = AcadDoc.ModelSpace.AddLightWeightPolyline(syu)
Ld1(0).Closed = True '这行是增加的，让多段线闭合就可以了，不需要多出一个顶点
HatchObj.AppendOuterLoop (Ld1) '将建立的实体赋给outerLoop
HatchObj.Evaluate
AcadDoc.Regen True
End Sub
woaishuijia 发表于 2020-9-14 23:21
我靠，你这程序里问题太多了，容我给你改过来
麻烦您了，谢谢谢谢。我是17，刚才那个16写错了。 woaishuijia 发表于 2020-9-15 09:28
改完了，在4楼
谢谢谢谢，非常感谢。 woaishuijia 发表于 2020-9-14 17:34
改完了，在4楼
麻烦再问一下，我是新手，关于VB与CAD的联合应用，除了张西晋的《《VisualBasic与AutoCAD二次开发》张晋西》，还有没有什么推荐的书籍，谢谢。 也许有一天 发表于 2020-9-15 10:33
麻烦再问一下，我是新手，关于VB与CAD的联合应用，除了张西晋的《《VisualBasic与AutoCAD二次开发》张晋 ...
这是CAD自带的帮助文件，中文的，记不得是CAD哪个版本的了——好像是2005。我觉得这个比那些教材好
woaishuijia 发表于 2020-9-15 11:04
这是CAD自带的帮助文件，中文的，记不得是CAD哪个版本的了——好像是2005。我觉得这个比那些教材好
谢谢谢谢，非感谢感谢。
页:
[1]
2