hexagon logo
Register Sign in
  • Replies 22 replies
  • Subscribers 34 subscribers
  • Views 535 views
  • Users 0 members are here
Options
Related

PC-Dmis to Excel, through PC-Dmis Script

Rploughe
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........
  • 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
  • There the monster is finished.

    I can personally say it was fun writing this.

    The first section posted goes through my company directory by a pulled variable and locations to find my end "address"
    the second section posted actually controls all the excel population. Still needs cleaned up.
    The third section is the final part of the program for clean up, and formula crunching.

    If you have any questions, I will answer what I can.

    ---------
    I had some time and decided to play with the excel functions some more. Finding the correct syntax for the "Excel" "WorkbookFunction" was a little annoying but I got it. I also figured out how to properly select a cell range for data crunching.

    Not sure if my formula for Cp, CpK are correct. I did it off of memory real quick.

    So here you go, a working excel output script with examples on excel function/formula implementation. There are other logic statements I have been playing with like cell shading and cell width/height. Once I get a "neat" layout I will post them.
    ------- 
    Dim WidthSet
 WidthSet = xlSheet.Range("A4").Columns.AutoFit()
WidthSet = xlSheet.Cells(RCount - 1, 2).Columns.AutoFit()[SIZE=2][/SIZE]

    ^Controls to AutoSet Cell Width for information display length 
    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

    ^Controls to AutoSet Cell Shade based on cell value comparatively. 
    objExcel.Cells(1, 2).Font.ColorIndex = 44

    ^Controls to AutoSet Cell Text Color. 
    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

    ^Code snippet to determine color code
  • Noob (to VB) question here, do I just copy this into VB to make this work?
  • ...... it won't be that easy.

    I could post a more user-friendly copy, but this was more of a reference/guide to using excel from the basic script commands. I found the pcd2excel wizard in pcdmis not very friendly to custom/modified outputs.

    I can help you with questions. pm me.
  • Drop-In Script part1 

    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
  • Drop-in Script Part2 
     
'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
  • 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
  • Above is a 3 part drop in script. You will need to copy and paste it all together.

    Note 1: If you notice in the first section, you need to add a default excel file for reference as a security means.
    Note 2: The version of excel you are using is important. As Default it uses the extension .xlsx
    Note 3: The following code snippet requires these variables in your Pc-Dmis program to be implemented. If you want to use the default program data, that can be done as well. Just change the code.
    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")
    Note 4: The optional math functions are for your use. If you don't want them, delete them out. BUT! you can't leave them in there if you dry run. throws zeroes out and causes errors.
    Note 5: Please notice that even if you dim out in negatives, everything in this script uses Abs values and rounds out to 6 places. For the math functions to work, it had to be done.
    Note 6: Your dimensions can't be 0 +/- tol. For obvious reasons, your averages and other values will be wrong. So you may use dimensions like this, but you can't use the math functions.
© 2024 Hexagon AB and/or its subsidiaries. Privacy Policy | Cloud Services Agreement