坛子上好多朋友需要数据导出等二次开发操作,但海克斯康的原始程序导出的数据不一定符合要求,以下是程序中的一段主要代码,请参考
不懂的可以提问,共同学习!!
Private Sub Command2_Click()
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim app As PCDLRN.Application
Dim cmds As PCDLRN.Commands
Dim cmd As PCDLRN.Command
Dim part As PCDLRN.PartProgram
Dim lngR As Long
Dim lngC As Long
Dim i As Long
Dim arrValue() As String
Dim strName As String
ReDim arrValue(5000, 8)
If Text1.Text = "" Then
MsgBox "无效保存路径!", vbCritical + vbOKOnly, "提示"
Exit Sub
End If
Set app = CreateObject("PCDLRN.Application")
Set part = app.ActivePartProgram
Set cmds = part.Commands
lngR = 0
lngC = 0
i = 1
For Each cmd In cmds
If cmd.IsDimension Then
If cmd.Type = DIMENSION_TRUE_START_POSITION Or cmd.Type = DIMENSION_END_LOCATION Or cmd.Type = DIMENSION_START_LOCATION Or cmd.Type = DIMENSION_TRUE_END_POSITION Or cmd.Type = DIMENSION_2D_DISTANCE Or cmd.Type = DIMENSION_3D_DISTANCE Or cmd.Type = DIMENSION_FLATNESS Then
arrValue(lngR + i, lngC + 1) = cmd.DimensionCommand.ID:
strName = cmd.DimensionCommand.ID
Else
arrValue(lngR + i, lngC + 1) = strName
End If
If cmd.Type = DIMENSION_2D_DISTANCE Or cmd.Type = DIMENSION_3D_DISTANCE Or cmd.Type = DIMENSION_FLATNESS Or cmd.Type = DIMENSION_X_LOCATION Or cmd.Type = DIMENSION_Y_LOCATION Or cmd.Type = DIMENSION_Z_LOCATION Or cmd.Type = DIMENSION_T_LOCATION Then
Select Case cmd.Type
Case DIMENSION_X_LOCATION
arrValue(lngR + i, lngC + 2) = "X"
Case DIMENSION_Y_LOCATION
arrValue(lngR + i, lngC + 2) = "Y"
Case DIMENSION_Z_LOCATION
arrValue(lngR + i, lngC + 2) = "Z"
Case DIMENSION_T_LOCATION
arrValue(lngR + i, lngC + 2) = "T"
Case DIMENSION_2D_DISTANCE
arrValue(lngR + i, lngC + 2) = "2D距离"
Case DIMENSION_FLATNESS
arrValue(lngR + i, lngC + 2) = "平面度"
Case DIMENSION_3D_DISTANCE
arrValue(lngR + i, lngC + 2) = "3D距离"
End Select
arrValue(lngR + i, lngC + 3) = Format(cmd.DimensionCommand.NOMINAL, "0.00")
arrValue(lngR + i, lngC + 4) = Format(cmd.DimensionCommand.Measured, "0.00")
arrValue(lngR + i, lngC + 5) = cmd.DimensionCommand.Plus
arrValue(lngR + i, lngC + 6) = -cmd.DimensionCommand.Minus
arrValue(lngR + i, lngC + 7) = Format(cmd.DimensionCommand.Deviation, "0.00")
arrValue(lngR + i, lngC + 8) = Format(cmd.DimensionCommand.OutTol, "0.00")
i = i + 1
End If
End If
DoEvents
Next cmd
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
xlApp.Visible = False
Sheets("Sheet1").Name = "Data"
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete
Set xlSheet = xlBook.Worksheets("Data")
With xlSheet
.Range("A1:H1").Merge
.Rows("1:1").RowHeight = 30
.Range("A1:H1").FormulaR1C1 = "CMM"
.Range("A1:H1").Font.Size = 26
.Range("A1:H1").HorizontalAlignment = xlCenter
.Cells(2, 1) = "ID"
.Cells(2, 2) = "AXIS"
.Cells(2, 3) = "Nominal"
.Cells(2, 4) = "Measured"
.Cells(2, 5) = "Plus"
.Cells(2, 6) = "Minus"
.Cells(2, 7) = "Deviation"
.Cells(2, 8) = "OutTol"
.Range("A2:H2").HorizontalAlignment = xlCenter
.Range(.Cells(3, 1), .Cells(i + 3, 8)) = arrValue
End With
Application.ScreenUpdating = True
xlApp.ActiveWorkbook.SaveAs FileName:=Text1.Text
Set xlSheet = Nothing
xlBook.Close
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub