- UID
- 702335
- 积分
- 65
- 精华
- 贡献
-
- 威望
-
- 活跃度
-
- D豆
-
- 在线时间
- 小时
- 注册时间
- 2013-8-27
- 最后登录
- 1970-1-1
|
马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。
您需要 登录 才可以下载或查看,没有账号?立即注册
×
- '打开文件
- 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
- Private Const SW_SHOW = 5
- '-------------------切换线程-------------
- Private Declare Function GetWindowThreadProcessId Lib "user32" _
- (ByVal hwnd As Long, lpdwProcessId As Long) As Long
- Private Declare Function AttachThreadInput Lib "user32" _
- (ByVal idAttach As Long, ByVal idAttachTo As Long, ByVal fAttach As Long) As Long
- Private Declare Function GetForegroundWindow Lib "user32" () As Long
- Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
- Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long
- Private Declare Function ShowWindow Lib "user32" _
- (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
- 'Private Const SW_SHOW = 5 '与打开文件里面的重复了,这里取消
- Private Const SW_RESTORE = 9
- '-------------------切换线程-------------
- Sub 批量替换()
- Dim i As Integer
-
- On Error Resume Next
-
- FileCopy ThisDrawing.Path & "\PiLiangTiHuan.dll", "C:\WINDOWS\system32\PiLiangTiHuan.dll"
- Shell "regsvr32 /s PiLiangTiHuan.dll"
-
- Err.Clear
-
- Dim xlApp As Object, xlSheet As Object
-
-
- Set xlApp = GetObject(, "Excel.Application")
-
- If Err Then
- Err.Clear
- Set xlApp = GetObject(, "ET.Application")
-
- End If
-
- If Err Then
- Err.Clear
-
- ShellExecute Me.hwnd, "open", ThisDrawing.Path & "\TT_AutoCAD文字自动替代.xls", vbNullString, vbNullString, SW_SHOW
- GoTo QueDingSheet
-
- End If
-
- If xlApp.Workbooks.Count > 0 Then
- For i = 1 To xlApp.Workbooks.Count
-
-
- If InStr(xlApp.Workbooks(i).Name, "TT_AutoCAD文字自动替代") > 0 Then
- Set xlSheet = xlApp.Workbooks(i).ActiveSheet
- GoTo QueDingSheet
-
- End If
- Next
-
- End If
-
- Err.Clear
-
- ShellExecute Me.hwnd, "open", ThisDrawing.Path & "\TT_AutoCAD文字自动替代.xls", vbNullString, vbNullString, SW_SHOW
-
-
- QueDingSheet:
-
-
-
- ForceForegroundWindow Application.hwnd
-
- Dim objForm As Object ' New PiLiangTiHuan.TiHuan
-
- Set objForm = CreateObject("PiLiangTiHuan.TiHuan")
- Set objForm.Application = Application
-
- DoEvents
-
- objForm.ShowFormMain
-
- Err.Clear
-
- End Sub
- Private Sub AcadDocument_Activate()
- On Error Resume Next
- FileCopy ThisDrawing.Path & "\PiLiangTiHuan.dll", "C:\WINDOWS\system32\PiLiangTiHuan.dll"
- Shell "regsvr32 /s PiLiangTiHuan.dll"
-
- Err.Clear
- 批量替换
- End Sub
- Public Function ForceForegroundWindow(ByVal hwnd As Long) As Boolean
- Dim ThreadID1 As Long ' 线程ID
- Dim ThreadID2 As Long ' 线程ID
- Dim nRet As Long
-
- ' 如果指定的窗体已经在前台,不做任何操作
- If hwnd = GetForegroundWindow() Then
- ForceForegroundWindow = True
- Else
- ' 首先获得指定窗体相关的线程和当前前台窗口所在的线程
- ThreadID1 = GetWindowThreadProcessId(GetForegroundWindow, ByVal 0&)
- ThreadID2 = GetWindowThreadProcessId(hwnd, ByVal 0&)
-
- ' 通过共享输入状态,两个线程分享当前窗口
- If ThreadID1 <> ThreadID2 Then
- Call AttachThreadInput(ThreadID1, ThreadID2, True)
- nRet = SetForegroundWindow(hwnd)
- Call AttachThreadInput(ThreadID1, ThreadID2, False)
- Else
- nRet = SetForegroundWindow(hwnd)
- End If
-
- ' 恢复和重画
- If IsIconic(hwnd) Then
- Call ShowWindow(hwnd, SW_RESTORE)
- Else
- Call ShowWindow(hwnd, SW_SHOW)
- End If
-
- ' 精确地返回函数执行结果
- ForceForegroundWindow = CBool(nRet)
- End If
- End Function
- 'Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
-
- ' On Error GoTo errhand
-
- 'If CommandName = "VBALOAD" Or CommandName = "VBAMAN" Or CommandName = "APPLOAD" Or CommandName = "COMMANDLINE" Then
- ' Dim objForm As New PiLiangTiHuan.TiHuan
- ' Set objForm.Application = Application
- ' objForm.ShowFormMain
- 'End If
- 'errhand:
- 'If Err.Number = 0 Then
- ' Else
-
- ' MsgBox Err.Description & Err.Number
-
- ' Err.Clear
-
- 'End If
- 'End Sub
- Private Sub AcadDocument_BeginDoubleClick(ByVal PickPoint As Variant)
- 批量替换
- End Sub
|
|