| | | Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte | | | | Request a special discount on NVIDIA RTX 5000 Ada Generation GPU !, eine Pressemitteilung
|
Autor
|
Thema: Export Parameters to Excel (3661 mal gelesen)
|
SHP Mitglied Konstrukteur
Beiträge: 1331 Registriert: 17.07.2003 IV9-SP3 IV10-Sp3a IV11
|
erstellt am: 05. Apr. 2005 20:43 <-- editieren / zitieren --> Unities abgeben:
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
Beiträge: 1331 Registriert: 17.07.2003 IV9-SP3 IV10-Sp3a IV11
|
erstellt am: 05. Apr. 2005 23:46 <-- editieren / zitieren --> Unities abgeben:
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
Beiträge: 3833 Registriert: 15.02.2001 DELL Precision 7520 Win10Pro-64 Inventor mit Vault Professional 2024 --------------------- Während man es aufschiebt, verrinnt das Leben. Lucius Annaeus Seneca (ca. 4 v. Chr - 65 n. Chr.)
|
erstellt am: 06. Apr. 2005 09:01 <-- editieren / zitieren --> Unities abgeben: Nur für SHP
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 |
SHP Mitglied Konstrukteur
Beiträge: 1331 Registriert: 17.07.2003 IV9-SP3 IV10-Sp3a IV11
|
erstellt am: 06. Apr. 2005 11:30 <-- editieren / zitieren --> Unities abgeben:
|
| Anzeige.:
Anzeige: (Infos zum Werbeplatz >>)
|