圖塊會增加

yuangw1234 发表于 2006-4-10 11:50:00

本人写了如下一个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 发表于 2006-4-10 22:33:00

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

mccad 发表于 2006-4-11 06:48:00

需要保证你所建的图块没有被插入到图面中才能对块进行删除。
如果块删除不了，则会在下次使用时直接往里面添加东西。
你可以在找到块时，不去删除它，而是把它里面的图元都删除掉。然后再加入新的图元。

yuangw1234 发表于 2006-4-11 09:06:00

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

雪山飞狐_lzh 发表于 2006-4-11 11:13:00

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

yuangw1234 发表于 2006-4-11 11:46:00

版主你好，无名块也试过，好象没有反应
请问各版主及管理员还有各位朋友是否有好方法，感谢万分

mccad 发表于 2006-4-11 18:35:00

随便改的：
Public Sub tt1()    '以下是变为各种螺丝调用程式
Dim RAs 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 发表于 2006-4-11 22:41:00

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

mccad 发表于 2006-4-11 22:53:00

搞不清楚你需要什么样的程序。
我的程序是这样的： 1.出现对话框，用户输入象m8,m10这样的字符。 2.让用户选择图面上的圆。 3.判断图块中是否有指定的图块，如果没有，则建该图块，如果有则跳过。 4.插入指定的图块。
这里，图块有m5,m6,m8,m10,m12,m14等多种，它们之间并不存在任何关系。
我的程序运行并不会因为插入m10时会把原先的m8给删除掉。因为它们之间不存在关系。
可能我还没有理解你需要什么样的程序。
看看我生成的图，有m8,m10和m6三种，其中m8是分两次选择生成的。它们并不相互干涉。

yuangw1234 发表于 2006-4-11 23:05:00

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

页: [1] 2

明经CAD社区's Archiver

圖塊會增加