ç¨vbaå¯ä»¥å®ç°ã
为äºé²æ¢ä¿¡æ¯å¹²æ°ï¼å»ºè®®å¨è¯»ååï¼å°è¡¨æ ¼å
容设置å¨ä¸ä¸ªå¾å±ï¼ä¾å¦100ï¼ä¸ã
ä¸é¢ç代ç æ¯å¸®æååçï¼ä»
ä¾åèã
Sub 读åä¿¡æ¯()
' Const tzz = 6 'xåæ ç¸å·®5认为æ¯åä¸åæ°æ®
Dim ent As AcadEntity '对象åºç±»
Dim A(1 To 1000, 1 To 4) '1-ææ¬ 2-xåæ 3-yåæ 4-æ°æ®é¡¹çåæ°(4-ä¿®æ£åçXåæ )
Dim I As Integer
Dim x(1 To 1000) As Double 'åæ¾CADè¡¨æ ¼çº¿æ®µXåæ å¼
Dim xCount As Integer
Dim lineCount As Integer
Dim startP As Variant
Dim endP As Variant
Dim lineS(1 To 1000, 1 To 4) 'è®°å½ç«çº¿åæ
I = 1: j = 1
For Each ent In ThisDrawing.ModelSpace 'ææ对象
If TypeOf ent Is AcadText And ent.Layer = "100" Then 'åè¡ææ¬ ä¸å¾å±100
A(I, 1) = ent.TextString
B = ent.InsertionPoint
A(I, 2) = B(0)
A(I, 3) = B(1)
I = I + 1
'Else If TypeOf ent Is AcadMText Then 'å¤è¡ææ¬
'ElseIf TypeOf ent Is AcadDimension Then âæ 注
Else
If TypeOf ent Is AcadLine And ent.Layer = "100" Then
startP = ent.StartPoint
endP = ent.EndPoint
' x1 = ent.StartPoint(0)
' x2 = ent.EndPoint(0)
' If startP(0) >= 1507 Then
' sss = 1
' End If
If Abs(startP(0) - endP(0)) <= 0.1 Then 'èµ·ç¹Xåæ =ç»ç¹Xåæ
x(j) = startP(0)
lineS(j, 1) = startP(0)
lineS(j, 2) = startP(1)
lineS(j, 3) = endP(0)
lineS(j, 4) = endP(1)
j = j + 1
End If
End If
End If
Next
I = I - 1: j = j - 1
lineCount = j
'对线段Xåæ å¼æåº
For k = 1 To j - 1
For l = k + 1 To j
If x(k) > x(l) Then
xx = x(k)
x(k) = x(l)
x(l) = xx
End If
Next l
Next k
'对读åææ¬çXåæ è¿è¡æåº
Dim m_1 As String
Dim m_2 As Double
Dim m_3 As Double
Dim m_4 As Double
For j = 1 To I - 1
For k = j + 1 To I
If A(j, 2) > A(k, 2) Then 'æ°æ®äº¤æ¢
m_1 = A(j, 1)
m_2 = A(j, 2)
m_3 = A(j, 3)
A(j, 1) = A(k, 1)
A(j, 2) = A(k, 2)
A(j, 3) = A(k, 3)
A(k, 1) = m_1
A(k, 2) = m_2
A(k, 3) = m_3
End If
Next k
Next j
'å»é¤éå¤å¼
Dim y(1 To 100)
l = 1: y(1) = x(1)
For k = 2 To lineCount
If x(k) - y(l) > 1 Then
l = l + 1
y(l) = x(k)
End If
Next k
xCount = l
''设å®X2åæ å¼ xåæ å·®å¼å°äºè°æ´å¼å认为æ¯åä¸åæ°æ®ï¼å°X2åæ 设置为ç¸åå¼
'A(1, 4) = Int(A(1, 2))
'For j = 2 To I
' If A(j, 2) - A(j - 1, 2) < tzz Then
' A(j, 4) = A(j - 1, 4)
' Else
' A(j, 4) = Int(A(j, 2))
' End If
'Next j
'æ ¹æ®Xåæ å¼è®¡ç®æ°æ®é¡¹çåå·
For k = 1 To I
For l = 1 To xCount
If A(k, 2) >= y(l) And A(k, 2) < y(l + 1) Then
A(k, 4) = l
Exit For
End If
Next l
Next k
'对Yåæ è¿è¡éåºæå
For j = 1 To I - 1
For k = j + 1 To I
If A(j, 3) < A(k, 3) And A(j, 4) = A(k, 4) Then 'æ°æ®äº¤æ¢
m_1 = A(j, 1)
m_2 = A(j, 2)
m_3 = A(j, 3)
m_4 = A(j, 4)
A(j, 1) = A(k, 1)
A(j, 2) = A(k, 2)
A(j, 3) = A(k, 3)
A(j, 4) = A(k, 4)
A(k, 1) = m_1
A(k, 2) = m_2
A(k, 3) = m_3
A(k, 4) = m_4
End If
Next k
Next j
Set xlApp = GetObject(, "Excel.Application")
If Err Then
MsgBox " Excel åºç¨ç¨åºæ²¡æè¿è¡ã请å¯å¨ Excel 并éæ°è¿è¡ç¨åºã"
Exit Sub
End If
Dim xlSheet As Worksheet
Set xlSheet = xlApp.ActiveSheet
xlSheet.Select
For j = 1 To I - 1
With xlSheet
.Cells(j + 1, 1) = A(j, 1)
.Cells(j + 1, 2) = A(j, 2)
.Cells(j + 1, 3) = A(j, 3)
.Cells(j + 1, 4) = A(j, 4)
End With
Next j
'å°ç«çº¿çåæ å¼è¾åº
For j = 1 To lineCount
With xlSheet
.Cells(j + 1, 11) = lineS(j, 1)
.Cells(j + 1, 12) = lineS(j, 2)
.Cells(j + 1, 13) = lineS(j, 3)
.Cells(j + 1, 14) = lineS(j, 4)
End With
Next j
j = 1
End Sub
温馨提示:答案为网友推荐,仅供参考