批量替换对应文本，如何加入功能“完全匹配”、“指定图层” 大家都来帮帮忙吧

xunzhao123

2. '打开文件
   
3.   Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
   
4. Private Const SW_SHOW = 5
   
5. '-------------------切换线程-------------
   
6. Private Declare Function GetWindowThreadProcessId Lib "user32" _
   
7.     (ByVal hwnd As Long, lpdwProcessId As Long) As Long
   
8. Private Declare Function AttachThreadInput Lib "user32" _
   
9.     (ByVal idAttach As Long, ByVal idAttachTo As Long, ByVal fAttach As Long) As Long
   
10. Private Declare Function GetForegroundWindow Lib "user32" () As Long
    
11. Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
    
12. Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long
    
13. Private Declare Function ShowWindow Lib "user32" _
    
14.     (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    
15. 
    
16. 'Private Const SW_SHOW = 5  '与打开文件里面的重复了，这里取消
    
17. Private Const SW_RESTORE = 9
    
18. '-------------------切换线程-------------
    
19. Sub 批量替换()
    
20. Dim i As Integer
    
21. 
    
22. On Error Resume Next
    
23. 
    
24.   FileCopy ThisDrawing.Path & "\PiLiangTiHuan.dll", "C:\WINDOWS\system32\PiLiangTiHuan.dll"
    
25.   Shell "regsvr32   /s   PiLiangTiHuan.dll"
    
26.   
    
27.    Err.Clear
    
28.    
    
29.    Dim xlApp As Object, xlSheet As Object
    
30.    
    
31.    
    
32.    Set xlApp = GetObject(, "Excel.Application")
    
33.    
    
34.    If Err Then
    
35.      Err.Clear
    
36.     Set xlApp = GetObject(, "ET.Application")
    
37.          
    
38.      End If
    
39.   
    
40.     If Err Then
    
41.        Err.Clear
    
42.      
    
43.       ShellExecute Me.hwnd, "open", ThisDrawing.Path & "\TT_AutoCAD文字自动替代.xls", vbNullString, vbNullString, SW_SHOW
    
44.       GoTo QueDingSheet
    
45.    
    
46.     End If
    
47.    
    
48.     If xlApp.Workbooks.Count > 0 Then
    
49.     For i = 1 To xlApp.Workbooks.Count
    
50.         
    
51.         
    
52.         If InStr(xlApp.Workbooks(i).Name, "TT_AutoCAD文字自动替代") > 0 Then
    
53.           Set xlSheet = xlApp.Workbooks(i).ActiveSheet
    
54.           GoTo QueDingSheet
    
55.          
    
56.         End If
    
57.      Next
    
58.    
    
59.     End If
    
60.    
    
61.     Err.Clear
    
62.      
    
63.     ShellExecute Me.hwnd, "open", ThisDrawing.Path & "\TT_AutoCAD文字自动替代.xls", vbNullString, vbNullString, SW_SHOW
    
64.    
    
65.      
    
66. QueDingSheet:
    
67.    
    
68.    
    
69.    
    
70.     ForceForegroundWindow Application.hwnd
    
71.    
    
72.    Dim objForm As Object      ' New PiLiangTiHuan.TiHuan
    
73.    
    
74.    Set objForm = CreateObject("PiLiangTiHuan.TiHuan")
    
75.     Set objForm.Application = Application
    
76.    
    
77.     DoEvents
    
78.    
    
79.     objForm.ShowFormMain
    
80.    
    
81.   Err.Clear
    
82.   
    
83. 
    
84. End Sub
    
85. 
    
86. Private Sub AcadDocument_Activate()
    
87.   On Error Resume Next
    
88. FileCopy ThisDrawing.Path & "\PiLiangTiHuan.dll", "C:\WINDOWS\system32\PiLiangTiHuan.dll"
    
89.   Shell "regsvr32   /s   PiLiangTiHuan.dll"
    
90.   
    
91.    Err.Clear
    
92. 
    
93.   批量替换
    
94. End Sub
    
95. Public Function ForceForegroundWindow(ByVal hwnd As Long) As Boolean
    
96.    Dim ThreadID1 As Long    ' 线程ID
    
97.    Dim ThreadID2 As Long    ' 线程ID
    
98.    Dim nRet As Long
    
99.    
    
100.    ' 如果指定的窗体已经在前台，不做任何操作
     
101.    If hwnd = GetForegroundWindow() Then
     
102.       ForceForegroundWindow = True
     
103.    Else
     
104.       ' 首先获得指定窗体相关的线程和当前前台窗口所在的线程
     
105.       ThreadID1 = GetWindowThreadProcessId(GetForegroundWindow, ByVal 0&)
     
106.       ThreadID2 = GetWindowThreadProcessId(hwnd, ByVal 0&)
     
107.       
     
108.       ' 通过共享输入状态，两个线程分享当前窗口
     
109.       If ThreadID1 <> ThreadID2 Then
     
110.          Call AttachThreadInput(ThreadID1, ThreadID2, True)
     
111.          nRet = SetForegroundWindow(hwnd)
     
112.          Call AttachThreadInput(ThreadID1, ThreadID2, False)
     
113.       Else
     
114.          nRet = SetForegroundWindow(hwnd)
     
115.       End If
     
116.       
     
117.       ' 恢复和重画
     
118.       If IsIconic(hwnd) Then
     
119.          Call ShowWindow(hwnd, SW_RESTORE)
     
120.       Else
     
121.          Call ShowWindow(hwnd, SW_SHOW)
     
122.       End If
     
123.       
     
124.       ' 精确地返回函数执行结果
     
125.       ForceForegroundWindow = CBool(nRet)
     
126.    End If
     
127. End Function
     
128. 
     
129. 
     
130. 
     
131. 
     
132. 'Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
     
133.   
     
134. '  On Error GoTo errhand
     
135.   
     
136. 'If CommandName = "VBALOAD" Or CommandName = "VBAMAN" Or CommandName = "APPLOAD" Or CommandName = "COMMANDLINE" Then
     
137. 
     
138. '   Dim objForm As New PiLiangTiHuan.TiHuan
     
139. '   Set objForm.Application = Application
     
140. '   objForm.ShowFormMain
     
141. 'End If
     
142. 
     
143. 'errhand:
     
144. 'If Err.Number = 0 Then
     
145. 
     
146. ' Else
     
147.   
     
148.   '  MsgBox Err.Description & Err.Number
     
149.    
     
150.   '  Err.Clear
     
151.    
     
152. 'End If
     
153. 
     
154. 
     
155. 
     
156. 'End Sub
     
157. Private Sub AcadDocument_BeginDoubleClick(ByVal PickPoint As Variant)
     
158.   批量替换
     
159. End Sub
     
160. 
     

'打开文件<br />   Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long<br /> Private Const SW_SHOW = 5<br /> '-------------------切换线程-------------<br /> Private Declare Function GetWindowThreadProcessId Lib "user32" _<br />     (ByVal hwnd As Long, lpdwProcessId As Long) As Long<br /> Private Declare Function AttachThreadInput Lib "user32" _<br />     (ByVal idAttach As Long, ByVal idAttachTo As Long, ByVal fAttach As Long) As Long<br /> Private Declare Function GetForegroundWindow Lib "user32" () As Long<br /> Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long<br /> Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long<br /> Private Declare Function ShowWindow Lib "user32" _<br />     (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long<br /> <br /> 'Private Const SW_SHOW = 5  '与打开文件里面的重复了，这里取消<br /> Private Const SW_RESTORE = 9<br /> '-------------------切换线程-------------<br /> Sub 批量替换()<br /> Dim i As Integer<br /> <br /> On Error Resume Next<br /> <br />   FileCopy ThisDrawing.Path & "\PiLiangTiHuan.dll", "C:\WINDOWS\system32\PiLiangTiHuan.dll"<br />   Shell "regsvr32   /s   PiLiangTiHuan.dll"<br />   <br />    Err.Clear<br />    <br />    Dim xlApp As Object, xlSheet As Object<br />    <br />    <br />    Set xlApp = GetObject(, "Excel.Application")<br />    <br />    If Err Then<br />      Err.Clear<br />     Set xlApp = GetObject(, "ET.Application")<br />           <br />      End If<br />   <br />     If Err Then<br />        Err.Clear<br />      <br />       ShellExecute Me.hwnd, "open", ThisDrawing.Path & "\TT_AutoCAD文字自动替代.xls", vbNullString, vbNullString, SW_SHOW<br />       GoTo QueDingSheet<br />     <br />     End If<br />     <br />     If xlApp.Workbooks.Count > 0 Then<br />     For i = 1 To xlApp.Workbooks.Count<br />         <br />         <br />         If InStr(xlApp.Workbooks(i).Name, "TT_AutoCAD文字自动替代") > 0 Then<br />           Set xlSheet = xlApp.Workbooks(i).ActiveSheet<br />           GoTo QueDingSheet<br />           <br />         End If<br />      Next<br />     <br />     End If<br />     <br />     Err.Clear<br />      <br />     ShellExecute Me.hwnd, "open", ThisDrawing.Path & "\TT_AutoCAD文字自动替代.xls", vbNullString, vbNullString, SW_SHOW<br />     <br />      <br /> QueDingSheet:<br />     <br />    <br />    <br />     ForceForegroundWindow Application.hwnd<br />     <br />    Dim objForm As Object      ' New PiLiangTiHuan.TiHuan<br />    <br />    Set objForm = CreateObject("PiLiangTiHuan.TiHuan")<br />     Set objForm.Application = Application<br />     <br />     DoEvents<br />     <br />     objForm.ShowFormMain<br />    <br />   Err.Clear<br />   <br /> <br /> End Sub<br /> <br /> Private Sub AcadDocument_Activate()<br />   On Error Resume Next<br /> FileCopy ThisDrawing.Path & "\PiLiangTiHuan.dll", "C:\WINDOWS\system32\PiLiangTiHuan.dll"<br />   Shell "regsvr32   /s   PiLiangTiHuan.dll"<br />   <br />    Err.Clear<br /> <br />   批量替换<br /> End Sub<br /> Public Function ForceForegroundWindow(ByVal hwnd As Long) As Boolean<br />    Dim ThreadID1 As Long    ' 线程ID<br />    Dim ThreadID2 As Long    ' 线程ID<br />    Dim nRet As Long<br />    <br />    ' 如果指定的窗体已经在前台，不做任何操作<br />    If hwnd = GetForegroundWindow() Then<br />       ForceForegroundWindow = True<br />    Else<br />       ' 首先获得指定窗体相关的线程和当前前台窗口所在的线程<br />       ThreadID1 = GetWindowThreadProcessId(GetForegroundWindow, ByVal 0&)<br />       ThreadID2 = GetWindowThreadProcessId(hwnd, ByVal 0&)<br />       <br />       ' 通过共享输入状态，两个线程分享当前窗口<br />       If ThreadID1 <> ThreadID2 Then<br />          Call AttachThreadInput(ThreadID1, ThreadID2, True)<br />          nRet = SetForegroundWindow(hwnd)<br />          Call AttachThreadInput(ThreadID1, ThreadID2, False)<br />       Else<br />          nRet = SetForegroundWindow(hwnd)<br />       End If<br />       <br />       ' 恢复和重画<br />       If IsIconic(hwnd) Then<br />          Call ShowWindow(hwnd, SW_RESTORE)<br />       Else<br />          Call ShowWindow(hwnd, SW_SHOW)<br />       End If<br />       <br />       ' 精确地返回函数执行结果<br />       ForceForegroundWindow = CBool(nRet)<br />    End If<br /> End Function<br /> <br /> <br /> <br /> <br /> 'Private Sub AcadDocument_EndCommand(ByVal CommandName As String)<br />   <br /> '  On Error GoTo errhand<br />   <br /> 'If CommandName = "VBALOAD" Or CommandName = "VBAMAN" Or CommandName = "APPLOAD" Or CommandName = "COMMANDLINE" Then<br /> <br /> '   Dim objForm As New PiLiangTiHuan.TiHuan<br /> '   Set objForm.Application = Application<br /> '   objForm.ShowFormMain<br /> 'End If<br /> <br /> 'errhand:<br /> 'If Err.Number = 0 Then<br /> <br /> ' Else<br />   <br />   '  MsgBox Err.Description & Err.Number<br />     <br />   '  Err.Clear<br />     <br /> 'End If<br /> <br /> <br /> <br /> 'End Sub<br /> Private Sub AcadDocument_BeginDoubleClick(ByVal PickPoint As Variant)<br />   批量替换<br /> End Sub<br /> <br />

csharp

高大上程序，牛刀很厉害

newer

这是求助，还是分享？

xunzhao123

newer 发表于 2014-8-19 15:25
这是求助，还是分享？

求助  希望加入“完全匹配”和”指定图层“的过滤条件