圖塊會增加

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

随便改的：

copy


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 · 发表于 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是分两次选择生成的。它们并不相互干涉。

zy14vioikjo.jpg

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

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

圖塊會增加

发表回复

精选推荐