PC-Dmis to Excel, through PC-Dmis Script

I know there is currently a VB project that runs in Excel during execution that will pull information into the workbook during execution. I decided to venture out and try some of my own approaches with a combination of data I found online here and there.

What I have is a script that can be executed in program, without too much setup and hassle, that will export data into an excel workbook like a print command would. I feel this script offers a little more versatility.

I will not claim ownership of this program. I just tweaked it to fit my needs. So far I have it running, and it works quite well.

I will answer what questions I can, but for the most part I wanted to post it to have as a reference.

It's a long program........

Parents

Rploughe over 9 years ago

Drop-In Script Part3


Else 'If ResFileExists = False Then
    If objFSO.FileExists(ResFileExists) = True Then 
         RCount = 11
         Found = 0
         Do Until Found = 1
              RCount = RCount + 1
              If xlSheet.Cells(RCount,1).Value = "" Then
                   Found=Found+1
              End If
         Loop
         xlSheet.Cells(RCount, 1).Value = "Sample # :"
         xlSheet.Cells(RCount, 2).Value = Samp.StringValue
         'Fill In measured data
         CCount = 3
         i = 0
         For Each Cmd In Cmds
              i = i + 1
              App.StatusBar = "Cycling through commands. Current command: " & i
              'Do GDT
              If Cmd.Type = 184 Then ' FCF
                   ReportDim = Cmd.GetText(OUTPUT_TYPE, 0)
                   If ReportDim = "BOTH" Or ReportDim = "REPORT" Then
                        xlSheet.Cells(RCount, CCount).Value = fncsheet.Round(Cmd.GetText(LINE2_DEV, 1),6)
                        If xlsheet.Cells(RCount,CCount).value > xlsheet.cells(9,Ccount).Value Or _
                             xlsheet.Cells(RCount,CCount).value < xlsheet.cells(10,Ccount).Value Then
                             xlsheet.Cells(RCount,Ccount).Interior.ColorIndex = 38
                        End If
                   End If 'ReportDim = "BOTH" Or ReportDim = "REPORT" 
                   CCount = CCount + 1
              End If
              '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 And _
                        Cmd.Type <> DATDEF_COMMAND Then
                        Set DCmd = Cmd.DimensionCommand
                        CheckDim = Cmd.GetText ( OUTPUT_TYPE, 0)
                        If CheckDim <> "" Then
                             ReportDim = CheckDim
                        End If
                        If ReportDim = "BOTH" Or ReportDim = "REPORT" Then
                             Set PlusTol =  xlSheet.Cells(9, CCount).Value
                             Set MinusTol = xlSheet.Cells(10, CCount).Value
                             'Measured Or Deviation With check For True Position
                             If DCmd.AxisLetter <> "TP" Then
                                  Set Meas = Abs(fncsheet.Round(DCmd.Measured,6))
                                  xlSheet.Cells(RCount, CCount).Value = Meas
                                  If Meas > PlusTol Or _
                                  Meas < MinusTol Then
                                       xlsheet.Cells(RCount,Ccount).Interior.ColorIndex = 38
                                  End If
                             Else
                                  Set Meas = Abs(fncsheet.Round(DCmd.Deviation,6))
                                  xlSheet.Cells(RCount, CCount).Value = Meas
                                  If Meas > PlusTol Or _
                                  Meas < MinusTol Then
                                       xlsheet.Cells(RCount,Ccount).Interior.ColorIndex = 38
                                  End If
                             End If 'DCmd.AxisLetter <> "TP" 
                             'Add For Profile dimensions
                             If Cmd.Type = 1118 Or Cmd.Type = 1105 Then
                                  Set Meas = Abs(fncsheet.Round(DCmd.Deviation,6))
                                  xlSheet.Cells(RCount, CCount).Value = Meas
                                  If Meas > PlusTol Or _
                                  Meas < MinusTol Then
                                       xlsheet.Cells(RCount,Ccount).Interior.ColorIndex = 38
                                  End If
                             End If 'Cmd.Type = 1118 Or Cmd.Type = 1105 
                        End If 'ReportDim = "BOTH" Or ReportDim = "REPORT"
                        CCount = CCount + 1
                   End If
              End If
         Next Cmd
    End If
End If 'If ResFileExists = False Then
'Optional sheet functions used For data gathering.  'Will Not work If there are blank values.  Delete out the following Or use As needed.
If objFSO.FileExists(ResFileExists) = True And Rcount >= 13 Then
    Dim Aver, Mini, Maxi, Std, Cp, Cpk, usl, lsl
    Dim Startcell, EndCell, Tcount, Scount
    Dim Col, lCol
    Rcount = Rcount
    Ccount = 3
    Scount = 12
    Tcount = Rcount-Scount
    Rcount = Rcount+2
    xlsheet.cells(Rcount-1,1).Value = ""
    xlsheet.cells(Rcount+0,1).Value = "Max"
    xlsheet.cells(Rcount+1,1).Value = "Min"
    xlsheet.cells(Rcount+2,1).Value = "Range"
    xlsheet.cells(Rcount+3,1).Value = "--"
    xlsheet.cells(Rcount+4,1).Value = "Average"
    xlsheet.cells(Rcount+5,1).Value = "Mean"
    xlsheet.cells(Rcount+6,1).Value = "Std Dev"
    xlsheet.cells(Rcount+7,1).Value = "--"
    'xlsheet.cells(Rcount+8,1).Value = "Cp"
    'xlsheet.cells(Rcount+9,1).Value = "CpK"
    xlsheet.cells(Rcount+8,1).Value = "Count"
    xlsheet.cells(Rcount+8,2).Value = Rcount-Scount-1
    xlsheet.cells(Rcount-1,2).Value = "--"
    xlsheet.cells(Rcount+0,2).Value = "--"
    xlsheet.cells(Rcount+1,2).Value = "--"
    xlsheet.cells(Rcount+2,2).Value = "--"
    xlsheet.cells(Rcount+3,2).Value = "--"
    xlsheet.cells(Rcount+4,2).Value = "--"
    xlsheet.cells(Rcount+5,2).Value = "--"
    xlsheet.cells(Rcount+6,2).Value = "--"
    xlsheet.cells(Rcount+7,2).Value = "--"
    'xlsheet.cells(Rcount+8,2).Value = "--"
    'xlsheet.cells(Rcount+9,2).Value = "--"
    'xlsheet.cells(Rcount+10,2).Value = "--"
    NotFound = 0
    Do Until NotFound = 1
         If xlSheet.Cells(7, CCount).Value <> "" Then ' FCF
              xlsheet.cells(Rcount-1,Ccount).Value = "--"
              Set USL = xlsheet.cells(9,Ccount).Value
              Set LSL = xlsheet.cells(10,Ccount).Value
              xlsheet.cells(Rcount+0,Ccount).Value = fncsheet.Max(xlsheet.Range(xlsheet.cells(Scount,Ccount),(xlsheet.cells(Scount+Tcount,Ccount))))
              Set Maxi = xlsheet.cells(Rcount+0,Ccount).Value
              xlsheet.cells(Rcount+1,Ccount).Value = fncsheet.Min(xlsheet.Range(xlsheet.cells(Scount,Ccount),(xlsheet.cells(Scount+Tcount,Ccount))))
              Set Mini = xlsheet.cells(Rcount+1,Ccount).Value
              'Controls Range of Meas, Max-Min
              xlsheet.cells(Rcount+2,Ccount).Value = fncsheet.Round(fncsheet.Sum(xlsheet.Cells(Rcount+0,Ccount).value,-(xlsheet.Cells(Rcount+1,Ccount).value)),6)
              xlsheet.cells(Rcount+3,Ccount).Value = "--"
              xlsheet.cells(Rcount+4,Ccount).Value = fncsheet.Average(xlsheet.Range(xlsheet.cells(Scount,Ccount),(xlsheet.cells(Scount+Tcount,Ccount))))
              Set Aver = xlsheet.cells(Rcount+4,Ccount).Value
              xlsheet.cells(Rcount+5,Ccount).Value = fncsheet.Median(xlsheet.Range(xlsheet.cells(Scount,Ccount),(xlsheet.cells(Scount+Tcount,Ccount))))
              xlsheet.cells(Rcount+6,Ccount).Value = fncsheet.Round(fncsheet.STDEVP(xlsheet.Range(xlsheet.cells(Scount,Ccount),(xlsheet.cells(Scount+Tcount,Ccount)))),6)
              Set Std = xlsheet.cells(Rcount+6,Ccount).Value
              xlsheet.cells(Rcount+7,Ccount).Value = "--"
              xlsheet.cells(Rcount+8,Ccount).Value = "--"
              'xlsheet.cells(Rcount+8,Ccount).Value =""
              'xlsheet.cells(Rcount+9,Ccount).Value =""
              'xlsheet.cells(Rcount+8,Ccount).Value = fncsheet.Round(((USL-LSL)/(6*Std)),6)
              'If LSL <> 0 Then
                   'xlsheet.cells(Rcount+9,Ccount).Value = fncsheet.Round(fncsheet.Min(((USL-Aver)/(3*Std)),((Aver-LSL)/(3*Std))),6)
              'Else
                   'xlsheet.cells(Rcount+9,Ccount).Value = fncsheet.Round((USL-Aver)/(3*Std),6)
              'End If
              'xlsheet.cells(Rcount+10,Ccount).Value = Rcount-Scount-1
              CCount = CCount + 1
              NotFound = 0
         Else 
              NotFound = 1
         End If 
    Loop
End If
'^^Optional sheet functions used For data gathering.  'Will Not work If there are blank values.  Delete out the following Or use As needed^^.
'Save And Cleanup
If objFSO.FileExists(ResFileExists) = False Then
    'If the file did Not exist originally, save the file As the Name given
    xlWorkBook.SaveAs ResFileExists
Else
    xlWorkBook.Save
End If
xlApp.Application.Visible = False
App.Visible = True
Set xlSheet = Nothing 
xlWorkbook.Close
Set xlWorkbook = Nothing 
xlWorkbooks.Close 
Set xlWorkbooks = Nothing 
xlApp.Quit
Set xlApp = Nothing
Exit Sub
ErrorCheck:
xlApp.Application.Visible = True
App.Visible = True
Set xlSheet = Nothing 
Set xlWorkbook = Nothing 
Set xlWorkbooks = Nothing 
Set xlApp = Nothing
End Sub

Reply

Rploughe over 9 years ago

Drop-In Script Part3


Else 'If ResFileExists = False Then
    If objFSO.FileExists(ResFileExists) = True Then 
         RCount = 11
         Found = 0
         Do Until Found = 1
              RCount = RCount + 1
              If xlSheet.Cells(RCount,1).Value = "" Then
                   Found=Found+1
              End If
         Loop
         xlSheet.Cells(RCount, 1).Value = "Sample # :"
         xlSheet.Cells(RCount, 2).Value = Samp.StringValue
         'Fill In measured data
         CCount = 3
         i = 0
         For Each Cmd In Cmds
              i = i + 1
              App.StatusBar = "Cycling through commands. Current command: " & i
              'Do GDT
              If Cmd.Type = 184 Then ' FCF
                   ReportDim = Cmd.GetText(OUTPUT_TYPE, 0)
                   If ReportDim = "BOTH" Or ReportDim = "REPORT" Then
                        xlSheet.Cells(RCount, CCount).Value = fncsheet.Round(Cmd.GetText(LINE2_DEV, 1),6)
                        If xlsheet.Cells(RCount,CCount).value > xlsheet.cells(9,Ccount).Value Or _
                             xlsheet.Cells(RCount,CCount).value < xlsheet.cells(10,Ccount).Value Then
                             xlsheet.Cells(RCount,Ccount).Interior.ColorIndex = 38
                        End If
                   End If 'ReportDim = "BOTH" Or ReportDim = "REPORT" 
                   CCount = CCount + 1
              End If
              '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 And _
                        Cmd.Type <> DATDEF_COMMAND Then
                        Set DCmd = Cmd.DimensionCommand
                        CheckDim = Cmd.GetText ( OUTPUT_TYPE, 0)
                        If CheckDim <> "" Then
                             ReportDim = CheckDim
                        End If
                        If ReportDim = "BOTH" Or ReportDim = "REPORT" Then
                             Set PlusTol =  xlSheet.Cells(9, CCount).Value
                             Set MinusTol = xlSheet.Cells(10, CCount).Value
                             'Measured Or Deviation With check For True Position
                             If DCmd.AxisLetter <> "TP" Then
                                  Set Meas = Abs(fncsheet.Round(DCmd.Measured,6))
                                  xlSheet.Cells(RCount, CCount).Value = Meas
                                  If Meas > PlusTol Or _
                                  Meas < MinusTol Then
                                       xlsheet.Cells(RCount,Ccount).Interior.ColorIndex = 38
                                  End If
                             Else
                                  Set Meas = Abs(fncsheet.Round(DCmd.Deviation,6))
                                  xlSheet.Cells(RCount, CCount).Value = Meas
                                  If Meas > PlusTol Or _
                                  Meas < MinusTol Then
                                       xlsheet.Cells(RCount,Ccount).Interior.ColorIndex = 38
                                  End If
                             End If 'DCmd.AxisLetter <> "TP" 
                             'Add For Profile dimensions
                             If Cmd.Type = 1118 Or Cmd.Type = 1105 Then
                                  Set Meas = Abs(fncsheet.Round(DCmd.Deviation,6))
                                  xlSheet.Cells(RCount, CCount).Value = Meas
                                  If Meas > PlusTol Or _
                                  Meas < MinusTol Then
                                       xlsheet.Cells(RCount,Ccount).Interior.ColorIndex = 38
                                  End If
                             End If 'Cmd.Type = 1118 Or Cmd.Type = 1105 
                        End If 'ReportDim = "BOTH" Or ReportDim = "REPORT"
                        CCount = CCount + 1
                   End If
              End If
         Next Cmd
    End If
End If 'If ResFileExists = False Then
'Optional sheet functions used For data gathering.  'Will Not work If there are blank values.  Delete out the following Or use As needed.
If objFSO.FileExists(ResFileExists) = True And Rcount >= 13 Then
    Dim Aver, Mini, Maxi, Std, Cp, Cpk, usl, lsl
    Dim Startcell, EndCell, Tcount, Scount
    Dim Col, lCol
    Rcount = Rcount
    Ccount = 3
    Scount = 12
    Tcount = Rcount-Scount
    Rcount = Rcount+2
    xlsheet.cells(Rcount-1,1).Value = ""
    xlsheet.cells(Rcount+0,1).Value = "Max"
    xlsheet.cells(Rcount+1,1).Value = "Min"
    xlsheet.cells(Rcount+2,1).Value = "Range"
    xlsheet.cells(Rcount+3,1).Value = "--"
    xlsheet.cells(Rcount+4,1).Value = "Average"
    xlsheet.cells(Rcount+5,1).Value = "Mean"
    xlsheet.cells(Rcount+6,1).Value = "Std Dev"
    xlsheet.cells(Rcount+7,1).Value = "--"
    'xlsheet.cells(Rcount+8,1).Value = "Cp"
    'xlsheet.cells(Rcount+9,1).Value = "CpK"
    xlsheet.cells(Rcount+8,1).Value = "Count"
    xlsheet.cells(Rcount+8,2).Value = Rcount-Scount-1
    xlsheet.cells(Rcount-1,2).Value = "--"
    xlsheet.cells(Rcount+0,2).Value = "--"
    xlsheet.cells(Rcount+1,2).Value = "--"
    xlsheet.cells(Rcount+2,2).Value = "--"
    xlsheet.cells(Rcount+3,2).Value = "--"
    xlsheet.cells(Rcount+4,2).Value = "--"
    xlsheet.cells(Rcount+5,2).Value = "--"
    xlsheet.cells(Rcount+6,2).Value = "--"
    xlsheet.cells(Rcount+7,2).Value = "--"
    'xlsheet.cells(Rcount+8,2).Value = "--"
    'xlsheet.cells(Rcount+9,2).Value = "--"
    'xlsheet.cells(Rcount+10,2).Value = "--"
    NotFound = 0
    Do Until NotFound = 1
         If xlSheet.Cells(7, CCount).Value <> "" Then ' FCF
              xlsheet.cells(Rcount-1,Ccount).Value = "--"
              Set USL = xlsheet.cells(9,Ccount).Value
              Set LSL = xlsheet.cells(10,Ccount).Value
              xlsheet.cells(Rcount+0,Ccount).Value = fncsheet.Max(xlsheet.Range(xlsheet.cells(Scount,Ccount),(xlsheet.cells(Scount+Tcount,Ccount))))
              Set Maxi = xlsheet.cells(Rcount+0,Ccount).Value
              xlsheet.cells(Rcount+1,Ccount).Value = fncsheet.Min(xlsheet.Range(xlsheet.cells(Scount,Ccount),(xlsheet.cells(Scount+Tcount,Ccount))))
              Set Mini = xlsheet.cells(Rcount+1,Ccount).Value
              'Controls Range of Meas, Max-Min
              xlsheet.cells(Rcount+2,Ccount).Value = fncsheet.Round(fncsheet.Sum(xlsheet.Cells(Rcount+0,Ccount).value,-(xlsheet.Cells(Rcount+1,Ccount).value)),6)
              xlsheet.cells(Rcount+3,Ccount).Value = "--"
              xlsheet.cells(Rcount+4,Ccount).Value = fncsheet.Average(xlsheet.Range(xlsheet.cells(Scount,Ccount),(xlsheet.cells(Scount+Tcount,Ccount))))
              Set Aver = xlsheet.cells(Rcount+4,Ccount).Value
              xlsheet.cells(Rcount+5,Ccount).Value = fncsheet.Median(xlsheet.Range(xlsheet.cells(Scount,Ccount),(xlsheet.cells(Scount+Tcount,Ccount))))
              xlsheet.cells(Rcount+6,Ccount).Value = fncsheet.Round(fncsheet.STDEVP(xlsheet.Range(xlsheet.cells(Scount,Ccount),(xlsheet.cells(Scount+Tcount,Ccount)))),6)
              Set Std = xlsheet.cells(Rcount+6,Ccount).Value
              xlsheet.cells(Rcount+7,Ccount).Value = "--"
              xlsheet.cells(Rcount+8,Ccount).Value = "--"
              'xlsheet.cells(Rcount+8,Ccount).Value =""
              'xlsheet.cells(Rcount+9,Ccount).Value =""
              'xlsheet.cells(Rcount+8,Ccount).Value = fncsheet.Round(((USL-LSL)/(6*Std)),6)
              'If LSL <> 0 Then
                   'xlsheet.cells(Rcount+9,Ccount).Value = fncsheet.Round(fncsheet.Min(((USL-Aver)/(3*Std)),((Aver-LSL)/(3*Std))),6)
              'Else
                   'xlsheet.cells(Rcount+9,Ccount).Value = fncsheet.Round((USL-Aver)/(3*Std),6)
              'End If
              'xlsheet.cells(Rcount+10,Ccount).Value = Rcount-Scount-1
              CCount = CCount + 1
              NotFound = 0
         Else 
              NotFound = 1
         End If 
    Loop
End If
'^^Optional sheet functions used For data gathering.  'Will Not work If there are blank values.  Delete out the following Or use As needed^^.
'Save And Cleanup
If objFSO.FileExists(ResFileExists) = False Then
    'If the file did Not exist originally, save the file As the Name given
    xlWorkBook.SaveAs ResFileExists
Else
    xlWorkBook.Save
End If
xlApp.Application.Visible = False
App.Visible = True
Set xlSheet = Nothing 
xlWorkbook.Close
Set xlWorkbook = Nothing 
xlWorkbooks.Close 
Set xlWorkbooks = Nothing 
xlApp.Quit
Set xlApp = Nothing
Exit Sub
ErrorCheck:
xlApp.Application.Visible = True
App.Visible = True
Set xlSheet = Nothing 
Set xlWorkbook = Nothing 
Set xlWorkbooks = Nothing 
Set xlApp = Nothing
End Sub

Children

No Data