圖塊會增加

雪山飞狐_lzh

Sub tt()
On Error Resume Next
Dim obj As AcadEntity, pnt
Dim d As Integer
Do
ThisDrawing.Utility.GetEntity obj, pnt
Loop While (obj.ObjectName <> "AcDbCircle" And obj.ObjectName <> "AcDbBlockReference")

If Err Then
Err.Clear
Else

d = ThisDrawing.Utility.GetInteger("输入直径：")
If obj.ObjectName = "AcDbCircle" Then
AddNut d, , obj.Center
Else
AddNut d, obj
End If
End If
End Sub

Sub AddNut(dia As Integer, Optional blkref As AcadBlockReference, Optional insertpnt)
Dim blk As AcadBlock
Dim pnt(2) As Double
If blkref Is Nothing Then
    Set blk = ThisDrawing.Blocks.Add(pnt, "*N")
    Set blkref = ThisDrawing.ModelSpace.InsertBlock(insertpnt, blk.Name, 1, 1, 1, 0)
Else
    Set blk = ThisDrawing.Blocks(blkref.Name)
End If

For Each i In blk
    i.Delete
Next i

'这里向块里加入实体
blk.AddText "M" & dia, pnt, 5#

blkref.Update
End Sub

mccad

理解你的意思，你还需要对原来已经插入的图块进行处理。

2. Public Sub tt1()        '以下是变为各种螺丝调用程式
3. Dim R  As Double
4. On Error Resume Next
5. Dim Sr As String
6. Dim Zm As String
7. Dim Shuz As Integer
8. Dim Yj As Double
9. Sr = InputBox("请输入人要变的东东", "变变", "")
10. Zm = Left(Sr, 1)
11. Shuz = Mid(Sr, 2)
12. Select Case Zm
13.      Case "m"
14.      Select Case Shuz
15.          Case 5
16.              Yj = 4.3
17.          Case 6
18.              Yj = 5.2
19.          Case 8
20.              Yj = 6.8
21.          Case 10
22.              Yj = 8.6
23.          Case 12
24.              Yj = 10.5
25.          Case 14
26.              Yj = 12.5
27.      End Select
28.       Call Gy1(Shuz, Yj)
29.      Case "u"  '以下是正面沉头的调用公式
30.       'Call u(shuz)
31.      Case Else
32.      'Call gy(Val(sr))   '这是变为圆的调用程式
33. End Select
34. End Sub
36. Public Sub Gy1(Ls As Integer, Yj As Double)
37. On Error Resume Next
38. Dim SSetObj1 As AcadSelectionSet      '以下是画螺丝的共用程式
39. Dim I1 As Integer
40. Dim SelObj1 As AcadObject
41. Dim blockObj As AcadBlock
42. Dim InsertPoint(0 To 2) As Double
43. Dim i As Integer
44. Dim BlockRefObj As AcadBlockReference
45. Dim Pt1 As Variant
46. Dim typeArray, dataArray
48. Const PI = 3.141592654
50.     BuildFilter typeArray, dataArray, -4, "<or", 0, "circle,arc", -4, "<and", 0, "insert", 2, "luosi*", -4, "and>", -4, "or>"
51.     Set SSetObj1 = PickFirstSSet("please select object:", typeArray, dataArray)
52.    
53.      InsertPoint(0) = InsertPoint(1) = InsertPoint(2) = 0
54.      
55.      Set blockObj = ThisDrawing.Blocks("luosi" & Ls)
56.      If Err Then
57.          Err.Clear
58.          Set blockObj = ThisDrawing.Blocks.Add(InsertPoint, "luosi" & Ls)
59.          blockObj.AddArc InsertPoint, Ls / 2, PI, PI / 2
60.          blockObj.AddCircle InsertPoint, Yj / 2
61.      End If
62.    
63.      For I1 = 0 To SSetObj1.Count - 1
64.          Set SelObj1 = SSetObj1.Item(I1)
65.          Select Case SelObj1.ObjectName
66.             Case "AcDbCircle", "AcDbCrc"
67.              Pt1 = SelObj1.Center
68.              Set BlockRefObj = ThisDrawing.ModelSpace.InsertBlock(Pt1, "luosi" & Ls, 1#, 1#, 1#, 0)
69.             Case "AcDbBlockReference"
70.             Pt1 = SelObj1.InsertionPoint
71.              Set BlockRefObj = ThisDrawing.ModelSpace.InsertBlock(Pt1, "luosi" & Ls, 1#, 1#, 1#, 0)
72.         End Select
73.         SelObj1.Delete
74.      
75.        Next
76. End Sub
78. Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
79.     Dim fType() As Integer, fData()
80.     Dim index As Long, i As Long
81.    
82.     index = LBound(gCodes) - 1
83.         
84.     For i = LBound(gCodes) To UBound(gCodes) Step 2
85.         index = index + 1
86.         ReDim Preserve fType(0 To index)
87.         ReDim Preserve fData(0 To index)
88.         fType(index) = CInt(gCodes(i))
89.         fData(index) = gCodes(i + 1)
90.     Next
91.     typeArray = fType: dataArray = fData
92. End Sub
94. Function PickFirstSSet(Optional txtTip As String = "", Optional typeArray = -1, Optional dataArray = -1) As AcadSelectionSet
95.     On Error Resume Next
96.     ThisDrawing.SelectionSets("PICKFIRST").Delete
97.     Set PickFirstSSet = ThisDrawing.PickfirstSelectionSet
98.     If PickFirstSSet.Count = 0 Then
99.         If txtTip <> "" Then ThisDrawing.Utility.Prompt txtTip
100.         If IsArray(typeArray) Then
101.             PickFirstSSet.SelectOnScreen typeArray, dataArray
102.         Else
103.             PickFirstSSet.SelectOnScreen
104.         End If
105.     Else
106.         If IsArray(typeArray) Then PickFirstSSet.Select acSelectionSetPrevious, , , typeArray, dataArray
107.     End If
108. End Function

Public Sub tt1()        '以下是变为各种螺丝调用程式 Dim R  As Double On Error Resume Next Dim Sr As String Dim Zm As String Dim Shuz As Integer Dim Yj As Double Sr = InputBox("请输入人要变的东东", "变变", "") Zm = Left(Sr, 1) Shuz = Mid(Sr, 2) Select Case Zm      Case "m"      Select Case Shuz          Case 5              Yj = 4.3          Case 6              Yj = 5.2          Case 8              Yj = 6.8          Case 10              Yj = 8.6          Case 12              Yj = 10.5          Case 14              Yj = 12.5      End Select       Call Gy1(Shuz, Yj)      Case "u"  '以下是正面沉头的调用公式       'Call u(shuz)      Case Else      'Call gy(Val(sr))   '这是变为圆的调用程式 End Select End Sub Public Sub Gy1(Ls As Integer, Yj As Double) On Error Resume Next Dim SSetObj1 As AcadSelectionSet      '以下是画螺丝的共用程式 Dim I1 As Integer Dim SelObj1 As AcadObject Dim blockObj As AcadBlock Dim InsertPoint(0 To 2) As Double Dim i As Integer Dim BlockRefObj As AcadBlockReference Dim Pt1 As Variant Dim typeArray, dataArray Const PI = 3.141592654     BuildFilter typeArray, dataArray, -4, "<or", 0, "circle,arc", -4, "<and", 0, "insert", 2, "luosi*", -4, "and>", -4, "or>"     Set SSetObj1 = PickFirstSSet("please select object:", typeArray, dataArray)          InsertPoint(0) = InsertPoint(1) = InsertPoint(2) = 0            Set blockObj = ThisDrawing.Blocks("luosi" & Ls)      If Err Then          Err.Clear          Set blockObj = ThisDrawing.Blocks.Add(InsertPoint, "luosi" & Ls)          blockObj.AddArc InsertPoint, Ls / 2, PI, PI / 2          blockObj.AddCircle InsertPoint, Yj / 2      End If          For I1 = 0 To SSetObj1.Count - 1          Set SelObj1 = SSetObj1.Item(I1)          Select Case SelObj1.ObjectName             Case "AcDbCircle", "AcDbCrc"              Pt1 = SelObj1.Center              Set BlockRefObj = ThisDrawing.ModelSpace.InsertBlock(Pt1, "luosi" & Ls, 1#, 1#, 1#, 0)             Case "AcDbBlockReference"             Pt1 = SelObj1.InsertionPoint              Set BlockRefObj = ThisDrawing.ModelSpace.InsertBlock(Pt1, "luosi" & Ls, 1#, 1#, 1#, 0)         End Select         SelObj1.Delete              Next End Sub Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())     Dim fType() As Integer, fData()     Dim index As Long, i As Long         index = LBound(gCodes) - 1              For i = LBound(gCodes) To UBound(gCodes) Step 2         index = index + 1         ReDim Preserve fType(0 To index)         ReDim Preserve fData(0 To index)         fType(index) = CInt(gCodes(i))         fData(index) = gCodes(i + 1)     Next     typeArray = fType: dataArray = fData End Sub Function PickFirstSSet(Optional txtTip As String = "", Optional typeArray = -1, Optional dataArray = -1) As AcadSelectionSet     On Error Resume Next     ThisDrawing.SelectionSets("PICKFIRST").Delete     Set PickFirstSSet = ThisDrawing.PickfirstSelectionSet     If PickFirstSSet.Count = 0 Then         If txtTip <> "" Then ThisDrawing.Utility.Prompt txtTip         If IsArray(typeArray) Then             PickFirstSSet.SelectOnScreen typeArray, dataArray         Else             PickFirstSSet.SelectOnScreen         End If     Else         If IsArray(typeArray) Then PickFirstSSet.Select acSelectionSetPrevious, , , typeArray, dataArray     End If End Function

yuangw1234

管理员，这次确实是好了，没想到要这么长的程式，太感谢你了！

在这里我真正感到了一个真正管理员的作风及为人，以前进的那个论坛太差了

最后我还是得说声谢谢管理员及版主，同时也感谢各位朋友，不过这个问题我

一直不解的是为什么只有管理员和版主在回复，可能是各位朋友觉得我这个问题

太简单了还是怎么回事？

yuangw1234

管理员你好，你那个虽然可以解决我的问题，不过我有点不懂，我一直想问管理员一个问题，就是为什么我的程式有这样一个处理 ：就是假如我当前图中有名为"luosi"的块存在，然后就去删除（或炸开），删除后再做一个以"luosi"为名的块为什么会做不起来呢？我现在想到的一点就是：假如当前图中有这样一个名为"luosi"的块存在，我只要把这个块中所含有的东西的一些性质改一下，如m8变成m10,我只要把以前块中的那个圆的半径改成m10的半径，弧也做同样的处理，这种方法应该可行，目前我想请教管理员就是怎么样可以提出块中所拥有的东西，如一个圆，我得到这个圆我再去变这个圆的半径就容易了，希望管理员或版主和各位可以支持，因为这个问题确实困扰我一段时间，多谢大家

 

mccad

1.插入后的图块，如果要删除，就得先删除图面上的块，才能删除块定义。
2.块定义中的对象可以修改的，直接修改就行。就跟修改图面上的对象一样(不同的是不能用选择集)
3.根据你程序只需要这点功能，程序可以简化：

2. Public Sub tt1()        '以下是变为各种螺丝调用程式
3.     On Error Resume Next
4.     Dim Sr As String
5.     Dim Zm As String
6.     Dim Shuz As Integer
7.     Sr = InputBox("请输入人要变的东东", "变变", "")
8.     Zm = Left(Sr, 1)
9.     Shuz = Mid(Sr, 2)
10.     Select Case Zm
11.          Case "m"
12.           Call Gy1(Shuz)
13.          Case "u"  '以下是正面沉头的调用公式
14.           'Call u(shuz)
15.          Case Else
16.          'Call gy(Val(sr))   '这是变为圆的调用程式
17.     End Select
18. End Sub
20. Public Sub Gy1(Ls As Integer)
21.     On Error Resume Next
22.     Dim SSetObj1 As AcadSelectionSet      '以下是画螺丝的共用程式
23.     Dim SelObj1 As AcadEntity
24.     Dim blockObj As AcadBlock
25.     Dim InsertPoint(0 To 2) As Double
26.     Dim i As Integer
27.     Dim Pt1 As Variant
28.      
29.     Const PI = 3.141592654
31.     ThisDrawing.SelectionSets("ss").Delete
32.     Err.Clear
33.     Set SSetObj1 = ThisDrawing.SelectionSets.Add("ss")
34.     ThisDrawing.Utility.Prompt "please select object:"
35.     SSetObj1.SelectOnScreen
36.    
37.     Set blockObj = ThisDrawing.Blocks("luosi" & Ls)
38.     If Err Then
39.         Err.Clear
40.         Set blockObj = ThisDrawing.Blocks.Add(InsertPoint, "luosi" & Ls)
41.         Dim YJ(14) As Double
42.         YJ(5) = 4.3: YJ(6) = 5.2: YJ(8) = 6.8: YJ(10) = 8.6: YJ(12) = 10.5: YJ(14) = 12.5
43.         blockObj.AddArc InsertPoint, Ls / 2, PI, PI / 2
44.         blockObj.AddCircle InsertPoint, YJ(Ls) / 2
45.     End If
46.    
47.     For i = 0 To SSetObj1.Count - 1
48.         Set SelObj1 = SSetObj1.Item(i)
49.         Select Case SelObj1.ObjectName
50.             Case "AcDbCircle", "AcDbCrc"
51.                 ThisDrawing.ModelSpace.InsertBlock SelObj1.Center, "luosi" & Ls, 1#, 1#, 1#, 0
52.                 SelObj1.Delete
53.             Case "AcDbBlockReference"
54.                 SelObj1.Name = "luosi" & Ls
55.                 SelObj1.Update
56.         End Select
57.     Next
58. End Sub

Public Sub tt1()        '以下是变为各种螺丝调用程式     On Error Resume Next     Dim Sr As String     Dim Zm As String     Dim Shuz As Integer     Sr = InputBox("请输入人要变的东东", "变变", "")     Zm = Left(Sr, 1)     Shuz = Mid(Sr, 2)     Select Case Zm          Case "m"           Call Gy1(Shuz)          Case "u"  '以下是正面沉头的调用公式           'Call u(shuz)          Case Else          'Call gy(Val(sr))   '这是变为圆的调用程式     End Select End Sub Public Sub Gy1(Ls As Integer)     On Error Resume Next     Dim SSetObj1 As AcadSelectionSet      '以下是画螺丝的共用程式     Dim SelObj1 As AcadEntity     Dim blockObj As AcadBlock     Dim InsertPoint(0 To 2) As Double     Dim i As Integer     Dim Pt1 As Variant           Const PI = 3.141592654     ThisDrawing.SelectionSets("ss").Delete     Err.Clear     Set SSetObj1 = ThisDrawing.SelectionSets.Add("ss")     ThisDrawing.Utility.Prompt "please select object:"     SSetObj1.SelectOnScreen         Set blockObj = ThisDrawing.Blocks("luosi" & Ls)     If Err Then         Err.Clear         Set blockObj = ThisDrawing.Blocks.Add(InsertPoint, "luosi" & Ls)         Dim YJ(14) As Double         YJ(5) = 4.3: YJ(6) = 5.2: YJ(8) = 6.8: YJ(10) = 8.6: YJ(12) = 10.5: YJ(14) = 12.5         blockObj.AddArc InsertPoint, Ls / 2, PI, PI / 2         blockObj.AddCircle InsertPoint, YJ(Ls) / 2     End If         For i = 0 To SSetObj1.Count - 1         Set SelObj1 = SSetObj1.Item(i)         Select Case SelObj1.ObjectName             Case "AcDbCircle", "AcDbCrc"                 ThisDrawing.ModelSpace.InsertBlock SelObj1.Center, "luosi" & Ls, 1#, 1#, 1#, 0                 SelObj1.Delete             Case "AcDbBlockReference"                 SelObj1.Name = "luosi" & Ls                 SelObj1.Update         End Select     Next End Sub

yuangw1234

确实是精华，这么简捷的几名话就搞定了，真的很偑服，我这次看明白了

虽然我昨晚也搞定了，但我的程式冗长，以下就是我的程式，就是多了一个

假如有100个相同点则以其中一个点为中心变化，还有一个就是不能变的东西作了一个处理,我现在这里编了一些一次性标注整个图面中的圆和块的坐标，还有一些

就是较復杂pwline线的入块画法（冲模中用的），当然还有一些其它的拉圾程式，我的这些程式都好象太长，真想管理员简化一下，不过这次已经够打扰你们了，就先不再打扰了，我的这些程式还是先将就用著，在这里非常感谢你们

Public Sub gy1(ls As Double)
Dim ssetobj1 As AcadSelectionSet      '以下是画螺丝的共用程式
Dim icount1 As Integer
Dim selobj1 As AcadObject
Dim I As Integer
Dim i1 As Integer
Dim i2 As Integer
Dim shuzi As Integer
icount1 = ThisDrawing.SelectionSets.Count
While (icount1 > 0)
    If ThisDrawing.SelectionSets.Item(icount1 - 1).Name = "yuan" Then
    ThisDrawing.SelectionSets.Item(icount1 - 1).Delete
    End If
    icount1 = icount1 - 1
Wend
    Set ssetobj1 = ThisDrawing.SelectionSets.Add("yuan")
    ThisDrawing.Utility.Prompt "please select object"
    ssetobj1.SelectOnScreen
    Const pi = 3.141592654
    I = ThisDrawing.Blocks.Count
While (I > 0)
    If ThisDrawing.Blocks.Item(I - 1).Name = "luosi" Then
    For i2 = 0 To ThisDrawing.Blocks.Item(I - 1).Count - 1
    ThisDrawing.Blocks.Item(I - 1).Item(i2).Radius = yj / 2
    Next
    ThisDrawing.Regen acAllViewports
   
    End If
    I = I - 1
Wend
    insertpoint(0) = 0
    insertpoint(1) = 0
    insertpoint(2) = 0
    Set blockobj = ThisDrawing.Blocks.Add(insertpoint, "luosi")
        Dim ptn(0 To 2) As Variant
        ptn(0) = Null
        ptn(1) = Null
        ptn(2) = Null
    For i1 = 0 To ssetobj1.Count - 1
        Set selobj1 = ssetobj1.Item(i1)
    If selobj1.ObjectName = "AcDbCircle" Or selobj1.ObjectName = "AcDbCrc" Then
        pt1 = selobj1.Center
        ElseIf selobj1.ObjectName = "AcDbBlockReference" Then
        pt1 = selobj1.InsertionPoint
        Else
        shuzi = MsgBox("选择了不可以变的东西", "1")
        If shuzi = 2 Then
        End
        End If
    End If
        If pt1(0) = ptn(0) And pt1(1) = ptn(1) And pt1(2) = ptn(2) Then
        Else
        ptn(0) = pt1(0)
        ptn(1) = pt1(1)
        ptn(2) = pt1(2)
        Set arc1 = blockobj.AddArc(insertpoint, ls / 2, pi, pi / 2)
        arc1.Linetype = "CONTINUOUS"
        Set circ1 = blockobj.AddCircle(insertpoint, yj / 2)
        circ1.Linetype = "CONTINUOUS"
        Set blockrefobj = ThisDrawing.ModelSpace.InsertBlock(pt1, "luosi", 1#, 1#, 1#, 0)
        End If
        selobj1.Delete
   
    Next
       

End Sub