标签： 编程

Option Explicit
Public Const BUFFER = 256
Public Declare Function GetProfileInt Lib “kernel32” Alias “GetProfileIntA” (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal nDefault As Long) As Long
Public Declare Function GetProfileSection Lib “kernel32” Alias “GetProfileSectionA” (ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Public Declare Function GetProfileString Lib “kernel32” Alias “GetProfileStringA” (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Public Declare Function GetPrivateProfileInt Lib “kernel32” Alias “GetPrivateProfileIntA” (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Public Declare Function GetPrivateProfileSection Lib “kernel32” Alias “GetPrivateProfileSectionA” (ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function GetPrivateProfileString Lib “kernel32” Alias “GetPrivateProfileStringA” (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WriteProfileSection Lib “kernel32” Alias “WriteProfileSectionA” (ByVal lpAppName As String, ByVal lpString As String) As Long
Public Declare Function WriteProfileString Lib “kernel32” Alias “WriteProfileStringA” (ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Long
Public Declare Function WritePrivateProfileSection Lib “kernel32” Alias “WritePrivateProfileSectionA” (ByVal lpAppName As String, ByVal lpString As String, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib “kernel32” Alias “WritePrivateProfileStringA” (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

Public Function WriteIniFile(ByVal sApp As String, ByVal sKey As String, ByVal sData As String, ByVal sIniFile As String) As Long
WriteIniFile = WritePrivateProfileString(sApp, sKey, sData, sIniFile)
End Function

Public Function ReadIniFile(ByVal sApp As String, ByVal sKey As String, ByVal sIniFile As String) As String
Dim sBuffer As String
sBuffer = Space$(BUFFER)
If GetPrivateProfileString(sApp, sKey, “”, sBuffer, BUFFER, sIniFile) > 0 Then
ReadIniFile = GetAPIString(sBuffer)
Else
ReadIniFile = “”
End If
End Function

‘绑定 AutoCAD
Dim I As Integer, J As Integer
Dim oAutoCAD As Object
Call BindAutoCAD(True)

‘打开并绑定文件 D:/Test.dwg
Dim oDraw As Object ‘AutoCAD 多文档之一
Set oDraw = oAutoCAD.Application.Documents.Open(“D:/Test.dwg”)

‘插入表格
Dim oTable As Object
Dim dInsertPoint(2) As Double
dInsertPoint(0) = 12
dInsertPoint(1) = 12
dInsertPoint(2) = 0
Set oTable = oDraw.ModelSpace.AddTable(dInsertPoint, 6, 7, 10, 50) ‘插入点,行列数,单元格高宽

‘调整字体
Call AddTextStyle(“Standard”)

‘填充表格
oTable.SetText 0, 0, “LOAD LIST”

oTable.SetText 1, 0, “Load”
oTable.SetText 2, 0, “Rating(kW)”
oTable.SetText 3, 0, “Factor”
oTable.SetText 4, 0, “Voltage(kV)”
oTable.SetText 5, 0, “Current(A)”

oTable.SetText 1, 1, “潜污泵 A”
oTable.SetText 2, 1, “22”
oTable.SetText 3, 1, “0.8”
oTable.SetText 4, 1, “0.38”
oTable.SetText 5, 1, “=B3/(1.732×B4×B5)” ‘× 改为合法的六星乘号

oTable.SetText 1, 2, “循环泵”
oTable.SetText 2, 2, “37”
oTable.SetText 3, 2, “0.8”
oTable.SetText 4, 2, “0.38”
oTable.SetText 5, 2, “=C3/(1.732×C4×C5)” ‘× 改为合法的六星乘号

oTable.SetText 1, 3, “外输泵”
oTable.SetText 2, 3, “45”
oTable.SetText 3, 3, “0.8”
oTable.SetText 4, 3, “0.38”
oTable.SetText 5, 3, “=D3/(1.732×D4×D5)” ‘× 改为合法的六星乘号

oTable.SetText 1, 4, “管道泵”
oTable.SetText 2, 4, “18.5”
oTable.SetText 3, 4, “0.8”
oTable.SetText 4, 4, “0.38”
oTable.SetText 5, 4, “=E3/(1.732×E4×E5)” ‘× 改为合法的六星乘号

oTable.SetText 1, 5, “潜污泵 B”
oTable.SetText 2, 5, “22”
oTable.SetText 3, 5, “0.8”
oTable.SetText 4, 5, “0.38”
oTable.SetText 5, 5, “=F3/(1.732×F4×F5)” ‘× 改为合法的六星乘号

oTable.SetText 1, 6, “照明箱”
oTable.SetText 2, 6, “20”
oTable.SetText 3, 6, “0.8”
oTable.SetText 4, 6, “0.38”
oTable.SetText 5, 6, “=G3/(1.732×G4×G5)” ‘× 改为合法的六星乘号

‘获取第4行第5列的文字
Debug.Print oTable.GetText(3, 4) ‘单元格序号基于 0

‘绑定 AutoCAD
Dim I As Integer, J As Integer
Dim oAutoCAD As Object
Call BindAutoCAD(True)

‘打开并绑定文件 D:/Test.dwg
Dim oDraw As Object ‘AutoCAD 多文档之一
Set oDraw = oAutoCAD.Application.Documents.Open(“D:/Test.dwg”)

‘ 生成块定义
Dim oBlockDef As Object
Dim insertionPnt(0 To 2) As Double
insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#
Set oBlockDef = oDraw.Blocks.Add(insertionPnt, “TestBlock”)

‘ 块内添加圆
Dim oCircle As Object
Dim center(0 To 2) As Double
Dim radius As Double
center(0) = 0: center(1) = 0: center(2) = 0
radius = 12
Set oCircle = oBlockDef.AddCircle(center, radius)
Debug.Print “Entity Name: ” & oCircle.EntityName
Debug.Print oCircle.Handle

‘ 块内添加单行文字
Dim startPoint(0 To 2) As Double
Dim height As Double
Dim textString As String
Dim oText As Object
startPoint(0) = 15
startPoint(1) = 5
startPoint(2) = 0
height = 6
textString = “A block demo.”
Set oText = oBlockDef.AddText(textString, startPoint, height)
Debug.Print “Entity Name: ” & oText.EntityName
Debug.Print oText.Handle

‘ 插入块(块的实例化)
Dim oBlockRef As Object
insertionPnt(0) = 2#: insertionPnt(1) = 2#: insertionPnt(2) = 0
Set oBlockRef = oDraw.ModelSpace.InsertBlock(insertionPnt, “TestBlock”, 1#, 1#, 1#, 0)

‘ 缩放块实例
Dim basePoint(0 To 2) As Double
Dim scaleFactor As Double
basePoint(0) = 0#
basePoint(1) = 0#
basePoint(2) = 0#
scaleFactor = 10#
Call oBlockRef.ScaleEntity(basePoint, scaleFactor)

‘ 旋转块实例
Dim rotationAngle As Double
basePoint(0) = 0#
basePoint(1) = 0#
basePoint(2) = 0#
rotationAngle = 1.57 ‘弧度
Call oBlockRef.Rotate(basePoint, rotationAngle)

‘ 分解块实例
Dim oSet As Variant
oSet = oBlockRef.Explode()
For I = LBound(oSet) To UBound(oSet)
Debug.Print “Entity Name: ” & oSet(I).EntityName
Debug.Print oSet(I).Handle
Next

‘ 执行 AutoCAD 命令 Zoomextents
oAutoCAD.Zoomextents

‘本例演示判断两个图元是否交叉？有几个交点？交点坐标分别是什么？

‘绑定 AutoCAD
Dim I As Integer, J As Integer
Dim oAutoCAD As Object
Call BindAutoCAD(True)

‘打开并绑定文件 D:/Test.dwg
Dim oDraw As Object ‘AutoCAD 多文档之一
Set oDraw = oAutoCAD.Application.Documents.Open(“D:/Test.dwg”)

‘建立选择集
Dim oSelset As Object, oItem As Object
Dim TempName As String
TempName = SelName(8)
If SetExist(oDraw, TempName) Then oDraw.SelectionSets.Item(TempName).Delete
Set oSelset = oDraw.SelectionSets.Add(TempName)
oDraw.Activate

‘屏幕选择多个图元填入选择集，列出前两个图元之间交点的坐标
Dim IntersectPoint As Variant
oSelset.SelectOnScreen
‘Debug.Print “oSelSet.Count” & Space$(1) &”=” & Space$(1) & oSelSet.Count
If oSelset.Count > 1 Then ‘最少两个,但只认前两个
‘ Find the intersection points between the oSelSet(0) and the oSelSet(1)
IntersectPoint = oSelset(0).IntersectWith(oSelset(1), 0)
‘ acExtendNone Does not extend either object.
‘ acExtendThisEntity Extends the base object.
‘ acExtendOtherEntity Extends the object passed as an argument.
‘ acExtendBoth Extends both objects.
‘ Print all the intersection points
If VarType(IntersectPoint) <> vbEmpty Then
For I = LBound(IntersectPoint) To UBound(IntersectPoint) Step 3
Debug.Print “Intersection[” & (I + 3) / 3 & “/” & (UBound(IntersectPoint) – LBound(IntersectPoint) + 1) / 3 & “]:” & Space$(1) & _
IntersectPoint(I) & “,” & IntersectPoint(I + 1) & “,” & IntersectPoint(I + 2)
Next I
Else
Debug.Print “No intersection points.”
End If
End If

‘解除绑定,释放资源
oSelset.Delete
Set oSelset = Nothing
Set oItem = Nothing

‘本例演示分多次绘制图形,而每次所绘图元与当前进程所绘一般无二,即,可以对其进行任何操作, 绘制图元的数据存储于 Dictionarys,下次从 Dictionarys 中读出数据加以利用

‘绑定 AutoCAD
Dim I As Integer, J As Integer
Dim oAutoCAD As Object
Call BindAutoCAD(True)
Dim oDraw As Object ‘AutoCAD 多文档之一

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

Dim oLine() As Object
Dim LineCount As Integer
Public vPickPoint As Variant
Dim dStartPoint(0 To 2) As Double
Dim dEndPoint(0 To 2) As Double

‘在 Dictionarys 中查找 “Line”，并读取”Handle” App 的 “1000” 位码的值
Dim sTemp As String
sTemp = GetDicString(oDraw, “Line”, “Handle”)
sTemp = PurgeTerminal(sTemp, “|”)

‘确定起点
Set oUtility = oDraw.Utility
If sTemp = “” Then ‘第一次
LineCount = 0
vPickPoint = oUtility.GetPoint(, “选取线段起点!”)
dStartPoint(0) = vPickPoint(0)
dStartPoint(1) = vPickPoint(1)
dStartPoint(2) = vPickPoint(2)
Else ‘Dictionary 有数据则唤醒对象
Dim TempArray As Variant
TempArray = Split(sTemp, “|”, -1, vbTextCompare)
For I = LBound(TempArray) To UBound(TempArray)
LineCount = LineCount + 1
ReDim Preserve oLine(1 To LineCount)
Set oLine(LineCount) = oDraw.HandleToObject(TempArray(I))
Next I
Dim vStart As Variant, vEnd As Variant
vStart = oLine(LineCount).StartPoint
vEnd = oLine(LineCount).EndPoint ‘AutoCAD 特别之处
dStartPoint(0) = vEnd(0)
dStartPoint(1) = vEnd(1)
dStartPoint(2) = vEnd(2)
End If

‘绘制(或增加)线段
vPickPoint = oUtility.GetPoint(dStartPoint, “选取线段终点!”)
dEndPoint(0) = vPickPoint(0)
dEndPoint(1) = vPickPoint(1)
dEndPoint(2) = vPickPoint(2)
LineCount = LineCount + 1
ReDim Preserve oLine(1 To LineCount)
Set oLine(LineCount) = oDraw.ModelSpace.AddLine(dStartPoint, dEndPoint)

‘在 Dictionarys 中生成新的(或更新) Dictionary，建立 App 并为 “1000” 位码赋值
Dim lRet As Long
Dim sDic As String
Dim sApp As String
Dim sValue As String
sDic = “Line”
sApp = “Handle”
For I = 1 To LineCount
sValue = sValue & “|” & oLine(I).Handle
Next I
sTemp = PurgeTerminal(sValue, “|”)
lRet = SetDicString(oDraw, sDic, sApp, sValue)

‘测试一:统计长度
Dim dLength As Double
For I = 1 To LineCount
dLength = dLength + oLine(I).Length
Next I
Debug.Print “线段根数:” & CStr(LineCount)
Debug.Print “线段总长:” & CStr(dLength)

‘测试二:部分线段左移,部分线段右移
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
point1(0) = 0: point1(1) = 0: point1(2) = 0
point2(0) = 200: point2(1) = 0: point2(2) = 0
For I = 1 To LineCount Step 2
If I <= LineCount Then oLine(I).Move point1, point2 ‘1, 3, 5, 7
If I + 1 <= LineCount Then oLine(I + 1).Move point2, point1 ‘2, 4, 6, 8
Next I

‘测试三:识别屏幕所选图元
‘在 Dictionarys 中查找 “Line”，并读取”Handle” App “1000” 位码的值
Dim oSelset As Object, oItem As Object
sTemp = GetDicString(oDraw, “Line”, “Handle”)
sTemp = PurgeTerminal(sTemp, “|”)
Dim TempArray As Variant
TempArray = Split(sTemp, “|”, -1, vbTextCompare)
Dim iIndex As Integer
Dim TempName As String
TempName = SelName(8)
If SetExist(oDraw, TempName) Then oDraw.SelectionSets.Item(TempName).Delete
Set oSelset = oDraw.SelectionSets.Add(TempName)
oDraw.Activate
oSelset.SelectOnScreen
‘Debug.Print “oSelSet.Count” & Space$(1) &”=” & Space$(1) & oSelSet.Count
If oSelset.Count <= 0 Then Exit Sub
For I = 0 To oSelset.Count – 1
iIndex = IndexInArray(oSelset.Item(I).Handle, TempArray)
If iIndex = -1 Then
Debug.Print “选择了集外图元.”
Else
Debug.Print “选择了” & CStr(iIndex + 1) & “号线段.”
End If
Next I
oSelset.Delete
Set oSelset = Nothing
Set oItem = Nothing