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........

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

Rploughe over 8 years ago

example archive.zip

Here is a zip file with a text document for the code, and an example excel file of the results.

Apparently there is an error in the code, which is observed in the excel file.

On one of the job tabs, if you scroll to the right you will see an insert of a blank line which throws the data off.
i didn't catch this right away. I also don't know the culprit.

Anyone have time to look into it? I will be puzzling through it.

I fixed this problem.
I removed the second section as an "Else" and just made it another if.
Everything runs fine.

I have also incorporated reporting out profile Min/Max values and include a bonus column for TP values.

Attached Files

example archive.zip
Cancel
Vote Up 0 Vote Down

Sign in to reply

Cancel