---

Hallo zusammen,

ich benötige mal eure Hilfe. Ich habe es hinbekommen mittels vba die Zeichnungsstückliste zu exportieren in das von mir gewünschte Template.

Dennoch sind unsere Stücklisten für den Stalbau teilweise recht lang, was zur Folge hat das der Inhalt über die Fusszeilen hinüberschwappt. Gibt es eine Möglichkeit in VBA ein Bereich zu definieren? z.B. er soll bei Zeile A14 starten die Werte einzutragen und sobald A51 erreicht ist soll ein neues Blatt mit der gleichen Vorlage angelegt werden und er beginnt wieder bei der Zeilte A14 mit den weiteren Einträgen?

Und die nächste Frage die sich mir stellt: Wie kann ich einzelne Zellen mit einem bestimmten Wert ausfüllen, den er vom Zeichner erhält,bzw. vielleicht über ein Dropdown Feld möglich ist auszuwählen?

Vielen Dank schonmal für eure Hilfe.

Das ist der Export Code:

Sub export_BOM()
Dim oapp As Inventor.Application
Set oapp = ThisApplication
Dim odoc As Inventor.DrawingDocument

If oapp.ActiveDocument.DocumentType <> kDrawingDocumentObject Then
    MsgBox "Funktion ist nur in Zeichnungen zulässig"
    Exit Sub
End If

Set odoc = oapp.ActiveDocument
Dim oOptions As NameValueMap
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap

Dim oName, oStart, oTemplate, oFullFileName, oFileName, oXLSFileName  As String
Dim oLength As String

oFullFileName = Mid(odoc.FullFileName, InStrRev(odoc.FullFileName, "\") + 1)
oLength = Len(oFullFileName)
oFileName = Left(oFullFileName, oLength - 4)
oXLSFileName = "C:\temp\" & oFileName

'oName = Name des Excel- Sheets
oName = oFileName
'oStart = Start- Zelle
oStart = "A13"
'oTemplate = Pfad zum xls- Template
oTemplate = "C:\temp\Vorlage.xls"

Call oOptions.Add("TableName", oName)
Call oOptions.Add("StartingCell", oStart)
Call oOptions.Add("Template", oTemplate)

Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)

End Sub

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Ups der Thread sollte eigentlich in INventor Vba. kann das jemand bitte mal verschieben? danke!

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

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