AutoCAD界面移植到VB.net应用程序窗体中

来源：互联网发布：linux classpath 编辑：程序博客网时间：2024/06/06 07:32

最近因为需要将AutoCAD界面移植到VB.net应用程序窗体中，琢磨、搜索了很久，终于搞清楚，贴出来。。。

1.首先涉及两个按钮，第一个是启动CAD进程，第二个是打开图形界面

2.第一个按钮的进程启动事件：

Private Sub txcl_qdcad_ItemClick(ByVal sender As System.Object, ByVal e As DevExpress.XtraBars.ItemClickEventArgs) Handles txcl_qdcad.ItemClick
Dim runThread As Thread
runThread = New Thread(AddressOf qidongcad)

If txcl_qdcad.Caption = "启动AutoCad" Then

ztl_text.Caption = "温馨提示：若长时间无法启动，请线手动打开AutoCAD后重新启动..."
ztl_text.Refresh()
txcl_qdcad.Caption = "中止AutoCad"
runThread.Start()

ElseIf txcl_qdcad.Caption = "中止AutoCad" Then

txcl_qdcad.Caption = "启动AutoCad"
runThread.Abort()
ztl_text.Caption = "中止AutoCad成功"
ztl_text.Refresh()
End If

End Sub

’----线程

Private Sub qidongcad()
'SplashScreenManager.ShowWaitForm()
'SplitContainerControl1.Visible = False
'ChartControl_gxzx.Visible = False
'Dim acadApp As Autodesk.AutoCAD.Interop.AcadApplication
Try

'-------------------------------------------------
'启动CAD

'－－－－－－－－－－－－－－－－－－－－－－－－－－－
Try
acadApp = GetObject(, "AutoCAD.Application")

acadApp.Visible = False
Catch ex As Exception
Try
acadApp = CreateObject("AutoCAD.Application")
Catch dd As Exception
'SplashScreenManager.CloseWaitForm()
MsgBox("无法启动AutoCAD！", vbYes, "标题")
End Try
End Try
txcl_gbtxjm.Enabled = True
txsc_txsc.Enabled = True
txcl_qdcad.Enabled = False
ztl_text.Caption = "启动AutoCad成功"
Catch ex As Exception
txcl_qdcad.Enabled = True
'SplashScreenManager.CloseWaitForm()
MsgBox("未知错误，请尝试再次启动！", vbYes, "标题")
Exit Sub
End Try

'AppActivate(acadApp.Caption) '切换到CAD的界面为主体

End Sub

3.界面开启事件

Private Sub txcl_gbtxjm_ItemClick(ByVal sender As System.Object, ByVal e As DevExpress.XtraBars.ItemClickEventArgs) Handles txcl_gbtxjm.ItemClick
If txcl_gbtxjm.Caption = "打开图形界面" Then
SplashScreenManager.ShowWaitForm()
acadApp = GetObject(, "AutoCAD.Application")
lHwnd = GetParent(GetParent(acadApp.ActiveDocument.HWND)) '获得CAD窗体的句柄
If lHwnd = 0 Then Exit Sub

lState = acadApp.WindowState
acadApp.WindowState = 1 'AcWindowState.acMax '设置ACAD的窗口状态为默认，用于保存窗口位置。

'GetWindowRect(lHwnd, r) '保存窗体原来的位置及大小到变量r

'MsgBox(Me.Left & "," & Me.Right & "," & Me.Top & "," & Me.Bottom)

'SetParent(lHwnd, Me.Handle) '设置CAD窗体的父窗体为当前VB窗框

SetParent(lHwnd, SplitContainerControl1.Panel2.Handle)

'SetWindowPos(lHwnd, 0, 0, 150, Me.Width - 10, Me.Height - 157, 0) '设置CAD窗体的大小及位置
SetWindowPos(lHwnd, 0, 0, 0, SplitContainerControl1.Panel2.Width, SplitContainerControl1.Panel2.Height, 0)
SetIcon()

'隐藏CAD标题栏
L = GetWindowLong(lHwnd, GWL_STYLE)
L = L And Not (WS_CAPTION)
L = SetWindowLong(lHwnd, GWL_STYLE, L)

'隐藏工具栏
HideTool()
txcl_qdcad.Caption = "启动AutoCad"
txcl_gbtxjm.Caption = "关闭图形界面"
txcl_kqgbmlh.Enabled = True
txcl_biaozhu.Enabled = True
ztl_text.Caption = "打开图形界面成功"
SplashScreenManager.CloseWaitForm()
ElseIf txcl_gbtxjm.Caption = "关闭图形界面" Then
If MsgBox("确认关闭图形窗口界面？", vbYesNo, "标题") = vbYes Then
On Error Resume Next
acadApp.Visible = False
If lHwnd = 0 Then Exit Sub
SetParent(lHwnd, 0)
SetWindowPos(lHwnd, 0, r.Left, r.Top, r.Right - r.Left, r.Bottom - r.Top, 0)
acadApp.WindowState = 1 'AcWindowState.acMax

'恢复隐藏的CAD标题栏
L = GetWindowLong(lHwnd, GWL_STYLE)
L = L Or (WS_CAPTION)
L = SetWindowLong(lHwnd, GWL_STYLE, L)
'恢复工具栏
For Each Menugroup In acadApp.MenuGroups
For Each Toolbar In Menugroup.Toolbars
If Toolbar IsNot Nothing Then
For ii = 0 To CadToolsxh - 1
Dim dqstr() As String
dqstr = Split(CadTools(ii), ",")
If Toolbar.Name = dqstr(0) Then
If dqstr(1).ToUpper = "TRUE" Then
Toolbar.Visible = True
Else
Toolbar.Visible = False
End If
Exit For
End If
Next
End If
Next Toolbar
Next Menugroup
acadApp.Quit()
acadApp = Nothing
ChartControl_gxzx.Visible = True
txcl_gbtxjm.Caption = "打开图形界面"
ztl_text.Caption = "关闭图形界面成功"
txcl_gbtxjm.Enabled = False
txsc_txsc.Enabled = False
txcl_qdcad.Enabled = True
txcl_kqgbmlh.Enabled = False
txcl_biaozhu.Enabled = False
End If
End If

End Sub

‘-------------子函数以及定义等

Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Integer, ByVal hWndNewParent As Integer) As Integer
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Integer) As Integer

Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Integer, ByRef lpRect As RECT) As Integer
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Integer, ByVal hwndInsertAfter As Integer, ByVal x As Integer, _
ByVal y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer) As Integer

Private Structure RECT
Dim Left As Integer
Dim Top As Integer
Dim Right As Integer
Dim Bottom As Integer
End Structure

Private lHwnd As Integer '保存ACAD应用程序的窗口句柄

Private lState As Integer '保存ACAD的初始窗口状态

Private r As RECT '保存ACAD的初始窗口位置

Private acadApp As Object 'Autodesk.AutoCAD.Interop.AcadApplication

'下面这段代码用来设置CAD窗体的图标
'------------------------------------------------------------------------------------------------------------------------
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" _
(ByVal hInst As Integer, ByVal lpsz As String, ByVal un1 As Integer, _
ByVal n1 As Integer, ByVal n2 As Integer, ByVal un2 As Integer) As Integer
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal Hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As Object) As Integer
Private Const WM_SETICON = &H80
Private Const IMAGE_ICON = 1
Private Const LR_LOADFROMFILE = &H10
Dim CadTools() As String
Dim CadToolsxh As Integer

Public Sub SetIcon()
Dim hIcon As Integer
'FileName 图标文件, Hwnd ACAD应用程序的句柄
hIcon = LoadImage(0%, "E:\图片\图标\Excel.ico", IMAGE_ICON, 16, 16, LR_LOADFROMFILE)
If hIcon <> 0 Then
Call SendMessage(lHwnd, WM_SETICON, 0, hIcon)
End If
End Sub

'------------------------------------------------------------------------------------------------------

'下面的代码用于隐藏AutoCAD的标题栏
'---------------------------------------------------------------------------------
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Integer, ByVal nIndex As Integer, ByVal dwNewLong As Integer) As Integer
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Integer, ByVal nIndex As Integer) As Integer
Public Const GWL_STYLE = (-16)
Public Const WS_CAPTION = &HC00000
Public L As Integer

Private Sub HideTool() '隐藏/显示CAD工具栏
On Error Resume Next
Dim Menugroup As Object
Dim Toolbar As Object

CadToolsxh = 0
'----------隐藏
ReDim CadTools(1000)
For Each Menugroup In acadApp.MenuGroups
For Each Toolbar In Menugroup.Toolbars
CadTools(CadToolsxh) = Toolbar.Name & "," & Toolbar.Visible.ToString
CadToolsxh = CadToolsxh + 1
Toolbar.Visible = False
Next Toolbar
Next Menugroup

''-----------显示
'For Each Menugroup In acadApp.MenuGroups
' For Each Toolbar In Menugroup.Toolbars
' i = i + 1
' Toolbar.Visible = CadTools(i)
' Next Toolbar
'Next Menugroup

End Sub

最后结果如图所示：

0 0