圖塊會增加 - VBA/VB/ActiveX/API 编程技术 - AutoCAD论坛 - 明经CAD社区 - 第2页

雪山飞狐_lzh 发表于 2006-4-12 01:21:00

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 发表于 2006-4-12 11:43: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
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 发表于 2006-4-12 22:04:00

管理员，这次确实是好了，没想到要这么长的程式，太感谢你了！
在这里我真正感到了一个真正管理员的作风及为人，以前进的那个论坛太差了
最后我还是得说声谢谢管理员及版主，同时也感谢各位朋友，不过这个问题我
一直不解的是为什么只有管理员和版主在回复，可能是各位朋友觉得我这个问题
太简单了还是怎么回事？

yuangw1234 发表于 2006-4-13 10:34:00

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

mccad 发表于 2006-4-13 11:41:00

1.插入后的图块，如果要删除，就得先删除图面上的块，才能删除块定义。
2.块定义中的对象可以修改的，直接修改就行。就跟修改图面上的对象一样(不同的是不能用选择集)
3.根据你程序只需要这点功能，程序可以简化：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 发表于 2006-4-13 14:36:00

确实是精华，这么简捷的几名话就搞定了，真的很偑服，我这次看明白了
虽然我昨晚也搞定了，但我的程式冗长，以下就是我的程式，就是多了一个
假如有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

页: 1 [2]

明经CAD社区's Archiver