vba转换成vlisp

maiqi816

这个是VBA程序 统一改图号的 谁看看能不能改写成VLISP程序

1. Dim Num As Integer
   
2. Dim A() As String
   
3. Sub ChangeTxt()
   
4. 'On Error GoTo errhandle
   
5. Dim Sset As AcadSelectionSet
   
6. Dim Sset1 As AcadSelectionSet
   
7. Dim FilterType(0) As Integer
   
8. Dim FilterData(0) As Variant
   
9. Dim AcadText As AcadText, NewText As AcadText, AcadText1 As AcadText
   
10. Dim Num As Integer
    
11. Dim Delete As Boolean
    
12. Dim First As String, Second As String, Sep As Integer, TempText As String, InsertPoint As Variant, Points(2) As Double, Second1 As String
    
13. Dim I As Integer
    
14. Delete = False
    
15. Num = 0
    
16. 'Do
    
17.     FilterType(0) = 0
    
18.     FilterData(0) = "Text,Mtext"
    
19.     'If Not IsNull(ThisDrawing.SelectionSets.Item("sse1")) Then
    
20.         'Set SSet = ThisDrawing.SelectionSets.Item("sse1")
    
21.         'SSet.Delete
    
22.     'End If
    
23.     'ZoomExtents
    
24. '安全创建选择集
    
25.     Do While ThisDrawing.SelectionSets.Count > 0
    
26.         ThisDrawing.SelectionSets.Item(0).Delete
    
27.     Loop
    
28. '创建选择集
    
29. 
    
30.     Set Sset = ThisDrawing.SelectionSets.Add("sse1")
    
31.     'Set Sset1 = ThisDrawing.SelectionSets.Add("sse2")
    
32.     'Sset1.Select acSelectionSetAll, , , FilterType, FilterData
    
33. '提示用户选择
    
34.     Sset.SelectOnScreen FilterType, FilterData
    
35.     'MsgBox SSet.Count
    
36.    
    
37.     If Sset.Count <> 0 Then
    
38.         For Each AcadText In Sset
    
39.             If InStr(AcadText.TextString, "-----") > 0 Then
    
40.                 'ReDim Preserve A(0 To Num)
    
41.                 InsertPoint = AcadText.InsertionPoint
    
42.                 TempText = AcadText.TextString
    
43.                 Sep = InStr(TempText, "-")
    
44.                 First = Left(TempText, Sep - 1)
    
45.                 TempText = Right(TempText, 2)
    
46.                 Second1 = Left(TempText, 1)
    
47.                 Second = Left(TempText, 1)
    
48.                 Select Case Second
    
49.                     Case 1
    
50.                         Second = "（一）"
    
51.                     Case 2
    
52.                         Second = "（二）"
    
53.                         
    
54.                     Case 3
    
55.                         Second = "（三）"
    
56.                     Case 4
    
57.                         Second = "（四）"
    
58.                     Case 5
    
59.                         Second = "（五）"
    
60.                     Case 6
    
61.                         Second = "（六）"
    
62.                     Case 7
    
63.                         Second = "（七）"
    
64.                     Case 8
    
65.                         Second = "（八）"
    
66.                     Case 9
    
67.                         Second = "（九）"
    
68.                 End Select
    
69.                 Points(0) = InsertPoint(0) + 179.5: Points(1) = InsertPoint(1) - 233.2: Points(2) = InsertPoint(2)
    
70.                 If Len(AcadText.TextString) <> 8 Then
    
71.                     AcadText.TextString = First & "-----" & First & "'" & Second
    
72.                     TempText = "2-" & First & "-" & Second1
    
73.                 Else
    
74.                     TempText = "2-" & First
    
75.                   
    
76.                 End If
    
77.                
    
78.                 Set NewText = ThisDrawing.ModelSpace.AddText(TempText, Points, 3.5)
    
79.                 NewText.StyleName = "ST"
    
80.                 NewText.ScaleFactor = 1
    
81.                 Num = Num + 1
    
82.             End If
    
83.         Next
    
84. 
    
85.     End If
    
86.    
    
87.     MsgBox "共修改了" & Num & "个文字。"
    
88.     Sset.Delete     '及时删除选择集
    
89.     'Sset1.Delete
    
90. 'Loop
    
91. errhandle:
    
92.     If Err.Number <> 0 Then
    
93. 
    
94.         Exit Sub
    
95.     End If
    
96.     '
    
97. 
    
98. End Sub
    

Dim Num As Integer<br /> Dim A() As String<br /> Sub ChangeTxt()<br /> 'On Error GoTo errhandle<br /> Dim Sset As AcadSelectionSet<br /> Dim Sset1 As AcadSelectionSet<br /> Dim FilterType(0) As Integer<br /> Dim FilterData(0) As Variant<br /> Dim AcadText As AcadText, NewText As AcadText, AcadText1 As AcadText<br /> Dim Num As Integer<br /> Dim Delete As Boolean<br /> Dim First As String, Second As String, Sep As Integer, TempText As String, InsertPoint As Variant, Points(2) As Double, Second1 As String<br /> Dim I As Integer<br /> Delete = False<br /> Num = 0<br /> 'Do<br />     FilterType(0) = 0<br />     FilterData(0) = "Text,Mtext"<br />     'If Not IsNull(ThisDrawing.SelectionSets.Item("sse1")) Then<br />         'Set SSet = ThisDrawing.SelectionSets.Item("sse1")<br />         'SSet.Delete<br />     'End If<br />     'ZoomExtents<br /> '安全创建选择集<br />     Do While ThisDrawing.SelectionSets.Count > 0<br />         ThisDrawing.SelectionSets.Item(0).Delete<br />     Loop<br /> '创建选择集<br /> <br />     Set Sset = ThisDrawing.SelectionSets.Add("sse1")<br />     'Set Sset1 = ThisDrawing.SelectionSets.Add("sse2")<br />     'Sset1.Select acSelectionSetAll, , , FilterType, FilterData<br /> '提示用户选择<br />     Sset.SelectOnScreen FilterType, FilterData<br />     'MsgBox SSet.Count<br />     <br />     If Sset.Count <> 0 Then<br />         For Each AcadText In Sset<br />             If InStr(AcadText.TextString, "-----") > 0 Then<br />                 'ReDim Preserve A(0 To Num)<br />                 InsertPoint = AcadText.InsertionPoint<br />                 TempText = AcadText.TextString<br />                 Sep = InStr(TempText, "-")<br />                 First = Left(TempText, Sep - 1)<br />                 TempText = Right(TempText, 2)<br />                 Second1 = Left(TempText, 1)<br />                 Second = Left(TempText, 1)<br />                 Select Case Second<br />                     Case 1<br />                         Second = "（一）"<br />                     Case 2<br />                         Second = "（二）"<br />                         <br />                     Case 3<br />                         Second = "（三）"<br />                     Case 4<br />                         Second = "（四）"<br />                     Case 5<br />                         Second = "（五）"<br />                     Case 6<br />                         Second = "（六）"<br />                     Case 7<br />                         Second = "（七）"<br />                     Case 8<br />                         Second = "（八）"<br />                     Case 9<br />                         Second = "（九）"<br />                 End Select<br />                 Points(0) = InsertPoint(0) + 179.5: Points(1) = InsertPoint(1) - 233.2: Points(2) = InsertPoint(2)<br />                 If Len(AcadText.TextString) <> 8 Then<br />                     AcadText.TextString = First & "-----" & First & "'" & Second<br />                     TempText = "2-" & First & "-" & Second1<br />                 Else<br />                     TempText = "2-" & First<br />                    <br />                 End If<br />                 <br />                 Set NewText = ThisDrawing.ModelSpace.AddText(TempText, Points, 3.5)<br />                 NewText.StyleName = "ST"<br />                 NewText.ScaleFactor = 1<br />                 Num = Num + 1<br />             End If<br />         Next<br /> <br />     End If<br />     <br />     MsgBox "共修改了" & Num & "个文字。"<br />     Sset.Delete     '及时删除选择集<br />     'Sset1.Delete<br /> 'Loop<br /> errhandle:<br />     If Err.Number <> 0 Then<br /> <br />         Exit Sub<br />     End If<br />     '<br /> <br /> End Sub<br />

eachy

说说这个程序是改什么的

maiqi816

修改我们勘察剖面图图号的
他这个程序还有点问题 最好也能调整一下
vba 使用起来不方便

maiqi816

我把修改前后图纸和动画都发送上来了

maiqi816

动画上传不了不好意思

Free-Lancer

maiqi816 发表于 2013-6-2 10:44
动画上传不了不好意思

你要把规则说清楚别人才好帮你，看程序很累的

7-1-----7-1 => 7-----7(一)
9-2-----9-2 => 9-----9(二)

上面的程序对以下格式也进行了修改，不知道是不是本意

11-----11  => 11-----11(一)
15-----15  => 15-----15(五)

XDSoft

你还不如直接说你想要做什么，直接给你写LISP。详细的说出要求，贴上图片做说明。

maiqi816

是这个意思 不过右下角还有一个图号的问题7-1-----7-1 => 7-----7(一)
对应图号2-7-1或3-7-1 、7-----7 => 7-----7 对应图号则为2-7或3-7 以此类推
如果右下角的图号能放置在图号下面的格子里 并居中最好！

eachy

maiqi816 发表于 2013-6-2 14:34
是这个意思 不过右下角还有一个图号的问题7-1-----7-1 => 7-----7(一)
对应图号2-7-1或3-7-1 、7-----7 => ...

本程序仅是针对LZ提供样图对特定应用，请酌情下载！
命令：Chgtl
说明：本程序针对的是程序自动生成的图框及文字，在手动增删右下角标文字后可能造成混乱！

游客，本帖隐藏的内容需要积分高于 50 才可浏览，您当前积分为 0

maiqi816

非常好完全达到我预想目的非常感谢

fzcfcm

有没有什么工具直接把VBA转换成LSP的呢？