Moin,
Projekt Referenz auf excel.exe setzen nicht vergessen !
Sub DRAW_plates_from_excel()
Dim BLO As AcadBlockReference
Dim PoLin, sPoLin As Acad3DPolyline 'AutoCAD Polylinie
Dim Punkt(0 To 5) As Double 'Koordinaten des ersten Segments
Dim NeuPunkt(0 To 2) As Double
Dim MidPoint(0 To 2) As Double 'Koordintenfolgepunkte
Dim EPunkt(0 To 2) As Double 'Koordintenfolgepunkte
Dim wb As Excel.Workbook
Dim WTAB As Excel.Worksheet
Set wb = Excel.Workbooks.Open(SLOPEDIR.PROJECT & "\AP-OVERVIEW-3.xls")
Set WTAB = wb.Worksheets("AP")
Dim X0 As Double
Dim X1 As Double
Dim y0 As Double
Dim Y1 As Double
Dim z0 As Double
Dim Z1 As Double
Dim att As Variant
Dim ATTLIST As Variant
NR = 7
Do While Sheets("AP").Cells(NR, 2) <> ""
x = Sheets("AP").Cells(NR, 15)
Y = Sheets("AP").Cells(NR, 16)
z = Sheets("AP").Cells(NR, 14)
D = Sheets("AP").Cells(NR, 27)
KKS = MID(Sheets("AP").Cells(NR, 4), 6, 8)
TYP = "p" & Sheets("AP").Cells(NR, 25)
If left(D, 1) = "R" And x <= 0 And Y <> 0 Then
If left(D, 1) = "L" And x <= 0 Then Y = -Y
If left(D, 1) = "R" And x > 0 Then Y = Y
NeuPunkt(0) = Y
NeuPunkt(1) = z
NeuPunkt(2) = x
Set BLO = block_insert(NeuPunkt, TYP, 1, 1, 1, 0)
If BLO.hasattributes Then
ATTLIST = BLO.GetAttributes
For i = LBound(ATTLIST) To UBound(ATTLIST)
If ATTLIST(i).TAGSTRING = "KKS" Then ATTLIST(i).TEXTSTRING = KKS
Next
End If
End If
'debug.print KKS, TYP, Y, Z, X
NR = NR + 1
Loop
'Set WB = Excel.Workbooks.Close
End Sub
Function block_get_attribute(BLO As AcadBlockReference, tagname, Optional found As Boolean = False) As String
Dim ATTLIST As Variant
On Error Resume Next
If BLO.hasattributes Then
ATTLIST = BLO.GetAttributes
For i = LBound(ATTLIST) To UBound(ATTLIST)
If UCase(ATTLIST(i).TAGSTRING) = tagname Or UCase(Trim(ATTLIST(i).TAGSTRING)) = tagname & "_001" Then
block_get_attribute = ATTLIST(i).TEXTSTRING
found = True
Exit Function
End If
Next
End If
End Function
Sub block_set_attribute(BLO As AcadBlockReference, tagname, tagvalue)
Dim ATTLIST As Variant
If BLO Is Nothing Then Exit Sub
If BLO.hasattributes Then
tagname = Trim(UCase(tagname))
ATTLIST = BLO.GetAttributes
For i = LBound(ATTLIST) To UBound(ATTLIST)
'''debug.print "#" & UCase(attlist(i).TagString) & "#", tagname
If UCase(ATTLIST(i).TAGSTRING) = tagname Or UCase(Trim(ATTLIST(i).TAGSTRING)) = tagname & "_001" Then
'On Error Resume Next
ATTLIST(i).TEXTSTRING = "" & tagvalue
' attlist(I).Update
' On Error GoTo 0
Exit Sub
End If
Next
End If
End Sub
Guten Rutsch !
Thomas
------------------
Wer es nicht versucht, hat schon verlorn
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP