Hot News:

Unser Angebot:

  Foren auf CAD.de (alle Foren)
  Inventor VBA
  Export Parameters to Excel

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
  
Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte
Autor Thema:  Export Parameters to Excel (3636 mal gelesen)
SHP
Mitglied
Konstrukteur


Sehen Sie sich das Profil von SHP an!   Senden Sie eine Private Message an SHP  Schreiben Sie einen Gästebucheintrag für SHP

Beiträge: 1331
Registriert: 17.07.2003

IV9-SP3
IV10-Sp3a
IV11

erstellt am: 05. Apr. 2005 20:43    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Hallo Forum,
hab mir von sDotson diesen Code zum exportieren der Parameter downgeloaded.
Nur hat dieser einen kleinen Schönheitsfehler, es werden zwar die Gleichungen ausgegeben aber nicht die Nennwerte.
Jetzt hab ich einfach diese Zeile eingefügt.
xlWS.Cells(iRow, 5).Value = "Nennwert"

Leider werden die Nennwerte nicht so ausgegeben wie diese in der Parameterliste stehen.
Längenwerte werden auf cm umgerechnet und Winkelwerte zum Bogenmaß.
Kann mir da jemand helfen?


Public Sub exportToExcel()
    Dim oParams As Parameters
    Dim sDocName As String
    Dim i As Long
    Dim iRow As Long
    'Next 3 declarations commented during production.
    ' Uncomment during development, but need reference to Excel (Tools>References>microsoft Excel 10.0 Object libary
    'This way no Reference to Excel required (more stable and Excel version independent
    'See also Note: OPEN_EXCEL.
'    Dim XL As New Excel.Application
'    Dim xlWB As Excel.Workbook
'    Dim xlWS As Excel.WorkSheet
    Dim XL As Object
    Dim xlWB As Object
    Dim xlWS As Object
   
   
   
    If ThisApplication.ActiveDocumentType <> kAssemblyDocumentObject And _
        ThisApplication.ActiveDocumentType <> kPartDocumentObject Then
        MsgBox "Only Part or Assymbly document", vbCritical
        Exit Sub
    End If
    Set oParams = ThisApplication.ActiveDocument.ComponentDefinition.Parameters
   
   
    'Connect to Excel, and create a new Workbook
    'Note: OPEN_EXCEL.
    Set XL = CreateObject("Excel.Application")
    Set xlWB = XL.Workbooks.Add
    Set xlWS = xlWB.ActiveSheet
    XL.Visible = True
   
    'Write the Header Row
    iRow = 1
    xlWS.Cells(iRow, 1).Value = "Type"
    xlWS.Cells(iRow, 2).Value = "Name"
    xlWS.Cells(iRow, 3).Value = "Unit"
    xlWS.Cells(iRow, 4).Value = "Equation"
    xlWS.Cells(iRow, 5).Value = "Nennwert"
    xlWS.Cells(iRow, 6).Value = "Export"
    xlWS.Cells(iRow, 7).Value = "Health"

    'Some Excel formatting:
    '1. Freeze Header row
    '2. Header Bold and bigger fontsize
    xlWS.Rows("2:2").Select
    XL.ActiveWindow.FreezePanes = True
    xlWS.Rows("1:1").Select
    XL.Selection.Font.Bold = True
    With XL.Selection.Font
        .Name = "Arial"
        .Size = 14
        .Bold = True
    End With


    For i = 1 To oParams.Count
        iRow = iRow + 1
        Select Case oParams.Item(i).Type
            Case kModelParameterObject
                xlWS.Cells(iRow, 1).Value = "Model"
            Case kUserParameterObject
                xlWS.Cells(iRow, 1).Value = "User"
            Case kTableParameterObject
                xlWS.Cells(iRow, 1).Value = "Table"
        End Select
        xlWS.Cells(iRow, 2).Value = oParams.Item(i).Name
        xlWS.Cells(iRow, 3).Value = oParams.Item(i).Units
        xlWS.Cells(iRow, 4).Value = oParams.Item(i).Expression
        xlWS.Cells(iRow, 5).Value = oParams.Item(i).Value
               
        xlWS.Cells(iRow, 6).Value = oParams.Item(i).ExposedAsProperty
       
        Select Case oParams.Item(i).HealthStatus
            Case kDeletedHealth
                xlWS.Cells(iRow, 7).Value = "Deleted"
            Case kDriverLostHealth
                xlWS.Cells(iRow, 7).Value = "Driver Lost"
            Case kInErrorHealth
                xlWS.Cells(iRow, 7).Value = "In Error"
            Case kOutOfDateHealth
                xlWS.Cells(iRow, 7).Value = "Out of Date"
            Case kUnknownHealth
                xlWS.Cells(iRow, 7).Value = "Unknown"
            Case kUpToDateHealth
                xlWS.Cells(iRow, 7).Value = "Up to Date"
        End Select
    Next
   
    'Format the entire page so cell contents fit
    XL.Cells.Select
    XL.Cells.EntireColumn.AutoFit
    xlWS.Range("A1").Select
   
    'save this XL document, default to Inventor location and name
    sDocName = ThisApplication.ActiveDocument.FullFileName
    If sDocName = "" Then
        sDocName = "c:\temp\x"
    Else
        sDocName = Mid(sDocName, 1, Len(sDocName) - 4)
    End If
    If Dir(sDocName & ".xls") <> "" Then
        i = 1
        Do While Dir(sDocName & "_" & i & ".xls") <> ""
            i = i + 1
        Loop
        sDocName = sDocName & "_" & i
    End If
    xlWB.SaveAs FileName:=sDocName
   
    'detach from XL
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set XL = Nothing
   

End Sub

------------------
Gruß
Hans-Peter
Der Wahnsinn in Sachen Musik.

  Das Saxregister
 

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

SHP
Mitglied
Konstrukteur


Sehen Sie sich das Profil von SHP an!   Senden Sie eine Private Message an SHP  Schreiben Sie einen Gästebucheintrag für SHP

Beiträge: 1331
Registriert: 17.07.2003

IV9-SP3
IV10-Sp3a
IV11

erstellt am: 05. Apr. 2005 23:46    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Hallo,
dank Daywalker bin ich schon etwas weiter.
Nur das mit dem Pi funzt nicht so richtig.

Public Sub exportToExcel()
    Dim oParams As Parameters
    Dim sDocName As String
    Dim i As Long
    Dim iRow As Long
    Const Pi As Long = 3.14159265358979
    '3,1415926535897932
   

   
    'Next 3 declarations commented during production.
    ' Uncomment during development, but need reference to Excel (Tools>References>microsoft Excel 10.0 Object libary
    'This way no Reference to Excel required (more stable and Excel version independent
    'See also Note: OPEN_EXCEL.
'    Dim XL As New Excel.Application
'    Dim xlWB As Excel.Workbook
'    Dim xlWS As Excel.WorkSheet
    Dim XL As Object
    Dim xlWB As Object
    Dim xlWS As Object
   
   
   
    If ThisApplication.ActiveDocumentType <> kAssemblyDocumentObject And _
        ThisApplication.ActiveDocumentType <> kPartDocumentObject Then
        MsgBox "Only Part or Assymbly document", vbCritical
        Exit Sub
    End If
    Set oParams = ThisApplication.ActiveDocument.ComponentDefinition.Parameters
   
   
    'Connect to Excel, and create a new Workbook
    'Note: OPEN_EXCEL.
    Set XL = CreateObject("Excel.Application")
    Set xlWB = XL.Workbooks.Add
    Set xlWS = xlWB.ActiveSheet
    XL.Visible = True
   
    'Write the Header Row
    iRow = 1
    xlWS.Cells(iRow, 1).Value = "Type"
    xlWS.Cells(iRow, 2).Value = "Name"
    xlWS.Cells(iRow, 3).Value = "Unit"
    xlWS.Cells(iRow, 4).Value = "Equation"
    xlWS.Cells(iRow, 5).Value = "Nennwert"
    xlWS.Cells(iRow, 6).Value = "Export"
    xlWS.Cells(iRow, 7).Value = "Health"

    'Some Excel formatting:
    '1. Freeze Header row
    '2. Header Bold and bigger fontsize
    xlWS.Rows("2:2").Select
    XL.ActiveWindow.FreezePanes = True
    xlWS.Rows("1:1").Select
    XL.Selection.Font.Bold = True
    With XL.Selection.Font
        .Name = "Arial"
        .Size = 14
        .Bold = True
    End With


    For i = 1 To oParams.Count
        iRow = iRow + 1
        Select Case oParams.Item(i).Type
            Case kModelParameterObject
                xlWS.Cells(iRow, 1).Value = "Model"
            Case kUserParameterObject
                xlWS.Cells(iRow, 1).Value = "User"
            Case kTableParameterObject
                xlWS.Cells(iRow, 1).Value = "Table"
        End Select
        xlWS.Cells(iRow, 2).Value = oParams.Item(i).Name
        xlWS.Cells(iRow, 3).Value = oParams.Item(i).Units
        xlWS.Cells(iRow, 4).Value = oParams.Item(i).Expression
       
        Select Case oParams.Item(i).Units
            Case "mm"
                xlWS.Cells(iRow, 5).Value = FormatNumber(oParams.Item(i).Value * 10, 4) & " mm"
            Case "grd"
                xlWS.Cells(iRow, 5).Value = FormatNumber(oParams.Item(i).Value * 180 / 3.14159265358979, 4) & " °"
            Case "oE"
                xlWS.Cells(iRow, 5).Value = FormatNumber(oParams.Item(i).Value, 1) & " oE"
            Case Else
                xlWS.Cells(iRow, 5).Value = oParams.Item(i).Value
        End Select
                   
               
               
        xlWS.Cells(iRow, 6).Value = oParams.Item(i).ExposedAsProperty
       
        Select Case oParams.Item(i).HealthStatus
            Case kDeletedHealth
                xlWS.Cells(iRow, 7).Value = "Deleted"
            Case kDriverLostHealth
                xlWS.Cells(iRow, 7).Value = "Driver Lost"
            Case kInErrorHealth
                xlWS.Cells(iRow, 7).Value = "In Error"
            Case kOutOfDateHealth
                xlWS.Cells(iRow, 7).Value = "Out of Date"
            Case kUnknownHealth
                xlWS.Cells(iRow, 7).Value = "Unknown"
            Case kUpToDateHealth
                xlWS.Cells(iRow, 7).Value = "Up to Date"
        End Select
    Next
   
    'Format the entire page so cell contents fit
    XL.Cells.Select
    XL.Cells.EntireColumn.AutoFit
    xlWS.Range("A1").Select
   
    'save this XL document, default to Inventor location and name
    sDocName = ThisApplication.ActiveDocument.FullFileName
    If sDocName = "" Then
        sDocName = "c:\temp\x"
    Else
        sDocName = Mid(sDocName, 1, Len(sDocName) - 4)
    End If
    If Dir(sDocName & ".xls") <> "" Then
        i = 1
        Do While Dir(sDocName & "_" & i & ".xls") <> ""
            i = i + 1
        Loop
        sDocName = sDocName & "_" & i
    End If
    xlWB.SaveAs FileName:=sDocName
   
    'detach from XL
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set XL = Nothing
   

End Sub

------------------
Gruß
Hans-Peter
Der Wahnsinn in Sachen Musik.

  Das Saxregister
 

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

lbcad
Ehrenmitglied V.I.P. h.c.
Dipl.-Ing. Maschinenbau und CAD-Trainer



Sehen Sie sich das Profil von lbcad an!   Senden Sie eine Private Message an Lothar Boekels  Schreiben Sie einen Gästebucheintrag für Lothar Boekels

Beiträge: 3794
Registriert: 15.02.2001

erstellt am: 06. Apr. 2005 09:01    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für SHP 10 Unities + Antwort hilfreich

Hallo Hans-Peter,

das falsche Ergebnis kommt durch die gewählte Typvereinbarung in Verbindung mit der Rechenreihenfoge zustande. In welcher Gewichtung das allerdings eine Rolle spielt, kann ich Dir aus dem Stand nicht sagen.

wenn Du Pi als:

  Const Pi As Double = 3.14159265358979

und in der Berechnung

    xlWS.Cells(iRow, 5).Value = FormatNumber(oParams.Item(i).Value * (180 / Pi), 4) & " °"

verwendest, dann ist das Ergebnis korrekt.

------------------
Gruß Lothar

---------------------------------------------------

Während man es aufschiebt, verrinnt das Leben.
—Lucius Annaeus Seneca (ca. 4 v. Chr - 65 n. Chr.)

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



Bauingenieure (m/w/d) für die Betonfertigteilkonstruktion

GOLDBECK?realisiert zukunftsweisende Immobilien in Europa. Wir verstehen Gebäude als Produkte und bieten alle Leistungen aus einer Hand: vom Design über den Bau bis zu Services im Betrieb. Aktuell beschäftigt unser Familienunternehmen mehr als 12.000 Mitarbeitende an über 100 Standorten bei einer?Gesamtleistung von über 6 Mrd. Euro. Unser Anspruch ?building?excellence? steht dabei für Spitzenleistungen ...

Anzeige ansehenBauwesen
SHP
Mitglied
Konstrukteur


Sehen Sie sich das Profil von SHP an!   Senden Sie eine Private Message an SHP  Schreiben Sie einen Gästebucheintrag für SHP

Beiträge: 1331
Registriert: 17.07.2003

IV9-SP3
IV10-Sp3a
IV11

erstellt am: 06. Apr. 2005 11:30    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities


export_ExportParamsToExcel.zip

 
@Ibcad,
genau das wars.
Danke

hier der Code.

------------------
Gruß
Hans-Peter 
Der Wahnsinn in Sachen Musik.

   Das Saxregister
  

[Diese Nachricht wurde von SHP am 09. Apr. 2005 editiert.]

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

Anzeige.:

Anzeige: (Infos zum Werbeplatz >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!

Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2023 CAD.de | Impressum | Datenschutz