[求助]请斑竹帮我看以下这个问题

gjliang · 发表于 2003-4-17 12:31:00

下面是我利用选择集做的修改字的宽度因子的程序。
Sub ts()
Dim ss As AcadSelectionSet
Set ss = GetSelSet
Dim ent As AcadEntity
Dim ts As String
For Each ent In ss
On Error GoTo errtap
ts = ThisDrawing.Utility.GetString(False, "宽度比例：")
If TypeOf ent Is AcadText Then
ent.ScaleFactor = ts
End If
Next
errtap:
Exit Sub
End Sub
Function GetSelSet() As AcadSelectionSet
Dim ss As AcadSelectionSet
Set ss = ThisDrawing.PickfirstSelectionSet
If ss.Count = 0 Then
Dim ssName As String
ssName = "strSSet"
On Error Resume Next
Set ss = ThisDrawing.SelectionSets(ssName)
If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
ss.Clear
ss.SelectOnScreen
End If
Set GetSelSet = ss
End Function
有两个问题：１.怎样实现在要求输入新的宽度比例因子时，把旧的宽度比例因子参数传到“宽度比例”后面譬如：宽度比例：
２.如何实现一次选取多行文本进行宽度比例因子替换。
谢谢了！期待答复！

mccad · 发表于 2003-4-17 19:32:00

Sub ts()
Dim ss As AcadSelectionSet
Set ss = GetSelSet
Dim ent As AcadEntity
Dim ts As Double
Dim SF As Double
Dim ObjTxt As AcadText
For Each ent In ss
On Error Resume Next
If ent.ObjectName = "AcDbText" Then
      Set ObjTxt = ent
      ObjTxt.Highlight True
      SF = ObjTxt.ScaleFactor
      ts = ThisDrawing.Utility.GetReal("宽度比例：")
      If Err Then
         ts = SF
      End If
      ent.ScaleFactor = ts
End If
Next
End Sub

gjliang · 发表于 2003-4-17 21:48:00

我调试了一下，好象只能一次进行一行，并不能一次把所有选中的各行文字进行一次调整。

mccad · 发表于 2003-4-17 22:05:00

Dim ss As AcadSelectionSet
Set ss = GetSelSet
Dim ent As AcadEntity
Dim ts As Double
Dim SF As Double
Dim tx As String
Dim sa As Boolean
Dim i As Integer
i = 0
sa = False
Dim ObjTxt As AcadText
For Each ent In ss
On Error Resume Next
If ent.ObjectName = "AcDbText" Then
      i = i + 1
      Set ObjTxt = ent
      If sa = False Then
         ObjTxt.Highlight True
         SF = ObjTxt.ScaleFactor
         ts = ThisDrawing.Utility.GetReal("宽度比例：")
         If Err Then
            ts = SF
         End If
         If i = 1 Then
            ThisDrawing.Utility.InitializeUserInput 0, "Y N"
            tx = ThisDrawing.Utility.GetKeyword("是否将所有宽度比例设置为 " & ts & " [是(Y)/否(N)]")
            If Err Or tx = "" Then
                  tx = "Y"
            End If
            If tx = "Y" Then
                  sa = True
            End If
         End If
      End If
      ent.ScaleFactor = ts
End If
Next
End Sub

gjliang · 发表于 2003-4-17 22:18:00

可以一次调整比例因子了，但是要判断是否全部才行，是不是能不经过选择而直接进行一次调整呢？

mccad · 发表于 2003-4-17 22:27:00

Sub ts()
Dim ss As AcadSelectionSet
Set ss = GetSelSet
Dim ent As AcadEntity
Dim ts As Double
Dim SF As Double
Dim i As Integer
i = 0
Dim ObjTxt As AcadText
For Each ent In ss
On Error Resume Next
If ent.ObjectName = "AcDbText" Then
      i = i + 1
      Set ObjTxt = ent
      If i = 1 Then
         ObjTxt.Highlight True
         SF = ObjTxt.ScaleFactor
         ts = ThisDrawing.Utility.GetReal("宽度比例：")
         If Err Then
            ts = SF
         End If
      End If
      ObjTxt.ScaleFactor = ts
End If
Next
End Sub

gjliang · 发表于 2003-4-18 22:23:00

Sub cw()
Dim ss As AcadSelectionSet
Set ss = GetSelSet
Dim ent As AcadEntity
Dim ts As Double
Dim SF As Double
Dim tx As String
Dim i As Integer
i = 0
Dim Obj As AcadEntity
For Each ent In ss
   If TypeOf ent Is AcadEntity Then
      i = i + 1
      Set Obj = ent
            If i = 1 Then
         SF = Obj.Lineweight / 100
         On Error GoTo errtap
         ts = ThisDrawing.Utility.GetReal("新线宽:")
         End If
      ent.Lineweight = ts * 100
   End If
Next
errtap: Exit Sub
End Sub

myfreemind · 发表于 2003-4-18 23:44:00

Sub jczx()
On Error Resume Next
Dim i As Integer
Dim allobj As AcadEntity
Dim spnt As Variant
Dim epnt As Variant
Dim plineobj As AcadLWPolyline
Dim ver(0 To 3) As Double
For i = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(i).Clear
ThisDrawing.SelectionSets.Item(i).Delete
Next
Dim sset As AcadSelectionSet
Set sset = ThisDrawing.SelectionSets.Add("lineset")
sset.SelectOnScreen
If sset.Count = 0 Then Exit Sub
Dim w As String
w = ThisDrawing.Utility.GetString(1, vbCrLf & "请输入宽度:")
For Each allobj In sset
If allobj.ObjectName "AcDbLine" Then
allobj.ConstantWidth = w
End If
If allobj.ObjectName = "AcDbLine" Then
spnt = allobj.StartPoint
epnt = allobj.EndPoint
ver(0) = spnt(0): ver(1) = spnt(1)
ver(2) = epnt(0): ver(3) = epnt(1)Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(ver)plineobj.ConstantWidth = w
allobj.Delete
End If
Next
Exit Sub
end sub

gjliang · 发表于 2003-4-20 09:09:00

不知道都是可以改哪些线宽呢，我的选择对象是acadentity所以只要是可以设置线宽的cad实体都可以设置线宽的。

[求助]请斑竹帮我看以下这个问题

发表回复

精选推荐

浏览过的版块