replace.frm

在cad文件*.dwg 中替换字符串

VERSION 5.00
Begin VB.Form FrmReplace 
   Caption         =   "Form1"
   ClientHeight    =   2496
   ClientLeft      =   48
   ClientTop       =   336
   ClientWidth     =   3744
   LinkTopic       =   "Form1"
   ScaleHeight     =   2496
   ScaleWidth      =   3744
   StartUpPosition =   3  '窗口缺省
End
Attribute VB_Name = "FrmReplace"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
      Const PI = 3.1415926
      Const A = 0
      Const B = 1
      Const C = 2
      Const d = 3
      
        
      Public Acadapp As Object      '建立Application对象
      Public Acaddoc As Object      '建立Document对象
      Public Mospace As Object      '建立Model Space 对象
      Public Acadutil As Object
      Public AcadLayer As Object
      Public SelectObj As Object
      Public TextLayer As String
Public Sub Init()


      
      
      On Error Resume Next
      Set Acadapp = GetObject(, "AutoCAD.Application")
      'Set Acadapp = GetObject(, "autocad.application")   '若AutoCad已启动 , 则直接得到
      If Err Then
        Err.Clear
        'Set Acadapp = CreateObject("autocad.application")   '若AutoCad未启动，则运行它
        Set Acadapp = CreateObject("AutoCAD.Application")
        
        If Err Then
          MsgBox Err.Description
          Exit Sub
        End If
      End If
      Acadapp.Visible = True  '使AutoCad可见
      Set Acaddoc = Acadapp.ActiveDocument   '设acaddoc为当前                                   图形文件
      Set Mospace = Acaddoc.ModelSpace  '设mospace为当前图形
      Set Acadutil = Acaddoc.Utility
      
      
      ' Application对象是一系列对象的父对象，可以通过它的属性设置来改变AutoCad的窗口设置。请看下面代码:
      'acadapp.Top = 0   '设置AutoCad窗口的位置
      'acadapp.Left = 0
      'acadapp.Height = 800  '调整AutoCad窗口的大小
      'acadapp.Width = 1000
      'acadapp.Caption = "my first application" '设置AutoCad窗口的标题
      Acadapp.Visible = True
      
End Sub
Private Sub Form_Load()

Init
ReplaceText

End
End Sub
Public Sub ReplaceText()
      
      Dim sFindString As String
      Dim sReplaceString As String
      Dim ReplaceKind As Integer
      Dim Ent As Object
      Dim Bound As Integer
      Dim P As Variant
      Dim i As Long
      
      i = 0
      
      If Acaddoc.fullName = "" Then
        'MsgBox "    请打开一个图形文件  再运行程序  "
        SendKeys "{enter}"
        P = Acadutil.GetPoint(, "  请打开一个图形文件  再运行程序")

        End
      End If
        
      ReplaceKind = Acadutil.GetInteger("  修改内容  0  点 . 改为 度 ° \ 1 替换字串  : ")
       
      If ReplaceKind = 1 Then
        sFindString = Acadutil.Getstring(0, "请输入要被替换的字串 :")
        sReplaceString = Acadutil.Getstring(0, "请输入替换后的字串 :")
      Else
        sFindString = "."
        sReplaceString = "%%d"
      End If
       
      Bound = 0
      Bound = Acadutil.GetInteger("  修改范围  0 全图\ 1 部分  : ")
      
      If Bound = 1 Then
        Set SelectObj = Acaddoc.selectionsets.Add("newset")
        SelectObj.selectonscreen
      Else
        Set SelectObj = Mospace
      End If
      
      Dim S1, S2 As String
      Dim p1 As Integer
      Dim EntText As Variant
      Dim EntWidth As Double
      Dim W2 As Double
      Dim W1 As Double
      
        For Each Ent In SelectObj  '采用迭代遍历模型空间中的实体
           If Ent.entityname = "AcDbText" Then
               EntText = Ent.textstring
               P = InStr(EntText, sFindString)
               If P > 0 Then
               S1 = Mid(EntText, 1, P - 1)
               S2 = Mid$(EntText, P + Len(sFindString), _
                       Len(EntText) - (P + Len(sFindString)) + 1)
               
               EntText = S1 & sReplaceString & S2
               
               Ent.textstring = EntText
               End If
           End If
           
           
           If Ent.entityname = "AcDbMText" Then
              
               EntText = Ent.textstring
               EntWidth = Ent.Width
               W1 = Len(EntText)
               P = InStr(EntText, sFindString)
               If P > 0 Then
               S1 = Mid(EntText, 1, P - 1)
               S2 = Mid$(EntText, P + Len(sFindString), _
                       Len(EntText) - (P + Len(sFindString)) + 1)
               
               EntText = S1 & sReplaceString & S2
               
               W2 = Len(EntText)
               
               Ent.textstring = EntText
               Ent.Width = EntWidth * 2 * W2 / W1
               
               End If
           End If
           
           
           
        Next
      

    Acaddoc.regen (1)

    

      
End Sub