HU, ich hab das etwas anders gelöst. 1. Ich hab mir eine Exel tabelle definiert die die Kopf Fußzeilenwiederholung selber kann.
Nun muß man nur noch die Zellen in der Excel Tabelle munter ausfüllen
Anbei eine Routine die etwas in ein Excel Blatt füllt.
Referenz auf excel.exe setzen nicht vergessen
Gruß
Thomas
Sub coordinates_bending_schedule_o(ByVal selectionsetobject As AcadSelectionSet)
Dim BAR(20, 30) As Double
Dim BSPOS(1) As Long
Dim BSDIR As Long
Dim DELTA(1) As Double
Dim YDELTA(1) As Double
Dim SHORTY(1) As Long
Dim BSPOSID As Long
Dim entity As AcadEntity
Dim S As String
Dim r() As String
Dim r2() As String
Dim r3() As String
Dim r4() As String
Dim blo(1) As AcadBlockReference
Dim OBJ As Object
Dim ID1 As String
Dim ID2 As String
Dim ID0 As String
Dim retCoord As Variant
Dim RF As String
Dim SPOINT As POINT3D
Dim ePoint As POINT3D
Dim ssetObj As AcadSelectionSet
Dim ssobjs() As AcadEntity
ReDim ssobjs(0 To 1)
Dim SetName As String
Dim POLY As Acad3DPolyline
Dim P(8) As Double
Dim barlayer As String
Dim CID(1) As String
Dim CLAYER(1) As String
Dim ctype(1) As String
Dim CSHORT(1) As String
Dim CDELTAX(1) As String
Dim CDELTAY(1) As String
Dim CDELTAZ(1) As String
Dim CDELTAS(1) As String
Dim CDELTAE(1) As String
Dim CDELTA(1) As String
Dim CDIRECTION(1) As String
Dim CTX(1) As String
Dim CTY(1) As String
Dim CTZ(1) As String
Dim cIDs(1) As String
Dim CIDE(1) As String
'Open Excel
Dim oexcel As Excel.Application
Dim obook As Excel.Workbook
Dim oSheet As Excel.Worksheet
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")
oexcel.Application.ScreenUpdating = False
LINE = 0
nrow = 1
For j = 0 To 1
nrow = nrow + 1: oSheet.Cells(1, nrow) = "ID" '2
nrow = nrow + 1: oSheet.Cells(1, nrow) = "IDS"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "IDE"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "LAYER"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "DEVIATION"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "SHORT"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "RF"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "DX"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "DY"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "DZ"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "TX"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "TY"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "TZ"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "X"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "Y"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "Z"
nrow = nrow + 1
Next
nrow = nrow + 1: oSheet.Cells(1, nrow) = "1000"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "LAYER"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "DIRECTION"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "RF"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "XDELTAS"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "YDELTAS"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "ZDELTAS"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "DELTAS"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "XDELTAE"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "YDELTAE"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "ZDELTAE"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "DELTAE"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "DESX"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "DESY"
nrow = nrow + 1: oSheet.Cells(1, nrow) = "DESZ"
If 1 = 1 Then
LINE = 2
For Each entity In selectionsetobject
oexcel.Application.ScreenUpdating = False
If LCase(entity.ObjectName) = "acdb3dpolyline" Then
LINE = LINE + 1
oSheet.Cells(LINE, 1) = LINE
Debug.Print LINE
S = ""
Call XDATA_Get_full("REINF", entity, S)
s2 = S
' If s <> "" Then Debug.Print s
r = Split(S, "RF:")
If S <> "" Then
r(1) = REPLACE(r(1), vbLf, "")
r(1) = REPLACE(r(1), vbCr, "")
r(1) = REPLACE(r(1), vbCrLf, "")
r2 = Split(r(1), " ")
If Not GET_ENTITY_BY_HANDLE(blo(0), r2(0)) Then Debug.Print "ERROR B0"
If Not GET_ENTITY_BY_HANDLE(POLY, r2(1)) Then Debug.Print "ERROR POLY"
If Not GET_ENTITY_BY_HANDLE(blo(1), Trim(r2(2))) Then Debug.Print "ERROR B1"
Else
entity.color = str(240)
End If
barlayer = entity.layer
i = 0
r = Split(S, vbLf)
RFTYPE = r(2)
j = 0
nrow = 1
For i = 1 To 13
nrow = nrow + 1
oSheet.Cells(LINE, nrow) = block_get_attribute(blo(j), oSheet.Cells(1, nrow))
If oSheet.Cells(LINE, nrow) = "SHORT" Then
oSheet.Cells(LINE, nrow) = "LONG"
Sposshort = 0
Else
Sposshort = 1
End If
If oSheet.Cells(1, nrow) = "RF" Then
On Error Resume Next
oSheet.Cells(LINE, nrow) = REPLACE(oSheet.Cells(LINE, nrow), "RF:", "")
oSheet.Cells(LINE, nrow) = REPLACE(oSheet.Cells(LINE, nrow), vbLf, "")
End If
Next
For i = 0 To 2
nrow = nrow + 1
On Error Resume Next
oSheet.Cells(LINE, nrow) = blo(j).InsertionPoint(i)
On Error GoTo 0
Next
j = 1
nrow = 18
For i = 1 To 13
nrow = nrow + 1
oSheet.Cells(LINE, nrow) = block_get_attribute(blo(j), oSheet.Cells(1, nrow))
If oSheet.Cells(1, nrow) = "SHORT" Then
Eposshort = 0
oSheet.Cells(LINE, nrow) = "LONG"
Else
Eposshort = 1
End If
If oSheet.Cells(1, nrow) = "RF" Then
oSheet.Cells(LINE, nrow) = REPLACE(oSheet.Cells(LINE, nrow), "RF:", "")
oSheet.Cells(LINE, nrow) = REPLACE(oSheet.Cells(LINE, nrow), vbLf, "")
End If
Next
For i = 0 To 2
nrow = nrow + 1
On Error Resume Next
oSheet.Cells(LINE, nrow) = blo(j).InsertionPoint(i)
On Error GoTo 0
Next
'######''
nrow = 35
For i = 1 To 15
nrow = nrow + 1
key = oSheet.Cells(1, nrow)
kvalue = val(coordinates_get_info(r, key))
Select Case key
Case "DIRECTION"
oSheet.Cells(LINE, nrow) = r(2)
If r(2) = "VERTICAL" Then posdirection = 1 Else psdirection = 0
Case "LAYER"
oSheet.Cells(LINE, nrow) = POLY.layer
poslayer = oSheet.Cells(LINE, nrow)
Case "DELTAS"
DELTA(0) = kvalue
Case "DELTAE"
DELTA(1) = kvalue
Case "YDELTAS"
YDELTA(0) = kvalue
Case "YDELTAE"
YDELTA(1) = kvalue
Case Else
oSheet.Cells(LINE, nrow) = coordinates_get_info(r, oSheet.Cells(1, nrow))
End Select
Next
Select Case barlayer
Case "RFC4":
BSPOS(0) = 1
BSPOS(1) = 1
Case "RFC6":
BSPOS(0) = 2
BSPOS(1) = 2
Case "RFC4B":
BSPOS(0) = 3
BSPOS(1) = 3
Case "RFC6B":
BSPOS(0) = 4
BSPOS(1) = 4
Case "RFC5":
BSPOS(0) = 5
BSPOS(1) = 5
If Sposshort = 1 Then BSPOS(0) = 7
If Eposshort = 1 Then BSPOS(1) = 7
Case "RFC7":
BSPOS(0) = 6
BSPOS(1) = 6
If Sposshort = 1 Then BSPOS(0) = 8
If Eposshort = 1 Then BSPOS(1) = 8
Case Else
BSPOS(0) = 9
BSPOS(1) = 9
End Select
For B = 0 To 1
bpos = BSPOS(B)
If BSPOS(B) < 9 Then
dev = YDELTA(B)
Else
dev = DELTA(B) + 10
If posdirection = 0 Then
BAR(10, dev) = BAR(10, dev) + 1
Else
BAR(11, dev) = BAR(10, dev) + 1
End If
BAR(bpos, dev) = BAR(bpos, dev) + 1
End If
Next
End If
Next
End If
oexcel.Application.ScreenUpdating = True
oexcel.DisplayAlerts = True
'Save new file
'On Error Resume Next
Call obook.Close(True, "c:\temp\rf.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 !
<<< for sale !
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP