hexagon logo
Register Sign in
  • Replies 10 replies
  • Subscribers 33 subscribers
  • Views 544 views
  • Users 0 members are here
Options
Related

VB output to excel

Nano Vujkovic
I have a script that i found on here somewhere that creates excel reports and imports all the data in rows. I would like for the data to be imported in columns. I tried it by changing all the row commands to column and all column commands to row, but with no success. What am i doing wrong?

Also, what did the Let and Set assignment statements change to or what they have been replaced with?

Thanks
  • Are their coordinates? e.g. "place this in cell (3,5)"?

    Maybe try reversing the order (5,3)
  • Unfortunately not.
    This is the code i'm using. I got this from here years ago but never played with it until now. 

    Sub Main


'xl Declarations
Dim xlApp As Object
Dim xlWorkbooks As Object
Dim xlWorkbook As Object
Dim xlSheet As Object
Dim count As Integer


'pcdlrn declarations And Open ppg
Dim App As Object
Set App = CreateObject("PCDLRN.Application")
Dim Part As Object
Set Part = App.ActivePartProgram
Dim Cmds As Object
Set Cmds = Part.Commands
Dim Cmd As Object
Dim DCmd As Object
Dim DcmdID As Object
Dim DimID As String
Dim fs As Object
Dim ReportDim As String
Dim CheckDim As String

'Check To see If results file exists
FilePath = "C:\Excel Data\"
Set fs = CreateObject("Scripting.FileSystemObject") 
ResFileExists = fs.fileexists(FilePath & Part.partname & ".xls")


'Open Excel And Base form
Set xlApp = CreateObject("Excel.Application")
Set xlWorkbooks = xlapp.Workbooks
If ResFileExists = False Then
    TempFilename = FilePath & "Loop Template.xls"
Else
    TempFilename = FilePath & Part.partname & ".xls"
End If
Set xlWorkbook = xlWorkbooks.Open(TempFilename)
Set xlSheet = xlWorkbook.Worksheets("Sheet1") 


If ResFileExists = False Then
    RCount=6
    CCount=3
    xlSheet.Range("B1").Value = Part.PartName
    xlSheet.Range("A6").Value = Date() & " " & Time()

    For Each Cmd In Cmds
        'Eliminate DATDEF's
        If Cmd.Type <> 1299 Then
            'Do Dimensions
            If Cmd.IsDimension Then
                If Cmd.Type = DIMENSION_START_LOCATION Or Cmd.Type = DIMENSION_TRUE_START_POSITION Then
                    Set DcmdID = Cmd.DimensionCommand
                      DimID = DcmdID.ID
                      ReportDim = Cmd.GetText ( OUTPUT_TYPE, 0)
                End If
                If Cmd.Type <> DIMENSION_START_LOCATION And Cmd.Type <> DIMENSION_END_LOCATION And _
                    Cmd.Type <> DIMENSION_TRUE_START_POSITION And Cmd.Type <> DIMENSION_TRUE_END_POSITION Then
                    Set DCmd = Cmd.DimensionCommand
                    CheckDim = Cmd.GetText ( OUTPUT_TYPE, 0)
                    If CheckDim <> "" Then
                            ReportDim = CheckDim
                    End If
                    If ReportDim = "BOTH" Or ReportDim = "STATS" Then
                        If DCmd.ID = "" Then
                                xlSheet.Cells(5,CCount).Value = DimID
                        Else
                                xlSheet.Cells(5,CCount).Value = DCmd.ID
                        End If
                                xlSheet.Cells(2,CCount).Value = DCmd.Nominal
                                xlSheet.Cells(3,CCount).Value = DCmd.Plus
                                xlSheet.Cells(4,CCount).Value = DCmd.Minus
                                'Measured Or Deviation With check For True Position+
                      If DCmd.AxisLetter <> "TP" Then
                                  xlSheet.Cells(6,CCount).Value = DCmd.Measured
                Else
                                  xlSheet.Cells(6,CCount).Value = DCmd.Deviation
                End If
                                'Add Min/Max For Profile dimensions
                                If Cmd.Type = 1118 Or Cmd.Type = 1105 Then
                                  CCount=CCount+1
                                  xlSheet.Cells(5,CCount).Value = DCmd.ID & "." & "Max"
                                  xlSheet.Cells(2,CCount).Value = DCmd.Nominal
                                  xlSheet.Cells(3,CCount).Value = DCmd.Plus
                                  xlSheet.Cells(4,CCount).Value = DCmd.Minus
                                  xlSheet.Cells(6,CCount).Value = DCmd.Max
                                  CCount=CCount+1
                                  xlSheet.Cells(5,CCount).Value = DCmd.ID & "." & "Min"
                                  xlSheet.Cells(2,CCount).Value = DCmd.Nominal
                                  xlSheet.Cells(3,CCount).Value = DCmd.Plus
                                  xlSheet.Cells(4,CCount).Value = DCmd.Minus
                                  xlSheet.Cells(6,CCount).Value = DCmd.Min
                                End If
                                CCount=CCount+1
                    End If
                End If
            End If
            'Do GDT
            If Cmd.Type = 184 Then
                  ReportDim = Cmd.GetText ( OUTPUT_TYPE, 0)
                  If ReportDim = "BOTH" Or ReportDim = "STATS" Then
                        xlSheet.Cells(5,CCount).Value = Cmd.GetText (ID, 0) & "." & "FCF"
                        xlSheet.Cells(2,CCount).Value = "0"
                        xlSheet.Cells(3,CCount).Value = Cmd.GetText (LINE2_PLUSTOL, 1)
                        xlSheet.Cells(4,CCount).Value = "0"
                        xlSheet.Cells(6,CCount).Value = Cmd.GetText (LINE2_DEV, 1)
                        CCount=CCount+1
                  End If
            End If
        End If
    Next Cmd


Else

'Find first Open column.
RCount=6
Found=0
Do Until Found = 1
RCount = RCount + 1
If xlSheet.Cells(RCount,1).Value = "" Then
Found=1
End If
Loop

xlSheet.Cells(RCount,1).Value = Date() & " " & Time()

'Fill In measured data
CCount = 3
    For Each Cmd In Cmds
        'Eliminate DATDEF's
        If Cmd.Type <> 1299 Then
            'Do Dimensions
            If Cmd.IsDimension Then
                If Cmd.Type = DIMENSION_START_LOCATION Or Cmd.Type = DIMENSION_TRUE_START_POSITION Then
                    Set DcmdID = Cmd.DimensionCommand
                      DimID = DcmdID.ID
                      ReportDim = Cmd.GetText ( OUTPUT_TYPE, 0)
                End If
                If Cmd.Type <> DIMENSION_START_LOCATION And Cmd.Type <> DIMENSION_END_LOCATION And _
                    Cmd.Type <> DIMENSION_TRUE_START_POSITION And Cmd.Type <> DIMENSION_TRUE_END_POSITION Then
                    Set DCmd = Cmd.DimensionCommand
                    CheckDim = Cmd.GetText ( OUTPUT_TYPE, 0)
                    If CheckDim <> "" Then
                            ReportDim = CheckDim
                    End If
                    If ReportDim = "BOTH" Or ReportDim = "STATS" Then
                                'Measured Or Deviation With check For True Position
                              If DCmd.AxisLetter <> "TP" Then
                                  xlSheet.Cells(RCount,CCount).Value = DCmd.Measured
                Else
                                  xlSheet.Cells(RCount,CCount).Value = DCmd.Deviation
                End If
                                'Add Min/Max For Profile dimensions
                                If Cmd.Type = 1118 Or Cmd.Type = 1105 Then
                                  CCount=CCount+1
                                  xlSheet.Cells(RCount,CCount).Value = DCmd.Max
                                  CCount=CCount+1
                                  xlSheet.Cells(RCount,CCount).Value = DCmd.Min
                                End If
                       Ccount=Ccount+1
                    End If
                End If
            End If
            'Do GDT
            If Cmd.Type = 184 Then
                  ReportDim = Cmd.GetText ( OUTPUT_TYPE, 0)
                  If ReportDim = "BOTH" Or ReportDim = "STATS" Then
                        xlSheet.Cells(RCount,CCount).Value = Cmd.GetText (ID, 0) & "." & "FCF"
                        xlSheet.Cells(RCount,CCount).Value = "0"
                        xlSheet.Cells(RCount,CCount).Value = Cmd.GetText (LINE2_PLUSTOL, 1)
                        xlSheet.Cells(RCount,CCount).Value = "0"
                        xlSheet.Cells(RCount,CCount).Value = Cmd.GetText (LINE2_DEV, 1)
                        CCount=CCount+1
                  End If
            End If
        End If
    Next Cmd
End If


'Save And Cleanup
Set xlSheet = Nothing 
SaveName = FilePath & Part.partname & ".xls"
If ResFileExists = False Then
xlWorkBook.SaveAs SaveName
Else
xlWorkBook.Save
End If
xlWorkbook.Close
Set xlWorkbook = Nothing 
xlWorkbooks.Close 
Set xlWorkbooks = Nothing 
xlApp.Quit 
Set xlApp = Nothing

LabelEnd:

End Sub
  • As says, swap the rows and columns in xlSheet.Cells( RCount,CCount) to xlSheet.Cells( CCount,RCount) and any xlSheet.Range(" B1") to xlSheet.Range(" A2") (the letter B becomes the number 2, the number 1 becomes the letter A, and they swap place).
  • As says, swap the rows and columns in xlSheet.Cells( RCount,CCount) to xlSheet.Cells( CCount,RCount) and any xlSheet.Range(" B1") to xlSheet.Range(" A2") (the letter B becomes the number 2, the number 1 becomes the letter A, and they swap place).

    I already tried that with no success.
  • The "reverse" script 

    Sub Main  (strVariable As String)


'xl Declarations
Dim xlApp As Object
Dim xlWorkbooks As Object
Dim xlWorkbook As Object
Dim xlSheet As Object
Dim count As Integer


'pcdlrn declarations And Open ppg
Dim App As Object
Set App = CreateObject("PCDLRN.Application")
Dim Part As Object
Set Part = App.ActivePartProgram
Dim Cmds As Object
Set Cmds = Part.Commands
Dim Cmd As Object
Dim DCmd As Object
Dim DcmdID As Object
Dim DimID As String
Dim fs As Object
Dim ReportDim As String
Dim CheckDim As String


'Check To see If results file exists
FilePath = "C:\Excel Data\"
Set fs = CreateObject("Scripting.FileSystemObject")
ResFileExists = fs.fileexists(FilePath & Part.partname & " " &  strVariable & ".xls")


'Open Excel And Base form
Set xlApp = CreateObject("Excel.Application")
Set xlWorkbooks = xlapp.Workbooks
If ResFileExists = False Then
    TempFilename = FilePath & "Loop Template Column.xls"
Else
    TempFilename = FilePath & Part.partname & " " &  strVariable & ".xls"
End If
Set xlWorkbook = xlWorkbooks.Open(TempFilename)
Set xlSheet = xlWorkbook.Worksheets("Sheet1")


If ResFileExists = False Then
    CCount=6
    RCount=3
    xlSheet.Range("B1").Value = Part.PartName
    xlSheet.Range("A6").Value = Date() & " " & Time()
    xlSheet.Range("D1").Value = strVariable


    For Each Cmd In Cmds
        'Eliminate DATDEF's
        If Cmd.Type <> 1299 Then
            'Do Dimensions
            If Cmd.IsDimension Then
                If Cmd.Type = DIMENSION_START_LOCATION Or Cmd.Type = DIMENSION_TRUE_START_POSITION Then
                    Set DcmdID = Cmd.DimensionCommand
                      DimID = DcmdID.ID
                      ReportDim = Cmd.GetText ( OUTPUT_TYPE, 0)
                End If
                If Cmd.Type <> DIMENSION_START_LOCATION And Cmd.Type <> DIMENSION_END_LOCATION And _
                    Cmd.Type <> DIMENSION_TRUE_START_POSITION And Cmd.Type <> DIMENSION_TRUE_END_POSITION Then
                    Set DCmd = Cmd.DimensionCommand
                    CheckDim = Cmd.GetText ( OUTPUT_TYPE, 0)
                    If CheckDim <> "" Then
                            ReportDim = CheckDim
                    End If
                    If ReportDim = "BOTH" Or ReportDim = "STATS" Then
                        If DCmd.ID = "" Then
                                xlSheet.Cells(5,RCount).Value = DimID
                        Else
                                xlSheet.Cells(5,RCount).Value = DCmd.ID
                        End If
                                xlSheet.Cells(2,RCount).Value = DCmd.Nominal
                                xlSheet.Cells(3,RCount).Value = DCmd.Plus
                                xlSheet.Cells(4,RCount).Value = DCmd.Minus
                                'Measured Or Deviation With check For True Position
                      If DCmd.AxisLetter <> "TP" Then
                                  xlSheet.Cells(6,RCount).Value = DCmd.Measured
                Else
                                  xlSheet.Cells(6,RCount).Value = DCmd.Deviation
                End If
                                'Add Min/Max For Profile dimensions
                                If Cmd.Type = 1118 Or Cmd.Type = 1105 Then
                                  RCount=RCount+1
                                  xlSheet.Cells(5,RCount).Value = DCmd.ID & "." & "Max"
                                  xlSheet.Cells(2,RCount).Value = DCmd.Nominal
                                  xlSheet.Cells(3,RCount).Value = DCmd.Plus
                                  xlSheet.Cells(4,RCount).Value = DCmd.Minus
                                  xlSheet.Cells(6,RCount).Value = DCmd.Max
                                  RCount=RCount+1
                                  xlSheet.Cells(5,RCount).Value = DCmd.ID & "." & "Min"
                                  xlSheet.Cells(2,RCount).Value = DCmd.Nominal
                                  xlSheet.Cells(3,RCount).Value = DCmd.Plus
                                  xlSheet.Cells(4,RCount).Value = DCmd.Minus
                                  xlSheet.Cells(6,RCount).Value = DCmd.Min
                                End If
                                RCount=RCount+1
                    End If
                End If
            End If
            'Do GDT
            If Cmd.Type = 184 Then
                  ReportDim = Cmd.GetText ( OUTPUT_TYPE, 0)
                  If ReportDim = "BOTH" Or ReportDim = "STATS" Then
                        xlSheet.Cells(5,RCount).Value = Cmd.GetText (ID, 0) & "." & "FCF"
                        xlSheet.Cells(2,RCount).Value = "0"
                        xlSheet.Cells(3,RCount).Value = Cmd.GetText (LINE2_PLUSTOL, 1)
                        xlSheet.Cells(4,RCount).Value = "0"
                        xlSheet.Cells(6,RCount).Value = Cmd.GetText (LINE2_DEV, 1)
                        RCount=RCount+1
                  End If
            End If
        End If
    Next Cmd


Else

'Find first Open column.
CCount=6
Found=0
Do Until Found = 1
CCount = CCount + 1
If xlSheet.Cells(CCount,1).Value = "" Then
Found=1
End If
Loop

xlSheet.Cells(CCount,1).Value = Date() & " " & Time()

'Fill In measured data
RCount = 3
    For Each Cmd In Cmds
        'Eliminate DATDEF's
        If Cmd.Type <> 1299 Then
            'Do Dimensions
            If Cmd.IsDimension Then
                If Cmd.Type = DIMENSION_START_LOCATION Or Cmd.Type = DIMENSION_TRUE_START_POSITION Then
                    Set DcmdID = Cmd.DimensionCommand
                      DimID = DcmdID.ID
                      ReportDim = Cmd.GetText ( OUTPUT_TYPE, 0)
                End If
                If Cmd.Type <> DIMENSION_START_LOCATION And Cmd.Type <> DIMENSION_END_LOCATION And _
                    Cmd.Type <> DIMENSION_TRUE_START_POSITION And Cmd.Type <> DIMENSION_TRUE_END_POSITION Then
                    Set DCmd = Cmd.DimensionCommand
                    CheckDim = Cmd.GetText ( OUTPUT_TYPE, 0)
                    If CheckDim <> "" Then
                            ReportDim = CheckDim
                    End If
                    If ReportDim = "BOTH" Or ReportDim = "STATS" Then
                                'Measured Or Deviation With check For True Position
                              If DCmd.AxisLetter <> "TP" Then
                                  xlSheet.Cells(CCount,RCount).Value = DCmd.Measured
                Else
                                  xlSheet.Cells(CCount,RCount).Value = DCmd.Deviation
                End If
                                'Add Min/Max For Profile dimensions
                                If Cmd.Type = 1118 Or Cmd.Type = 1105 Then
                                  RCount=RCount+1
                                  xlSheet.Cells(CCount,RCount).Value = DCmd.Max
                                  RCount=RCount+1
                                  xlSheet.Cells(CCount,RCount).Value = DCmd.Min
                                End If
                       Rcount=Rcount+1
                    End If
                End If
            End If
            'Do GDT
            If Cmd.Type = 184 Then
                  ReportDim = Cmd.GetText ( OUTPUT_TYPE, 0)
                  If ReportDim = "BOTH" Or ReportDim = "STATS" Then
                        xlSheet.Cells(CCount,RCount).Value = Cmd.GetText (ID, 0) & "." & "FCF"
                        xlSheet.Cells(CCount,RCount).Value = "0"
                        xlSheet.Cells(CCount,RCount).Value = Cmd.GetText (LINE2_PLUSTOL, 1)
                        xlSheet.Cells(CCount,RCount).Value = "0"
                        xlSheet.Cells(CCount,RCount).Value = Cmd.GetText (LINE2_DEV, 1)
                        RCount=RCount+1
                  End If
            End If
        End If
    Next Cmd
End If


'Save And Cleanup
Set xlSheet = Nothing
SaveName = FilePath & Part.partname & " " & strVariable  & ".xls"
If ResFileExists = False Then
xlWorkBook.SaveAs SaveName
Else
xlWorkBook.Save
End If
xlWorkbook.Close
Set xlWorkbook = Nothing
xlWorkbooks.Close
Set xlWorkbooks = Nothing
xlApp.Quit
Set xlApp = Nothing

LabelEnd:

End Sub


    With some other changes.
  • Silly me. I missed a bunch of CCount and RCount commands to be flipped. I think i'm on the right track now.
  • in reply to Nano Vujkovic
    Why can't I write the measurement data?
  • in reply to Nano Vujkovic

    hello

    Does this actually work with geometric tolerance commands?

    It looks to me as if you only have one query for “exact measurement” and another for "dimmension commands".

    is that intended?

    Please post your latest version of this script

  • in reply to Henniger123

    This is 6 years old, he may not reply. Hope he does.

© 2024 Hexagon AB and/or its subsidiaries. Privacy Policy | Cloud Services Agreement