标签： 编程

Dim oAutoCAD As Object
Call BindAutoCAD(True)

Dim dStartPoint(0 To 2) As Double
Dim dEndPoint(0 To 2) As Double
Dim dCenterPoint(0 To 2) As Double
Dim sTextString As String
Dim dHeight As Double
Dim dRadius As Double

dStartPoint(0) = 10
dStartPoint(1) = 10
dStartPoint(2) = 0
dEndPoint(0) = 100
dEndPoint(1) = 100
dEndPoint(2) = 0
dCenterPoint(0) = 10
dCenterPoint(1) = 10
dCenterPoint(2) = 0
sTextString = “Hello world!”
dHeight = 6
dRadius = 24

Call DrawLine(dStartPoint, dEndPoint)
Call DrawText(sTextString, dStartPoint, dHeight)
Call DrawCircle(dCenterPoint, dRadius)

Public Sub DrawLine(vStartPoint As Variant, vEndPoint As Variant) ‘绘制直线
Dim oLine As Object
Set oLine = oAutoCAD.ActiveDocument.ModelSpace.AddLine(vStartPoint, vEndPoint)
End Function

Public Sub DrawText(sTextString As String, vStartPoint As Variant, vHeight As Variant) ‘写入文本
Dim oText As Object
Set oText = oAutoCAD.ActiveDocument.ModelSpace.AddText(sTextString, vStartPoint, vHeight)
End Function

Public Sub DrawCircle(vCenterPoint As Variant, vRadius As Variant) ‘绘制圆
Dim oCircle As Object
Set oCircle = oAutoCAD.ActiveDocument.ModelSpace.AddCircle(vCenterPoint, vRadius)
End Function

Dim oAutoCAD As Object
Call BindAutoCAD(True)

Dim sLayerName As String
Dim iColor As Integer
Dim sTextStyle As String
Dim iMode As Integer

sLayerName = “平面”
iColor = 1 ‘Red
sTextStyle = “汉字”
iMode = 519 ‘端点 1 + 中点 2 + 圆心 4 + 最近点 512

Call AddLayer(sLayerName, iColor)
Call AddTextStyle(sTextStyleName)
Call SetOSMode(iMode)

Public Sub AddLayer(sLayerName As String, iColor As Integer) ‘增加图层
Dim oLayer As Object
Set oLayer = oAutoCAD.ActiveDocument.Layers.Add(sLayerName)
oLayer.Color = iColor
oAutoCAD.ActiveDocument.ActiveLayer = oLayer
End Function

Public Sub AddTextStyle(sTextStyleName As String) ‘添加或修改字体
Dim oTextStyle As Object
Set oTextStyle = oAutoCAD.ActiveDocument.TextStyles.Add(sTextStyleName)
oTextStyle.BigFontFile = “hztxt.shx”
oTextStyle.FontFile = “romans.shx”
oTextStyle.Height = 8
oTextStyle.Width = 0.6
oAutoCAD.ActiveDocument.ActiveTextStyle = oTextStyle
End Function

Public Sub SetOSMode(ByVal iMode As Integer) ‘设置对象捕捉模式
oDraw.SetVariable “OSMODE”, iMode
‘使用以下位码设置“对象捕捉”的模式(OSNAP mode)：
‘0 NON (无)
‘1 END（端点）
‘2 MID（中点）
‘4 CEN (圆心)
‘8 NOD (节点)
’16 QUA (象限点)
’32 INT（交点）
’64 INS (插入点)
‘128 PER (垂足)
‘256 Tan (切点)
‘512 NEA (最近点)
‘1024 QUI (快速)
‘2048 App (外观交点)
‘4096 EXT (尺寸线)
‘8192 PAR (平行)
‘要指定多个对象捕捉方式，请输入各个位码值之和。
End Sub

‘绑定 AutoCAD
Dim oAutoCAD As Object ‘AutoCAD Application 本身
Call BindAutoCAD(True)
Dim oDraw As Object ‘AutoCAD 多文档之一

‘打开并绑定文件 D:/Test.dwg
Set oDraw = oAutoCAD.Application.Documents.Open(“D:/Test.dwg”)

‘绑定已经打开文件 Demo.dwg
Set oDraw = oAutoCAD.Documents.Item(“Demo.dwg”)

‘新建文件并绑定
Set oDraw = oAutoCAD.Documents.Add

‘绑定已经打开的当前文件
Set oDraw = oAutoCAD.ActiveDocument

‘另存文件并指定格式
oDraw.SaveAs “D:/TestBack.dwg”, 12 ’12 为 AutoCAD 2000 DWG (*.dwg) 格式

‘退出 AutoCAD 并释放资源
oAutoCAD.Quit
Set oAutoCAD = Nothing
Set oDraw = Nothing

模块 BindWord 后期绑定 WPS Word 对象，调用方法如下：

Dim sProg As String
sProg = “kwps” ‘WPS 2013 之前版本为 wps
Dim oWord As Object
Call BindWord(True)

Public Sub BindWord(ByVal bVisible As Boolean)
If Not oWord Is Nothing Then Exit Sub
On Error Resume Next
Set oWord = GetObject(, sProg & “.Application”)
If Err.Number <> 0 Then ‘没有打开
Err.Clear
Set oWord = CreateObject(sProg & “.application”)
If Err.Number <> 0 Then ‘没有正确安装
Err.Clear
Exit Sub
End If
oWord.Visible = bVisible
End If
On Error GoTo 0
End Sub

模块 BindExcel 后期绑定 WPS Excel 对象，调用方法如下：

Dim sProg As String
sProg = “ket” ‘WPS 2013 之前版本为 et
Dim oExcel As Object
Call BindExcel(True)

Public Sub BindExcel(ByVal bVisible As Boolean)
If Not oExcel Is Nothing Then Exit Sub
On Error Resume Next
Set oExcel = GetObject(, sProg & “.Application”)
If Err.Number <> 0 Then ‘没有打开
Err.Clear
Set oExcel = CreateObject(sProg & “.application”)
If Err.Number <> 0 Then ‘没有正确安装
Err.Clear
Exit Sub
End If
oExcel.Visible = bVisible
End If
On Error GoTo 0
End Sub