'
Function GetPointAcDimrotated(returnObj As AcadDimRotated)
Dim D As AcadEntity
Dim Tp As Variant
Dim VariantArr() As Variant
Dim k As Long
Dim ArrDxf As Boolean
Dim flagArr As Boolean
Dim ArrDimPoint() As Variant
Dim Codedxf As Variant
Dim CodeValue As Variant
Dim arrRes() As String
Dim startPnt(0 To 2), endPnt(0 To 2), location(0 To 2) As Variant
Dim ResArrPoint(0 To 2) As Variant
Dim Start As Double
Dim FileName_Dxf As String
Dim i As Integer
Dim str As String
Dim flag As Boolean
Dim FilePathAndName As String
Dim InputData
Dim reading As Boolean
Dim AcDimensionPropTemp As New Collection
Dim lineNumber As Integer
ArrDxf = False
flag = True
FileName_Dxf = ThisDrawing.GetVariable("DWGPREFIX") & "Dimdxf.dxf"
FileName_Dxf = Replace(FileName_Dxf, "\", "\\")
str = "(command ""_dxfout"" """ & FileName_Dxf & """ ""_O""" & " (handent """ & returnObj.Handle & """)" & " """" """") "
Application.ActiveDocument.SendCommand (str)
'Подождем пока файлик появится
FilePathAndName = FileName_Dxf
Do While flag
If Len(Dir$(FilePathAndName)) > 0 Then
'MsgBox ("Файл существует!")
flag = False
Else
'MsgBox ("Файл не найден...")
Start = Timer
Do While Timer < Start + 0.5 '0.5 = полсекунды
DoEvents
Loop
End If
Loop
reading = False
On Error GoTo Exit1
Open FilePathAndName For Input As #4
Do While Not EOF(4)
Line Input #4, InputData
If Trim(InputData) = "ENTITIES" Then
reading = True
End If
If reading And Trim(InputData) = "ENDSEC" Then
Exit Do
End If
If reading Then
AcDimensionPropTemp.Add Item:=InputData, key:=CStr(lineNumber)
End If
lineNumber = lineNumber + 1
Loop
k = -1
For i = 3 To AcDimensionPropTemp.Count Step 2
ArrDxf = True
k = k + 1
ReDim Preserve VariantArr(k)
VariantArr(k) = (Chr(10) & AcDimensionPropTemp(i - 1) & "->" & AcDimensionPropTemp(i))
Next
k = -1
If ArrDxf Then
For i = 0 To UBound(VariantArr)
arrRes = Split(VariantArr(i), "->")
Codedxf = arrRes(0)
CodeValue = arrRes(1)
' определение startPnt
If Codedxf = 13 Then
startPnt(0) = CodeValue
flagArr = True
k = k + 1
ReDim Preserve ArrDimPoint(k)
ArrDimPoint(k) = startPnt(0)
End If
If Codedxf = 23 Then
startPnt(1) = CodeValue
flagArr = True
k = k + 1
ReDim Preserve ArrDimPoint(k)
ArrDimPoint(k) = startPnt(1)
End If
If Codedxf = 33 Then
startPnt(2) = CodeValue
flagArr = True
k = k + 1
ReDim Preserve ArrDimPoint(k)
ArrDimPoint(k) = startPnt(2)
End If
' определение endPnt
If Codedxf = 14 Then
endPnt(0) = CodeValue
flagArr = True
k = k + 1
ReDim Preserve ArrDimPoint(k)
ArrDimPoint(k) = endPnt(0)
End If
If Codedxf = 24 Then
endPnt(1) = CodeValue
flagArr = True
k = k + 1
ReDim Preserve ArrDimPoint(k)
ArrDimPoint(k) = endPnt(1)
End If
If Codedxf = 34 Then
endPnt(2) = CodeValue
flagArr = True
k = k + 1
ReDim Preserve ArrDimPoint(k)
ArrDimPoint(k) = endPnt(2)
End If
' определение location
If Codedxf = 10 Then
location(0) = CodeValue
flagArr = True
k = k + 1
ReDim Preserve ArrDimPoint(k)
ArrDimPoint(k) = location(0)
End If
If Codedxf = 20 Then
location(1) = CodeValue
flagArr = True
k = k + 1
ReDim Preserve ArrDimPoint(k)
ArrDimPoint(k) = location(1)
End If
If Codedxf = 30 Then
location(2) = CodeValue
flagArr = True
k = k + 1
ReDim Preserve ArrDimPoint(k)
ArrDimPoint(k) = location(2)
End If
Next
If flagArr Then
If UBound(ArrDimPoint) = 8 Then
ResArrPoint(0) = startPnt
ResArrPoint(1) = endPnt
ResArrPoint(2) = location
GetPointAcDimrotated = ResArrPoint
Debug.Print startPnt(0), startPnt(1), startPnt(2)
Debug.Print endPnt(0), endPnt(1), endPnt(2)
Debug.Print location(0), location(1), location(2)
Else
GoTo Exit1
End If
Else
GoTo Exit1
End If
End If
Exit1:
Close #4
End Function
