HI,
wenn deine Tabelle die passenden EINFUEGE Koordinaten bereitstellt ist es machbar.
Allerdings wuerde ich da nicht die Multileader benutzen sondern dynamische Blöcke mit Attributen (letztere kann man auch wieder auslesen und sie lassen sich auch spiegeln)
Wenn dem nicht so ist ...
Dann hast du das Problem das niemand weis WO die Beschriftungen anzuflanschen sind - da musst selber klicken.
Die entsprechende VBA Programmierung ist auch aufwaendiger.
Ich wuerd einen Dialog mit einer Listbox bauen sowie einem vor, einem zuruck und einem Einfuegeknopf.
Dann koennt man die Liste mit etwas verwertbarem aus der excel tabelle fuellen
und sie mit den knoepfen der reihe nach durchwandern und mit dem einfuegeknopf den block nach auswahl des punktes dort einfuegen
wo er hingehoert. Und etwas logick übertraegt dann die Blockattribute mit den Tabellenwerten
Dynamische Blöcke um die Attribute etc verschieben zu koennen.
Ist einmalig ungefahr ein Tag Geschaeft fürs vorbereiten (wenn man es AZUBI sicher haben will)
und dann sehr einfach.
Die nachfolgend routinen funktionieren ergeben aber nicht deine fertige Anwendung *lach*
Immerhin adressieren sie die Hauptfunktionen die du benoetigst und diese routinen sind getested.
Sollt schon mal ein paar Tage mit alka selzer ersparen
Ich hatte mal das problem Aufmasspunkte welche aus 2 koordinatren bestanden dreidimensional darzustellen
und habe zur orientierung dazu Blöcke ebenfalls eingefuegt.
Ferner hab ich noch 3 routinen die Blockattribute setzen und loeschen dazugelegt.
Plus Pubktpickroutine ist ja nicht wie bei armen leuten hier
IM VBA die referenz oder den Verweis suf die excel.exe nicht vergessen (googlen da hats haufenweise tutorials dazu)
Public Sub Polin_aus_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("C:\diana.xls")
Set WTAB = wb.Worksheets("Sheet1")
I = 7
Sc = 1000
Do While I < 100
offset = 8
mytest = WTAB.Cells(I, offset + 1)
If IsNumeric(mytest) Then
If mytest <> 0 Then
Punkt(0) = mVal(WTAB.Cells(I, offset + 1).Value) * Sc
Punkt(1) = mVal(WTAB.Cells(I, offset + 2).Value) * Sc
Punkt(2) = mVal(WTAB.Cells(I, offset + 3).Value) * Sc
'Debug.Print i, Punkt(0), Punkt(1), Punkt(2)
offset = 23
Punkt(3) = mVal(WTAB.Cells(I, offset + 1).Value) * Sc
Punkt(4) = mVal(WTAB.Cells(I, offset + 2).Value) * Sc
Punkt(5) = mVal(WTAB.Cells(I, offset + 3).Value) * Sc
Set sPoLin = ThisDrawing.modelspace.Add3DPoly(Punkt) 'Polylinie erzeugen
MidPoint(0) = 0.5 * (Punkt(0) + Punkt(3))
MidPoint(1) = 0.5 * (Punkt(1) + Punkt(4))
MidPoint(2) = 0.5 * (Punkt(2) + Punkt(5))
sPoLin.ScaleEntity MidPoint, 2#
'set POINTmarks
NeuPunkt(0) = Punkt(0)
NeuPunkt(1) = Punkt(1)
NeuPunkt(2) = Punkt(2)
Set blo = ThisDrawing.modelspace.InsertBlock(NeuPunkt, "3D-KOORDINATE", 1, 1, 1, 0)
NeuPunkt(0) = Punkt(3)
NeuPunkt(1) = Punkt(4)
NeuPunkt(2) = Punkt(5)
Set blo = ThisDrawing.modelspace.InsertBlock(NeuPunkt, "3D-KOORDINATE", 1, 1, 1, 0)
Debug.Print I, NeuPunkt(0), NeuPunkt(1), NeuPunkt(2)
End If
End If
I = I + 1
Loop
wb.Close
End Sub
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
Function block_has_attribute(blo As AcadBlockReference, tagname As String) As Boolean
Dim attlist As Variant
On Error Resume Next
block_has_attribute = False
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_has_attribute = True
Exit Function
End If
Next
End If
End Function
Function block_get_attribute(blo As AcadBlockReference, tagname) As String
Dim attlist As Variant
On Error Resume Next
'If blo Is Nothing Then Exit Function
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
Exit Function
End If
Next
End If
End Function
Function get_POINT(MSG As String, P() As Double) As Boolean
get_POINT = False
Dim returnPnt As Variant
Dim v(2) As Double
' Return a POINT using a prompt
On Error GoTo ende
Err.Clear
returnPnt = ThisDrawing.UTILITY.getPoint(, "Enter a POINT: ")
On Error GoTo 0
If Err.number <> 0 Then Exit Function
get_POINT = True
'debug.print TypeName(returnPnt)
If TypeName(returnPnt) <> "Empty" Then
SLOPEFORM.CX = str(returnPnt(0))
SLOPEFORM.CY = str(returnPnt(1))
SLOPEFORM.CZ = str(returnPnt(2))
P(0) = returnPnt(0)
P(1) = returnPnt(1)
P(2) = returnPnt(2)
End If
Exit Function
ende:
P(0) = NAN
End Function
------------------
wer es nicht versucht, hat schon verlorn
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP