请问一下，想给在CAD中画好的封闭图形，填充RGB颜色应该更改哪里。谢谢。

也许有一天

   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

woaishuijia

也许有一天 发表于 2020-9-15 08:50
麻烦您了，谢谢谢谢。我是17，刚才那个16写错了。

改完了，在4楼

woaishuijia

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

我靠，你这程序里问题太多了，下面是改过的程序

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二次开发》张晋西》，还有没有什么推荐的书籍，谢谢。

woaishuijia

也许有一天 发表于 2020-9-15 10:33
麻烦再问一下，我是新手，关于VB与CAD的联合应用，除了张西晋的《《VisualBasic与AutoCAD二次开发》张晋 ...

这是CAD自带的帮助文件，中文的，记不得是CAD哪个版本的了——好像是2005。我觉得这个比那些教材好

也许有一天

woaishuijia 发表于 2020-9-15 11:04
这是CAD自带的帮助文件，中文的，记不得是CAD哪个版本的了——好像是2005。我觉得这个比那些教材好

谢谢谢谢，非感谢感谢。