Hi
Verknüpfung nachträglich herstellen dürft knifflig werden.
Aber mann kann Tabellen per VBA auslesen und in Excel schreiben und dort auch formatieren
als auch umgekehrt Tabellen aus Excel erzeugen und in ACAD neu aufbauen.
Besser ist na klar die ganzen Daten in eine zentrale Datenbank zu verfrachten und diese dann zu pflegen und ggf in ACAD anzeigen / aktualisieren zu lassen.
LG aus Finnland
<--- ist z Zt Käuflich 
Beispiel Tabelle von nem VBA Array aus einfügen
------------------------------------------------
Sub table_from_array(A() As String)
Dim Pt(2) As Double
Dim MyTable As AcadTable
Set MyTable = MyModelSpace.AddTable(Pt, UBound(BBS) + 4, 6, 10, 30)
MyTable.RegenerateTableSuppressed = True
LINES = UBound(A, 0)
cols = UBound(A, 0)
Dim col As New AcadAcCmColor
'col.SetRGB 255, 0, 255
For i = 0 To LINES
For j = 0 To cols
MyTable.SetCellTextHeight i, j, 3.5
MyTable.SetCellAlignment i, j, acMiddleCenter
MyTable.SetCellBackgroundColor i, j, col
MyTable.SetCellContentColor i, j, col
MyTable.SetCellType i, j, acTextCell
Next j
Next i
'To see line weights, do a plot or a plot preview
MyTable.SetGridLineWeight AcGridLineType.acHorzTop, AcRowType.acHeaderRow, AcLineWeight.acLnWt000
MyTable.SetGridLineWeight AcGridLineType.acHorzBottom, AcRowType.acDataRow, AcLineWeight.acLnWt000
MyTable.SetGridLineWeight AcGridLineType.acVertLeft, AcRowType.acTitleRow, AcLineWeight.acLnWt000
MyTable.SetGridLineWeight AcGridLineType.acVertRight, AcRowType.acTitleRow, AcLineWeight.acLnWt000
MyTable.SetGridLineWeight AcGridLineType.acHorzTop, AcRowType.acTitleRow, AcLineWeight.acLnWt000
'zeilen 'spalten
For i = 0 To LINES
For j = 0 To cols
MyTable.SETTEXT i, j, A(i, j)
Next
Next
MyTable.RegenerateTableSuppressed = False
If get_POINT("Table", Pt) Then
MyTable.insertionPoint = Pt
End If
Call MyTable.ScaleEntity(Pt, 30)
End Sub
Beispiel Excel tabelle auslesen (Koordinaten) und Punkte malen
--------------------------------------------------------------
Public Sub EXCEL_TABLE_IMPORT()
Dim blo As AcadBlockReference
Dim EPunkt(0 To 2) As Double
Dim wb As Excel.Workbook
Dim WTAB As Excel.Worksheet
Set wb = Excel.Workbooks.Open("C:\KOORDINATEN.xls")
Set WTAB = wb.Worksheets("KOORDINATEN")
offset = 2
i = 1
While WTAB.Cells(i, 1) <> ""
EPunkt(0) = WTAB.Cells(i, offset + 1) 'x
EPunkt(1) = WTAB.Cells(i, offset + 2) 'y
EPunkt(2) = WTAB.Cells(i, offset + 3) 'z
i = i + 1
Set blo = ThisDrawing.modelspace.InsertBlock(EPunkt, "KOORDINATE", 1, 1, 1, 0)
Wend
wb.Close 'Datei schließen nicht vergessen
End Sub
Beispiel: aus selektierten Blöcken ne excel tabelle erzeugen
------------------------------------------------------------
Sub Excel_Export_COORDINATESII()
Dim entity As AcadEntity
Dim blockref, BLK As AcadBlockReference
Dim polyline As AcadPolyline
Dim MTextObj As AcadMText
Dim face As Acad3DFace
Dim Myname, Mytype, KKS As String
Dim P1 As Variant
Dim P2(0 To 2) As Double
Dim P4(0 To 2), ang As Double
Dim x, y, z, r, l, r1, r2, x0, X1, X2, y0, y1, y2, z0, z1, z2, D, D0, pi1, td, pt1, Pt2, pt3, rot, level, lenkor As Double
Dim WIDTH As Double
Dim i As Integer
Dim Koord As Variant
Dim v As String
Dim b As String
Dim crlf As String
Dim text As String
FORM$ = "#.####"
Dim AttList As Variant
Dim oExcel As Excel.Application
Dim obook As Excel.Workbook
Dim osheet As Excel.Worksheet
Dim nrow As Integer
Dim NCol As Integer
Dim Facenr, FACES As Long
'Open Excel
Set oExcel = Excel.Application
oExcel.Visible = True
'Set oBook = oExcel.Workbooks.Add("C:\myTemplate.xls") ' Optional
Set obook = oExcel.Workbooks.ADD
Set osheet = obook.Sheets("Tabelle1")
nrow = 1
osheet.Cells(nrow, 1) = "Nr."
osheet.Cells(nrow, 2) = "d"
osheet.Cells(nrow, 3) = "r"
osheet.Cells(nrow, 4) = "X"
osheet.Cells(nrow, 5) = "Y"
osheet.Cells(nrow, 6) = "Z"
osheet.Cells(nrow, 7) = "TYPE"
osheet.Cells(nrow, 8) = "NAME"
'Create table
Facenr = 0
'run trough whole drawing
For Each entity In ThisDrawing.modelspace
'look for object types
Select Case LCASE(entity.ObjectName)
Case "acdbblockreference"
Set blockref = entity
Debug.Print blockref.Name, blockref.layer
If entity.layer = "FIN-AP" Then
Mytype = "AP"
P1 = blockref.insertionPoint
pt1 = Val(str(P1(0)))
Pt2 = Val(str(P1(1)))
pt3 = Val(str(P1(2)))
level = Pt2
rot = blockref.ROTATION
rot = 0
l = P1(0) 'X
lenkorr = l - 1171.38715091
lenkorr = lenkorr \ 2577.01652173
lenkorr = lenkorr * 2577.01652173 + 1171.38715091
If Abs(l - lenkorr) < 6 Then
l = lenkorr
Debug.Print "korrected"
P1(0) = l
End If
z2 = P1(1) 'Y
r1 = 28300
z2 = z2 - 45150
D = l * 360 / (r1 * PI * 2)
If D > 0 And D <= 90 Then
D2 = 90 - D
Else
D2 = 450 - D
End If
r2 = 9800
dr = r2 - Sqr((r2 * r2) - (z2 * z2))
r = 28300 - dr
radiant = D / 180 * PI
x = r * Sin(radiant)
y = r * Cos(radiant)
P2(0) = x
P2(1) = y
P2(2) = z
Myname = block_find_most_near(pt1, Pt2, pt3)
myname1 = Right(Myname, 6)
If Round(P1(1), 0) = 49420 Then
typ = "AP450"
Else
typ = "AP250"
End If
Set blo = ThisDrawing.modelspace.InsertBlock(P2, typ & "V", 1, 1, 1, ((90 - D) - 90) / 180 * PI)
AttList = blo.GetAttributes
For i = LBound(AttList) To UBound(AttList)
If AttList(i).TagString = "X" Then AttList(i).TEXTSTRING = "X=" & format(x, FORM)
If AttList(i).TagString = "Y" Then AttList(i).TEXTSTRING = "Y=" & format(y, FORM)
If AttList(i).TagString = "Z" Then AttList(i).TEXTSTRING = "Z=" & format(level, FORM)
If AttList(i).TagString = "A" Then AttList(i).TEXTSTRING = "D=" & format(D, FORM)
If AttList(i).TagString = "R" Then AttList(i).TEXTSTRING = "R=" & format(Round(r, 0), FORM)
If AttList(i).TagString = "TYPE" Then AttList(i).TEXTSTRING = typ & " - " & str(l)
If AttList(i).TagString = "NAME" Then AttList(i).TEXTSTRING = myname1
AttList(i).UPDATE
entity.UPDATE
Next
Debug.Print Sin(radiant)
Set blo = ThisDrawing.modelspace.InsertBlock(P1, typ, 1, 1, 1, 0)
blo.YScaleFactor = 2
AttList = blo.GetAttributes
For i = LBound(AttList) To UBound(AttList)
If AttList(i).TagString = "X" Then AttList(i).TEXTSTRING = "X=" & format(x, FORM)
If AttList(i).TagString = "Y" Then AttList(i).TEXTSTRING = "Y=" & format(y, FORM)
If AttList(i).TagString = "Z" Then AttList(i).TEXTSTRING = "Z=" & format(level, FORM)
If AttList(i).TagString = "A" Then AttList(i).TEXTSTRING = "D=" & format(D, FORM)
If AttList(i).TagString = "R" Then AttList(i).TEXTSTRING = "R=" & format(Round(r, 0), FORM)
If AttList(i).TagString = "TYPE" Then AttList(i).TEXTSTRING = typ & " - " & str(l)
If AttList(i).TagString = "NAME" Then AttList(i).TEXTSTRING = myname1
AttList(i).UPDATE
entity.UPDATE
Next
nrow = nrow + 1
FACES = 0
osheet.Cells(nrow, FACES + 1) = "POINT" & str(nrow)
osheet.Cells(nrow, FACES + 2) = D
osheet.Cells(nrow, FACES + 3) = r
osheet.Cells(nrow, FACES + 4) = x
osheet.Cells(nrow, FACES + 5) = y
osheet.Cells(nrow, FACES + 6) = level
osheet.Cells(nrow, FACES + 7) = Mytype
osheet.Cells(nrow, FACES + 8) = Myname
End If
Case Else
' Debug.Print entity.ObjectName & " wird noch nicht ausgewertet"
End Select
Next entity
oExcel.DisplayAlerts = False
'Save new file
Call obook.Close(True, "C:\myFile3.xls")
oExcel.DisplayAlerts = True
oExcel.Quit
Set osheet = Nothing
Set obook = Nothing
Set oExcel = Nothing
Debug.Print "DONE"
End Sub
------------------
Wer es nicht versucht, hat schon verlorn
Und bei 3 Typos gibts den vierten gratis !
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
.
)
