如何修改选择集中对象的属性

291118

我想先将选择集中的对象复制　然后再将其图案名改成别的图案，怎么也试验不成功请高手指点！　谢谢

Dim acadDoc As AcadDocument

Private Sub Command1_Click()

On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application")
If Err Then End
End If
acadApp.Visible = True
Set acadDoc = acadApp.ActiveDocument
Dim ssetObj As AcadSelectionSet

 K = -1
 For i = 0 To acadDoc.SelectionSets.Count - 1
 If acadDoc.SelectionSets.Item(i).Name = "SSET" Then acadDoc.SelectionSets.Item(i).Delete
  Next i
  Set ssetObj = acadDoc.SelectionSets.Add("SSET")

  Dim corner1(0 To 2) As Double
  Dim corner2(0 To 2) As Double
    corner1(0) = 0: corner1(1) = 0: corner1(2) = 0
    corner2(0) = 200: corner2(1) = 200: corner2(2) = 0

    Dim gpCode(0) As Integer
    Dim dataValue(0) As Variant
    gpCode(0) = 0
    dataValue(0) = "HATCH"
   ' gpCode(1) = 2
   ' dataValue(1) = "SOLID"

    Dim groupCode As Variant, dataCode As Variant
    groupCode = gpCode
    dataCode = dataValue
    ssetObj.Select acSelectionSetAll, , , groupCode, dataCode
  For i = 0 To ssetObj.Count - 1
   ssetObj.Item(i).Move corner1, corner2
  Next i

End Sub

雪山飞狐_lzh

复制用Copy函数

291118

经过研究能考贝了，只能改变颜色，但不能修改图案名　代码如下

Dim acadApp As AcadApplication
Dim acadDoc As AcadDocument

Private Sub Command1_Click()

On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application")
If Err Then End
End If
acadApp.Visible = True
Set acadDoc = acadApp.ActiveDocument
Dim ssetObj As AcadSelectionSet
Dim COPYObj As AcadEntity
Dim ss As Object
Dim s1, s2 As AcadHatch
Dim acad_obj As AcadObject

 K = -1
 For i = 0 To acadDoc.SelectionSets.Count - 1
 If acadDoc.SelectionSets.Item(i).Name = "SSET" Then acadDoc.SelectionSets.Item(i).Delete
  Next i
 Set ssetObj = acadDoc.SelectionSets.Add("SSET")

Dim corner1(0 To 2) As Double
  Dim corner2(0 To 2) As Double
    corner1(0) = 0: corner1(1) = 0: corner1(2) = 0
    corner2(0) = 200: corner2(1) = 200: corner2(2) = 0
    Dim gpCode(0) As Integer
    Dim dataValue(0) As Variant
    gpCode(0) = 0
    dataValue(0) = "HATCH"
   ' gpCode(1) = 2
   ' dataValue(1) = "SOLID"

    Dim groupCode As Variant, dataCode As Variant
    groupCode = gpCode
    dataCode = dataValue
     ssetObj.Clear
    ssetObj.Select acSelectionSetAll, , , groupCode, dataCode
 Set s1 = ssetObj.Item(0)
 Set s2 = s1.Copy
 ssetObj.Item(0).Move corner1, corner2
 s1.Color = 2
 s2.Color = 1
 MsgBox s2.PatternName
 s2.PatternName = "asni32" '这儿就出错了　说是只读
 ssetObj.Clear
   

End Sub

wenwengg

'图案名改成别的图案

hatchObj.SetPattern acHatchPatternTypePreDefined, "BRICK"