圖塊會增加

yuangw1234

本人写了如下一个VBA程式，就是将所选物体变成一个螺丝孔，但是出现了下面一些问题

假如先画一个圆，第一次将其变成m8，这一次很理想，而再次将m8变成m10就将不理想了，它生成了一个由m8和m10组成的块,我以为是没有删除以前块的原因，於是加了下面绿色的程式，可是还是没有用，请知道原因的老大多多指教，谢谢

Public Sub tt1()        '以下是变为各种螺丝调用程式
Dim r  As Double
On Error Resume Next
Dim sr As String
Dim zm As String
Dim shuz As Double

sr = InputBox("请输入人要变的东东", "变变", "")
zm = Mid(sr, 1, 1)
shuz = Mid(sr, 2)
If zm = "m" Then
     If shuz = 5 Then
     yj = 4.3
     End If
     If shuz = 6 Then
     yj = 5.2
     End If
     If shuz = 8 Then
     yj = 6.8
     End If
     If shuz = 10 Then
     yj = 8.6
     End If
     If shuz = 12 Then
     yj = 10.5
     End If
     If shuz = 14 Then
     yj = 12.5
     End If
     Call gy1(shuz)
End If

If zm = "u" Then '以下是正面沉头的调用公式
     Call u(shuz)

Else
     Call gy(Val(sr))   '这是变为圆的调用程式
End If
End Sub

Public Sub gy1(ls As Double)
On Error Resume Next
Dim ssetobj1 As AcadSelectionSet      '以下是画螺丝的共用程式
Dim icount1 As Integer
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

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
 
  insertpoint(0) = 0
  insertpoint(1) = 0
  insertpoint(2) = 0
  i = ThisDrawing.Blocks.Count
    While (i > 0)
      If ThisDrawing.Blocks.Item(i - 1).Name = "luosi" Then
             ThisDrawing.Blocks.Item(i - 1).Delete
       End If
       i = i - 1
       Wend

  Set blockobj = ThisDrawing.Blocks.Add(insertpoint, "luosi")
  Set arc1 = blockobj.AddArc(insertpoint, ls / 2, pi, pi / 2)
  Set circ1 = blockobj.AddCircle(insertpoint, yj / 2)

  For i1 = 0 To ssetobj1.Count - 1
      Set selobj1 = ssetobj1.Item(i1)
  If selobj1.ObjectName = "AcDbCircle" Or selobj1.ObjectName = "AcDbCrc" Then

      pt1 = selobj1.Center
  Else

      pt1 = selobj1.InsertionPoint
  End If

Set blockrefobj = ThisDrawing.ModelSpace.InsertBlock(pt1, "luosi", 1#, 1#, 1#, 0)
       selobj1.Delete
   
      Next

End Sub

yuangw1234

这么多朋友看过都没有大师回答，还是请请教一下版主，希望版主能帮我一个忙，在此感谢

mccad

需要保证你所建的图块没有被插入到图面中才能对块进行删除。

如果块删除不了，则会在下次使用时直接往里面添加东西。

你可以在找到块时，不去删除它，而是把它里面的图元都删除掉。然后再加入新的图元。

yuangw1234

版主你好，本人明白了你的意思，操作了一翻，但还是不成功，还是每次都会在上次的块里加东西，不知道是否可以劳驾一下版主在本人上面的程式中改一个地方，并用红色标示一下，多谢你

雪山飞狐_lzh

感觉你的问题最好使用无名块,

yuangw1234

版主你好，无名块也试过，好象没有反应

请问各版主及管理员还有各位朋友是否有好方法，感谢万分

 

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
35. Public Sub Gy1(Ls As Integer, Yj As Double)
36. On Error Resume Next
37. Dim SSetObj1 As AcadSelectionSet      '以下是画螺丝的共用程式
38. Dim I1 As Integer
39. Dim SelObj1 As AcadObject
40. Dim blockObj As AcadBlock
41. Dim InsertPoint(0 To 2) As Double
42. Dim i As Integer
43. Dim BlockRefObj As AcadBlockReference
44. Dim Pt1 As Variant
45. Const PI = 3.141592654
46.     ThisDrawing.SelectionSets("yuan").Delete
47.     Err.Clear
48.     Set SSetObj1 = ThisDrawing.SelectionSets.Add("yuan")
49.     ThisDrawing.Utility.Prompt "please select object"
50.     SSetObj1.SelectOnScreen
51.   
52.     InsertPoint(0) = InsertPoint(1) = InsertPoint(2) = 0
53.    
54.     Set blockObj = ThisDrawing.Blocks("luosi" & Ls)
55.     If Err Then
56.         Err.Clear
57.         Set blockObj = ThisDrawing.Blocks.Add(InsertPoint, "luosi" & Ls)
58.         blockObj.AddArc InsertPoint, Ls / 2, PI, PI / 2
59.         blockObj.AddCircle InsertPoint, Yj / 2
60.     End If
61.   
62.     For I1 = 0 To SSetObj1.Count - 1
63.         Set SelObj1 = SSetObj1.Item(I1)
64.         If SelObj1.ObjectName = "AcDbCircle" Or SelObj1.ObjectName = "AcDbCrc" Then
65.             Pt1 = SelObj1.Center
66.             Set BlockRefObj = ThisDrawing.ModelSpace.InsertBlock(Pt1, "luosi" & Ls, 1#, 1#, 1#, 0)
67.         End If
68.        SelObj1.Delete
69.    
70.       Next
71. End Sub

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 Const PI = 3.141592654     ThisDrawing.SelectionSets("yuan").Delete     Err.Clear     Set SSetObj1 = ThisDrawing.SelectionSets.Add("yuan")     ThisDrawing.Utility.Prompt "please select object"     SSetObj1.SelectOnScreen        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)         If SelObj1.ObjectName = "AcDbCircle" Or SelObj1.ObjectName = "AcDbCrc" Then             Pt1 = SelObj1.Center             Set BlockRefObj = ThisDrawing.ModelSpace.InsertBlock(Pt1, "luosi" & Ls, 1#, 1#, 1#, 0)         End If        SelObj1.Delete           Next End Sub

按照你的情形，需要定义几个型号螺丝的图块，所以用无名块也不好，只用一个块也不好。我是按照你需要多少个型号就定义多少个。每个图块只定义一次就够了，下次用的时间由程序检测是否存在该名称的图块就OK。

yuangw1234

管理员你好：

你的方法我试过了，不知道你调试的是不是可以，我这边调试的结果还是不尽如意，都是第一次变化的时候可以，而第二次将m8变成m10的结果我们的刚好相反，你的是把东西都删完，而我的是多加了一个m10到图块中，结果都不如意，真闷！！，不过还是相当感谢管理员及任何一个帮助我的朋友，希望管理员或版主还可以继续帮助，谢谢！！

mccad

搞不清楚你需要什么样的程序。

我的程序是这样的：
1.出现对话框，用户输入象m8,m10这样的字符。
2.让用户选择图面上的圆。
3.判断图块中是否有指定的图块，如果没有，则建该图块，如果有则跳过。
4.插入指定的图块。

这里，图块有m5,m6,m8,m10,m12,m14等多种，它们之间并不存在任何关系。

我的程序运行并不会因为插入m10时会把原先的m8给删除掉。因为它们之间不存在关系。

可能我还没有理解你需要什么样的程序。

看看我生成的图，有m8,m10和m6三种，其中m8是分两次选择生成的。它们并不相互干涉。

yuangw1234

管理员你太好了，这么快就回了，在这里我真的很感谢你

不过管理员的想法和我的是不太一样，我的想法是，假如第一次是将选中的圆变为m8，而第二次选择的对象不一定是一个圆，有可能是选我刚变过的m8，而管理员的程式在选择刚变过的m8时就将其删除了，没有将m8变成m10了