Your Products have been synced, click here to refresh
Sub Main 'xl Declarations Dim xlApp As Object Dim xlWorkbooks As Object Dim xlWorkbook As Object Dim xlSheet As Object Dim fncSheet As Object Dim count As Integer Dim xlWorksheets As String Dim xlWorksheet As String '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 fs As Object Dim DimID As String Dim ReportDim As String Dim CheckDim As String Dim Cavity As String Dim myValue As String Dim message, title, defaultValue As String Dim FolderList$ ( ) Set Project = Part.GetVariableValue("PROJECT") myValue = Project.StringValue If myValue = "" Then myValue = InputBox("Please Input Project #","Project # Input","XXXXXX") For Each Cmd In Cmds If Cmd.Type = ASSIGNMENT Then If Cmd.GetText(DEST_EXPR,0) = "PROJECT" Then bln = Cmd.PutText("""" + myValue + """", SRC_EXPR, 0) Cmd.ReDraw End If End If Next Cmd End If Dim objFSO, objFolder, objShell, firstchar, InputFolder, found, objDLG myProject = "Project # " & myValue Dim serverpath 'Hardcoded absolute serverpath = "X:\" 'Path coded As a network directory In "My Computer" To point To projects folder 'Assign searchpath using "serverpath" Dim foldername As String Dim strDirectory Dim strDirectory1 Dim strDirectory2 Dim strDirectory3 Dim strDirectory4 Dim strDirectory5 foldername = Dir(serverpath & "*.*", 16) 'value of "16" pulls In all folders In directory given count = 0 While foldername <> "" count = count +1 checker = Left(foldername,6) If checker = myValue Then strDirectory = serverpath & foldername strDirectory1 = strDirectory & "\Non-Disclosure Agreement" End If foldername = Dir ' find the Next file Wend 'Create filesystemobject Set objFSO = CreateObject("Scripting.FileSystemObject") 'Check If the folder "Non-Disclosure Agreement" exists If objFSO.FolderExists(strDirectory1) Then objFolder = objFSO.GetFolder(strDirectory1) found = 1 Else strDirectory = strDirectory & "\" found = 0 End If Dim CMDline, CMDvar, CMDval, Delimpos, CMDfind 'Handle For "Non-Disclosure Agreement" Not existing If (found = 0) Then foldername = Dir(strDirectory & "*.*", 16) 'value of "16" pulls In all folders In directory given count = 0 While foldername <> "" count = count + 1 delimpos = instr(1, foldername, " ") 'Find the delimeter (space), "13 Eng" ex. If delimpos Then CMDval = Right(foldername, 4) If CMDval = "Engineering" Then strDirectory1 = strDirectory & foldername End If End If foldername = Dir ' find the Next file Wend End If 'Find "Engineering Folder" strDirectory1 = strDirectory1 & "\" foldername = Dir(strDirectory1 & "*.*", 16) 'value of "16" pulls In all folders In directory given count = 0 While foldername <> "" count = count + 1 delimpos = instr(1, foldername, " ") 'Find the delimeter (space), "13 Eng" ex. If delimpos Then CMDval = Right(foldername,len(foldername) - delimpos) If CMDval = "Engineering" Then strDirectory2 = strDirectory1 & foldername strDirectory3 = strDirectory2 & "\09 Inspection" End If End If foldername = Dir ' find the Next file Wend 'Check If the folder "09 Inspection" exists If objFSO.FolderExists(strDirectory3) Then objFolder = objFSO.GetFolder(strDirectory3) found = 1 Else strDirectory2 = strDirectory2 & "\" found = 0 End If 'Handle For "09 Inspection" Not existing If (found = 0) Then foldername = Dir(strDirectory2 & "*.*", 16) 'value of "16" pulls In all folders In directory given count = 0 While foldername <> "" count = count + 1 delimpos = instr(1, foldername, " ") 'Find the delimeter (space), "13 Eng" ex. If delimpos Then CMDval = Right(foldername,len(foldername) - delimpos) If CMDval = "Inspection" Then strDirectory3 = strDirectory2 & foldername End If End If foldername = Dir ' find the Next file Wend End If 'Find "CMM Data" Folder strDirectory3 = strDirectory3 & "\" foldername = Dir(strDirectory3 & "*.*", 16) 'value of "16" pulls In all folders In directory given count = 0 founder = 0 While foldername <> "" count = count + 1 delimpos = instr(1, foldername, " ") 'Find the delimeter (space), "13 Eng" ex. If delimpos Then CMDval = Right(foldername,len(foldername) - delimpos) If CMDval = "CMM Programs & Documentation" Then founder = 1 strDirectory4 = strDirectory3 & foldername strDirectory5 = strDirectory4 End If End If foldername = Dir ' find the Next file Wend If (founder = 0) Then 'Check If the folder "02 CMM Programs & Documentation" exists If objFSO.FolderExists(strDirectory5) Then objFolder = objFSO.GetFolder(strDirectory5) 'Else objFolder = objFSO.CreateFolder(strDirectory5) objFolder = objFSO.GetFolder(strDirectory5) End If End If 'If the folder existed 'Check To see If results file exists FilePath = strDirectory5 & "\" Set prognam = Part.GetVariableValue("CMMPROGRAM") ResFileExists = FilePath & Prognam.StringValue & ".xlsx" Dim TempFilename If objFSO.FileExists(ResFileExists) = False Then TempFilename = "X:\00 Sub Folders\13 Engineering\09 Inspection\02 CMM Programs & Documentation\" & "Program Template.xlsx" Else TempFilename = FilePath & Prognam.StringValue & ".xlsx" End If On Error GoTo ErrorCheck
'Open Excel And Base form Set xlApp = CreateObject("Excel.Application") Set xlWorkbooks = xlapp.Workbooks Set xlWorkbook = xlWorkbooks.Open(TempFilename) Set xlSheet = xlWorkbook.Worksheets("#Main Page") Set xlsheets = xlworkbook.worksheets Set fncSheet = xlApp.WorkSheetFunction Dim Nomi, Plustol, Minustol Dim sh As Worksheet, flg As Boolean For Each sh In xlworkbook.worksheets If sh.Name = myProject Then flg = True : Exit For Next If flg = False Then xlsheets.Add.Name = myProject End If Set xlSheet = xlWorkbook.Worksheets(myProject) If objFSO.FileExists(ResFileExists) = False Then RCount = 7 CCount = 3 Set CMMPrognam = Part.GetVariableValue("CMMPROGRAM") Set Partnu = Part.GetVariableValue("PARTNUM") Set Partna = Part.GetVariableValue("PARTNAM") Set Printrevver = Part.GetVariableValue("PRINTREV1") xlSheet.Range("B1").Value = CMMPrognam.StringValue xlSheet.Range("A1").Value = "Program Name :" xlSheet.Range("B2").Value = Partnu.StringValue xlSheet.Range("A2").Value = "Part # :" xlSheet.Range("B3").Value = Partna.StringValue xlSheet.Range("A3").Value = "Part Name :" xlSheet.Range("B4").Value = Printrevver.StringValue xlSheet.Range("A4").Value = "Print Information :" Set Samp = Part.GetVariableValue("SAMP") xlSheet.Cells(RCount - 1, 2).Value = "Feature Name :" xlSheet.Cells(RCount + 5, 1).Value = "Sample # : " xlSheet.Cells(RCount + 5, 2).Value = Samp.StringValue xlSheet.Cells(RCount + 0, 1).Value = "--" xlSheet.Cells(RCount + 1, 1).Value = "--" xlSheet.Cells(RCount + 2, 1).Value = "--" xlSheet.Cells(RCount + 3, 1).Value = "--" xlSheet.Cells(RCount + 1, 2).Value = "Nominal" xlSheet.Cells(RCount + 2, 2).Value = "USL" xlSheet.Cells(RCount + 3, 2).Value = "LSL" xlSheet.Cells(RCount + 4, 1).Value = "--" xlSheet.Cells(RCount + 4, 2).Value = "--" 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-1,CCount).Value = Cmd.GetText (ID, 0) xlSheet.Cells(RCount,CCount).Value = Cmd.GetText(GDT_SYMBOL, 0) xlSheet.Cells(RCount+1,CCount).Value = "0" xlSheet.Cells(RCount+2,CCount).Value = Cmd.GetText (LINE2_PLUSTOL, 1) xlSheet.Cells(RCount+3,CCount).Value = "0" xlSheet.Cells(RCount+4, CCount).Value = "--" xlSheet.Cells(RCount+5, CCount).Value = Cmd.GetText(LINE2_DEV, 1) 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) xlSheet.Cells(RCount - 1, CCount).Value = DcmdID.Id 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 If DCmd.ID = "" Then xlSheet.Cells(RCount, CCount).Value = DCmd.AxisLetter Else xlSheet.Cells(RCount - 1, CCount).Value = Dcmd.Id xlSheet.Cells(RCount, CCount).Value = "M" End If 'DCmd.ID = "" xlSheet.Cells(RCount+1,CCount).Value = DCmd.Nominal Set PlusTol = fncsheet.Sum(DCmd.Nominal,(DCmd.Plus)) Set MinusTol = fncsheet.Sum(DCmd.Nominal,-(DCmd.Minus)) xlSheet.Cells(RCount + 2, CCount).Value = PlusTol xlSheet.Cells(RCount + 3, CCount).Value = MinusTol xlSheet.Cells(RCount+4, CCount).Value = "--" 'Measured Or Deviation With check For True Position If DCmd.AxisLetter <> "TP" Then xlSheet.Cells(RCount+5, CCount).Value = DCmd.Measured Else xlSheet.Cells(RCount+5, CCount).Value = DCmd.Deviation End If 'DCmd.AxisLetter <> "TP" 'Add For Profile dimensions If Cmd.Type = 1118 Or Cmd.Type = 1105 Then xlSheet.Cells(RCount+5, CCount).Value = DCmd.Deviation 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 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 Samp = Part.GetVariableValue("SAMP") xlSheet.Cells(RCount, 1).Value = "Sample # :" xlSheet.Cells(RCount, 2).Value = 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 = Cmd.GetText(LINE2_DEV, 1) 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 '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 'DCmd.AxisLetter <> "TP" 'Add For Profile dimensions If Cmd.Type = 1118 Or Cmd.Type = 1105 Then xlSheet.Cells(RCount, CCount).Value = DCmd.Deviation 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 Then Dim Aver, Mini, Maxi, StdDevv, Ranger, Meani, Cp, Cpk Dim MyRange As Range 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+10,1).Value = "Count" 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)))) 'Controls Range of Meas, Max-Min xlsheet.cells(Rcount+2,Ccount).Value = fncsheet.Sum(xlsheet.Cells(Rcount+0,Ccount).value,-(xlsheet.Cells(Rcount+1,Ccount).value)) 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.STDEVP(xlsheet.Range(xlsheet.cells(Scount,Ccount),(xlsheet.cells(Scount+Tcount,Ccount)))) xlsheet.cells(Rcount+7,Ccount).Value = "--" If xlsheet.cells(10,Ccount).Value <> 0 Then xlsheet.cells(Rcount+8,Ccount).Value = _ (xlsheet.cells(9,Ccount).Value-xlsheet.cells(10,Ccount).Value)/(6*xlsheet.cells(Rcount+6,Ccount).value) xlsheet.cells(Rcount+9,Ccount).Value = fncsheet.Min( _ (xlsheet.cells(9,Ccount).Value-xlsheet.cells(Rcount+4,Ccount).Value) /(3*xlsheet.cells(Rcount+6,Ccount).value) _ ,(xlsheet.cells(Rcount+4,Ccount).Value-xlsheet.cells(10,Ccount).Value)/(3*xlsheet.cells(Rcount+6,Ccount).value)) Else xlsheet.cells(Rcount+8,Ccount).Value = _ (xlsheet.cells(9,Ccount).Value)/(6*xlsheet.cells(Rcount+6,Ccount).value) xlsheet.cells(Rcount+9,Ccount).Value = _ (xlsheet.cells(9,Ccount).Value-xlsheet.cells(Rcount+4,Ccount).Value) /(3*xlsheet.cells(Rcount+6,Ccount).value) 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 Set xlSheet = Nothing xlWorkbook.Close Set xlWorkbook = Nothing xlWorkbooks.Close Set xlWorkbooks = Nothing xlApp.Quit Set xlApp = Nothing Exit Sub ErrorCheck: Set xlSheet = Nothing xlWorkbook.Close Set xlWorkbook = Nothing xlWorkbooks.Close Set xlWorkbooks = Nothing xlApp.Quit Set xlApp = Nothing End Sub
Dim WidthSet WidthSet = xlSheet.Range("A4").Columns.AutoFit() WidthSet = xlSheet.Cells(RCount - 1, 2).Columns.AutoFit()[SIZE=2][/SIZE]
If xlsheet.Cells(RCount+5,CCount).value > xlsheet.cells(Rcount+2,Ccount).Value Then xlsheet.Cells(RCount+5,Ccount[B]).Interior.ColorIndex [/B]= 38 End If
objExcel.Cells(1, 2).Font.ColorIndex = 44
Set objExcel = CreateObject("Excel.Application") objExcel.Visible = True Set objWorkbook = objExcel.Workbooks.Add() Set objWorksheet = objWorkbook.Worksheets(1) For i = 1 to 14 objExcel.Cells(i, 1).Value = i objExcel.Cells(i, 2).Interior.ColorIndex = i Next For i = 15 to 28 objExcel.Cells(i - 14, 3).Value = i objExcel.Cells(i - 14, 4).Interior.ColorIndex = i Next For i = 29 to 42 objExcel.Cells(i - 28, 5).Value = i objExcel.Cells(i - 28, 6).Interior.ColorIndex = i Next For i = 43 to 56 objExcel.Cells(i - 42, 7).Value = i objExcel.Cells(i - 42, 8).Interior.ColorIndex = i Next
Sub Main 'pcdlrn declarations And Open ppg Dim App As Object Set App = CreateObject("PCDLRN.Application") Dim Part As Object Set Part = App.ActivePartProgram Dim Ew As Object Set Ew = Part.EditWindow Dim Cmds As Object Set Cmds = Part.Commands Dim Cmd As Object Dim DCmd As Object Dim DcmdID As Object Dim ObjFso Set objFSO = CreateObject("Scripting.FileSystemObject") 'Excel Declarations Dim xlApp As Object Set xlApp = CreateObject("Excel.Application") Dim xlWorkbooks As Object Set xlWorkbooks = xlapp.Workbooks Dim xlWorkbook As Object Dim xlSheet As Object Dim fncSheet As Object Dim count As Integer Dim xlWorksheets As String Dim xlWorksheet As String Dim DimID As String Dim ReportDim As String Dim CheckDim As String Dim FilePath, SheetPath As String 'Check To see If results file exists myTitle$ = "User Input" Prompt$ = "Please Input Directory for blank Excel Document, or Reference Document. Including file name." Default$ = "C:\" FilePath = InputBox$(Prompt$, myTitle$, Default$) myTitle$ = "User Input" Prompt$ = "Please Input Sheet Name for Data Population" Default$ = "Sheet1" SheetPath = InputBox$(Prompt$, myTitle$, Default$) ResFileExists = FilePath & ".xlsx" Dim TempFilename,TempSheetName TempSheetName = SheetPath If objFSO.FileExists(ResFileExists) = False Then 'If the file did Not exist, Then use a default file location stored As a precaution TempFilename = "X:\00 Sub Folders\13 Engineering\09 Inspection\02 CMM Programs & Documentation\" & "Prog Template.xlsx" [COLOR=#FF0000][B] '^^ You need to adjust this line to fit your needs. This is a security line to always point to a guaranteed excel document for use. _ 'Ex. "C:\Test.xlsx"[/B][/COLOR] Else TempFilename = ResFileExists End If On Error GoTo ErrorCheck
'Open Excel And Base form 'Display Excel, While hiding Pc-Dmis xlApp.Application.Visible = True App.Visible = False Set xlWorkbook = xlWorkbooks.Open(TempFilename) Set xlsheets = xlworkbook.worksheets 'by default first sheet is "Sheet1" In a workbook. If you save a default template_ 'Then you need To adjust the following Set xlsheet assignment To match Set xlSheet = xlWorkbook.Worksheets("Sheet1") Set fncSheet = xlApp.WorkSheetFunction 'Pc-Dmis Variable Call-In Set CMMPrognam = Part.GetVariableValue("CMMPROGRAM") Set Partnu = Part.GetVariableValue("PARTNUMBER") Set Partna = Part.GetVariableValue("PARTNAME") Set Printrevver = Part.GetVariableValue("PRINTREV1") Set Samp = Part.GetVariableValue("SAMP") Dim sh As Worksheet, flg As Boolean Dim Nomi, Plustol, Minustol, Meas, WidthSet 'Search the Open workbook For a sheet Name For Each sh In xlworkbook.worksheets If sh.Name = SheetPath Then flg = True : Exit For Next 'If sheet is Not found, add one If flg = False Then xlsheets.Add.Name = SheetPath End If 'Asssign sheet Name To be populated Set xlSheet = xlWorkbook.Worksheets(SheetPath) 'If the file did Not exist, start execution To populate main data If objFSO.FileExists(ResFileExists) = False Or xlsheet.cells(1,1).Value = "" Then RCount = 7 CCount = 3 xlSheet.Range("B1").Value = CMMPrognam.StringValue xlSheet.Range("A1").Value = "Program Name :" xlSheet.Range("B2").Value = Partnu.StringValue xlSheet.Range("A2").Value = "Part # :" xlSheet.Range("B3").Value = Partna.StringValue xlSheet.Range("A3").Value = "Part Name :" xlSheet.Range("B4").Value = Printrevver.StringValue xlSheet.Range("A4").Value = "Print Information :" WidthSet = xlSheet.Range("A4").Columns.AutoFit() xlSheet.Cells(RCount - 1, 2).Value = "Feature Name :" WidthSet = xlSheet.Cells(RCount - 1, 2).Columns.AutoFit() xlSheet.Cells(RCount + 5, 1).Value = "Sample # : " xlSheet.Cells(RCount + 5, 2).Value = Samp.StringValue xlSheet.Cells(RCount + 0, 1).Value = "--" xlSheet.Cells(RCount + 1, 1).Value = "--" xlSheet.Cells(RCount + 2, 1).Value = "--" xlSheet.Cells(RCount + 3, 1).Value = "--" xlSheet.Cells(RCount + 1, 2).Value = "Nominal" xlSheet.Cells(RCount + 2, 2).Value = "USL" xlSheet.Cells(RCount + 3, 2).Value = "LSL" xlSheet.Cells(RCount + 4, 1).Value = "--" xlSheet.Cells(RCount + 4, 2).Value = "--" 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-1,CCount).Value = Cmd.GetText (ID, 0) xlSheet.Cells(RCount,CCount).Value = Cmd.GetText(GDT_SYMBOL, 0) xlSheet.Cells(RCount+1,CCount).Value = "0" xlSheet.Cells(RCount+2,CCount).Value = Cmd.GetText (LINE2_PLUSTOL, 1) xlSheet.Cells(RCount+3,CCount).Value = "0" xlSheet.Cells(RCount+4, CCount).Value = "--" xlSheet.Cells(RCount+5, CCount).Value = fncsheet.Round(Cmd.GetText(LINE2_DEV, 1),6) If xlsheet.Cells(RCount+5,CCount).value > xlsheet.cells(Rcount+2,Ccount).Value Then xlsheet.Cells(RCount+5,Ccount).Interior.ColorIndex = 38 End If WidthSet = xlSheet.Cells(RCount-1,CCount).Columns.AutoFit() WidthSet = xlSheet.Cells(RCount,CCount).Columns.AutoFit() 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) xlSheet.Cells(RCount - 1, CCount).Value = DcmdID.Id WidthSet = xlSheet.Cells(RCount-1,CCount).Columns.AutoFit() 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 If DCmd.ID = "" Then xlSheet.Cells(RCount, CCount).Value = DCmd.AxisLetter Else xlSheet.Cells(RCount - 1, CCount).Value = Dcmd.Id xlSheet.Cells(RCount, CCount).Value = "M" End If 'DCmd.ID = "" If Dcmd.Nominal < 0 Then Set Nomi = Abs(DCmd.Nominal) Set PlusTol = fncsheet.Sum(Nomi,Abs((DCmd.Plus))) Set MinusTol = fncsheet.Sum(Nomi,-Abs((DCmd.Minus))) Else Set Nomi = DCmd.Nominal Set PlusTol = fncsheet.Sum(Nomi,(DCmd.Plus)) Set MinusTol = fncsheet.Sum(Nomi,-(DCmd.Minus)) End If xlSheet.Cells(RCount+1,CCount).Value = Nomi xlSheet.Cells(RCount + 2, CCount).Value = PlusTol xlSheet.Cells(RCount + 3, CCount).Value = MinusTol xlSheet.Cells(RCount+4, 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+5, CCount).Value = Meas If Meas > PlusTol Or _ Meas < MinusTol Then xlsheet.Cells(RCount+5,Ccount).Interior.ColorIndex = 38 End If Else Set Meas = Abs(fncsheet.Round(DCmd.Deviation,6)) xlSheet.Cells(RCount+5, CCount).Value = Meas If Meas > PlusTol Or _ Meas < MinusTol Then xlsheet.Cells(RCount+5,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+5, CCount).Value = Meas If xlsheet.Cells(RCount+5,CCount).value > PlusTol Or _ xlsheet.Cells(RCount+5,CCount).value < MinusTol Then xlsheet.Cells(RCount+5,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
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
© 2024 Hexagon AB and/or its subsidiaries. | Privacy Policy | Cloud Services Agreement |