This is the code I have to output to a CSV file using VB6. It gives me all the feature names, but only gives the values for any TP or form Features. It will not give me values for Diameters or distances. It returns "0".
Any help would be appreciated... Thanks !!!
Start of Code ***********************************************
Sub Main()
Dim strSQL As String
Dim strTBL As String
Dim strVAL As String
'PCDMIS declarations
'--------------------
Dim App As PCDLRN.Application
Dim Part As PCDLRN.PartProgram
Dim Cmds As PCDLRN.Commands
Dim Cmd As PCDLRN.Command
Dim DCmd As PCDLRN.DimensionCmd
Set App = CreateObject("PCDLRN.Application.4.2")
Set Part = App.ActivePartProgram
Set Cmds = Part.Commands
Dim Var As Object
Dim Var1 As Object
Dim Var2 As Object
Set Var = App.ActivePartProgram.GetVariableValue("CMM_NO")
Set Var1 = App.ActivePartProgram.GetVariableValue("CELL_NO")
Set Var2 = App.ActivePartProgram.GetVariableValue("MACH_NO")
Dim PartNo As String
Dim CellNo As String
Dim MachNo As String
Dim Charpos As Integer
Dim Dev_Val As Double
Dim Tmp_Val As Double
Dim FeatName As String
'===========================================================================
' SECTION 1 - Get Part, Cell, Machine and CMM Number from program
'===========================================================================
'Following variables must be defined in CMM program
' CELL_NO
' MACH_NO
'----------------------------------------------------------------------------
PartNo = Left(Part, 5)
CellNo = Var1.StringValue
MachNo = Var2.StringValue
CellNo = 4
MachNo = 2
'MsgBox "CELL = " & CellNo & " MACH = " & MachNo & "CMM = " & CmmNo
'===============================================================================
' SECTION 2 - Get Features / Dimensions and Start Building the Table and Value strings and
' get the Feature and Value Info...
'===============================================================================
If (Not App Is Nothing) Then
Set Part = App.ActivePartProgram
If (Not Part Is Nothing) Then
Set Cmds = Part.Commands
strTBL = "INSERT INTO MBHData (PART, CELL, MACH, "
strVAL = "VALUES ('" & PartNo & "', '" & CellNo & "', '" & MachNo & "'"
For Each Cmd In Cmds
FeatName = ""
If Cmd.IsDimension Then
Set DCmd = Cmd.DimensionCommand
FeatName = DCmd.ID
Dev_Val = Round(DCmd.Deviation, 4)
'If DCmd.ID <> "" Then
'If Cmd.Type = DIMENSION_START_LOCATION Or _
'Cmd.Type = DIMENSION_END_LOCATION Or _
'Cmd.Type = DIMENSION_TRUE_START_POSITION Or _
'Cmd.Type = DIMENSION_TRUE_END_POSITION
'Select Case Cmd.Type
'Case DIMENSION_2D_DISTANCE
'FeatName = DCmd.ID
'Dev_Val = Round(DCmd.Deviation, 4)
'Case Else
'If DCmd.AxisLetter <> "" Then
'Dev_Val = Round(DCmd.Deviation, 4)
'End If
'End Select
'End If
'End If
ElseIf (Cmd.Type = FEATURE_CONTROL_FRAME) Then
FeatName = Cmd.ID
Tmp_Val = Cmd.GetText(LINE2_DEV, 1)
Dev_Val = Round(Tmp_Val, 4)
End If
' In order to match FeatureNames correctly from PC-DMIS, this will strip
' any of them that have "__XX__" (for tolerance warnings) in them.
' example (HUB ID__66__make an offset) gets stripped to HUB ID...
'MsgBox FeatName
Charpos = InStr(1, FeatName, "_", vbTextCompare)
If Charpos > 0 Then
FeatName = Left(FeatName, Charpos - 1)
End If
'MsgBox FeatName
'*********************************************************************
' These are the FeatureName to Tablename descriptors that build
' the strTBL and strVAL strings based on what is in the Part Program.
' Always update this area when you add NEW features to the PC-DMIS programs.
' Note - Keep the same format below when adding or removing features
' because you'll never have the same starting or ending features
' from program to program.
' It does not matter what order you put them in here either
'*********************************************************************
' *************************************************************************
' Start of Feature Names and Table Names...
' *************************************************************************
Select Case FeatName
Case "THRUST FACE FLATNESS"
strTBL = strTBL & "TFFLT, "
strVAL = strVAL & "," & Dev_Val
Case "V11"
strTBL = strTBL & "V11, "
strVAL = strVAL & "," & Dev_Val
Case "HUB ID"
strTBL = strTBL & "HID, "
strVAL = strVAL & "," & Dev_Val
Case "HUB ID TAPER"
strTBL = strTBL & "HTAP, "
strVAL = strVAL & "," & Dev_Val
Case "MAJOR OD"
strTBL = strTBL & "MAJOD, "
strVAL = strVAL & "," & Dev_Val
Case "HOLE A TRUE POSITION"
strTBL = strTBL & "AHTP, "
strVAL = strVAL & "," & Dev_Val
Case "HOLE B TRUE POSITION"
strTBL = strTBL & "BHTP, "
strVAL = strVAL & "," & Dev_Val
Case "STAKE HOLE D TRUE POSITION"
strTBL = strTBL & "SHDTP, "
strVAL = strVAL & "," & Dev_Val
Case "STAKE HOLE E TRUE POSITION"
strTBL = strTBL & "SHETP, "
strVAL = strVAL & "," & Dev_Val
Case "TREPAN ID"
strTBL = strTBL & "TRPID, "
strVAL = strVAL & "," & Dev_Val
Case "TREPAN OD"
strTBL = strTBL & "TRPOD, "
strVAL = strVAL & "," & Dev_Val
Case "PAD HEIGHT"
strTBL = strTBL & "PADH, "
strVAL = strVAL & "," & Dev_Val
Case "DOWEL SPREAD"
strTBL = strTBL & "DWLSP, "
strVAL = strVAL & "," & Dev_Val
End Select
' *************************************************************************
' End of Feature Names and Table Names...
' *************************************************************************
Next Cmd
Set Part = Nothing
End If
Set App = Nothing
End If
'===============================================================================
' SECTION 3 - Clean up the strTBL and strVAL strings...
'===============================================================================
'This removes the last "comma" and "space" and appends a "closing parenthesis"...
strTBL = Left(strTBL, Len(strTBL) - 2)
strTBL = strTBL & ")"
'This appends a "closing parenthesis"...
strVAL = strVAL & ")"
'Now, combine the strTBL and strVAL strings for output as strSQL...
strSQL = strTBL & strVAL
' This is the Write the File command...
writeFile (strSQL)
' This tell me it's DONE !!!
MsgBox "Done"
End Sub
'===============================================================================
' SECTION 4 - Write the data to a CSC file (for testing only)
'===============================================================================
Public Function writeFile(strSQL)
Dim FileSQL As Integer
On Error GoTo ErrHandler
FileSQL = FreeFile
Open "c:\DATA\query.txt" For Output As #FileSQL
Print #FileSQL, strSQL
Close #FileSQL
Exit Function
ErrHandler:
MsgBox ("Can't open the CSV file")
End Function
End of Code ***********************************************
