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 8 years ago

Second Half

Else 'If ResFileExists = False Then
    If objFSO.FileExists(ResFileExists) = True Then 
		RCount = 11
		Found = 0
        Counter = 11
		Do Until Found = 1
			RCount = RCount + 1
			If xlSheet.Cells(RCount,1).Value = "" Then
				Found=Found+1
			End If
		Loop
		Samp = Part.GetVariableValue("SAMP")
        Opper = Part.GetVariableValue("OPERATOR")
        xlSheet.Cells(RCount, 1).Value = "Operator : " & Opper.StringValue
        Do Until Counter = Rcount
            If Len(xlSheet.Cells(RCount, 1).Value) > Len(xlSheet.Cells(Counter, 1).Value) Then
                WidthSet = xlSheet.Cells(RCount, 1).Columns.AutoFit()
            End If
            Counter = Counter +1
        Loop
        xlSheet.Cells(RCount, 2).Value = "Sample # : " & Samp.StringValue
		'Fill In measured data
		CCount = 3
		For Each Cmd In Cmds
			'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


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 = "--"
			xlsheet.cells(Rcount+0,Ccount).Value = fncsheet.Max(xlsheet.Range(xlsheet.cells(Scount,Ccount),(xlsheet.cells(Scount+Tcount,Ccount))))
			xlsheet.cells(Rcount+1,Ccount).Value = fncsheet.Min(xlsheet.Range(xlsheet.cells(Scount,Ccount),(xlsheet.cells(Scount+Tcount,Ccount))))
			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))))
			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)
			xlsheet.cells(Rcount+7,Ccount).Value = "--"
			xlsheet.cells(Rcount+8,Ccount).Value = "--"
			
			Set Maxi = xlsheet.cells(Rcount+0,Ccount).Value
			Set Mini = xlsheet.cells(Rcount+1,Ccount).Value
			Set Aver = xlsheet.cells(Rcount+4,Ccount).Value
			Set Std = xlsheet.cells(Rcount+6,Ccount).Value
			Set USL = xlsheet.cells(9,Ccount).Value
			Set LSL = xlsheet.cells(10,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


'Save And Cleanup


If objFSO.FileExists(ResFileExists) = False Then
    xlWorkBook.SaveAs ResFileExists
Else
    xlWorkBook.Save
End If


xlApp.Application.Visible = False
App.Visible = True
Set xlSheet = Nothing 
Set xlSheets = 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 xlSheets = Nothing 
Set xlWorkbook = Nothing 
Set xlWorkbooks = Nothing 
Set xlApp = Nothing


End Sub

Reply

Rploughe over 8 years ago

Second Half

Else 'If ResFileExists = False Then
    If objFSO.FileExists(ResFileExists) = True Then 
		RCount = 11
		Found = 0
        Counter = 11
		Do Until Found = 1
			RCount = RCount + 1
			If xlSheet.Cells(RCount,1).Value = "" Then
				Found=Found+1
			End If
		Loop
		Samp = Part.GetVariableValue("SAMP")
        Opper = Part.GetVariableValue("OPERATOR")
        xlSheet.Cells(RCount, 1).Value = "Operator : " & Opper.StringValue
        Do Until Counter = Rcount
            If Len(xlSheet.Cells(RCount, 1).Value) > Len(xlSheet.Cells(Counter, 1).Value) Then
                WidthSet = xlSheet.Cells(RCount, 1).Columns.AutoFit()
            End If
            Counter = Counter +1
        Loop
        xlSheet.Cells(RCount, 2).Value = "Sample # : " & Samp.StringValue
		'Fill In measured data
		CCount = 3
		For Each Cmd In Cmds
			'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


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 = "--"
			xlsheet.cells(Rcount+0,Ccount).Value = fncsheet.Max(xlsheet.Range(xlsheet.cells(Scount,Ccount),(xlsheet.cells(Scount+Tcount,Ccount))))
			xlsheet.cells(Rcount+1,Ccount).Value = fncsheet.Min(xlsheet.Range(xlsheet.cells(Scount,Ccount),(xlsheet.cells(Scount+Tcount,Ccount))))
			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))))
			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)
			xlsheet.cells(Rcount+7,Ccount).Value = "--"
			xlsheet.cells(Rcount+8,Ccount).Value = "--"
			
			Set Maxi = xlsheet.cells(Rcount+0,Ccount).Value
			Set Mini = xlsheet.cells(Rcount+1,Ccount).Value
			Set Aver = xlsheet.cells(Rcount+4,Ccount).Value
			Set Std = xlsheet.cells(Rcount+6,Ccount).Value
			Set USL = xlsheet.cells(9,Ccount).Value
			Set LSL = xlsheet.cells(10,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


'Save And Cleanup


If objFSO.FileExists(ResFileExists) = False Then
    xlWorkBook.SaveAs ResFileExists
Else
    xlWorkBook.Save
End If


xlApp.Application.Visible = False
App.Visible = True
Set xlSheet = Nothing 
Set xlSheets = 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 xlSheets = Nothing 
Set xlWorkbook = Nothing 
Set xlWorkbooks = Nothing 
Set xlApp = Nothing


End Sub

Children

No Data