最近更新于 2026-06-09 14:24
前言
2026/6/6
去年启动了一个项目，用纯 Python 实现的，用于自动导出测量数据到 Excel，项目地址：https://github.com/IYATT-yx/pcdmis-export-data
近期尝试优化，但是效果甚微。我用内置的 BASIC 测试发现同样的数据导出，BASIC 可以做到 0.0078s，而 Python 要 3s，这性能差异不是一般的大。主要问题是 Python 是外部进程执行，通过 COM 跨进程交互的代价非常高，而 BASIC 是 PC-DMIS 内置执行，同进程内的调用效率非常高。因此我准备重构这个项目，将数据读取部分改为 BASIC 实现，其它功能用 Python 实现，这样应该可以大大改善导出效率。现在纯 Python 方案确实性能太拉跨了，有一个箱体零件，检测报告 13 页的样子，导出要 28s 左右（那台三坐标电脑还是机械硬盘的），时间开销太大。
这里就记录 BASIC 方案的实践。
PC-DMIS 的 BASIC 还是一个非常老的引擎，而且极度阉割，很多语法功能都不支持，写起来挺累的。我也是现学现探索，通过 Google Gemini 辅助我研究，并把验证的相关代码和结果记录在本文，为重构我的项目做准备。
测试软件版本
- PC-DMIS 2019 R2
- PC-DMIS 2023.1（默认测试环境）
实践记录
插入脚本
这玩意折腾了我晚上一两个小时，我不是很熟悉 PC-DMIS 有个标记操作，不知道默认插入的 BASIC 是不执行状态的，然后反复研究到底怎么回事。最后才发现要切换标记才能执行。
插入 – BASIC 脚本
如果有现成的脚本可以直接选择，没有就自己取一个文件名
插入后可以看到色有背景色的，现在运行测量程序时是不会执行它的
光标点到这个命令上，按一下F3，这样就切换到可执行状态了
光标在命令上，按F9可以打开脚本编辑器
选中整个命令，按Ctrl+L执行当前命令，成功执行以后会显示出终止脚本/。
BASIC 脚本文件编码
中文语言下通过 PC-DMIS 插入创建默认用的 GB2312，如果自己创建脚本的话就要特别选择。
比如我用 VScode 写代码，保存就手动选编码 GB2312。如果要国际化，建议脚本里写纯英文，不要出现中文字符，这时候 GB2312 可以等效为 ANSI。在非中文语言的电脑上也能正常显示字符。
获取软件版本
Sub Main()
Dim app As Object
Set app = CreateObject("PCDLRN.Application")
If app Is Nothing Then
MsgBox "无法连接到 PC-DMIS 实例！", 16, "错误"
Exit Sub
End If
MsgBox "当前 PC-DMIS 版本为：" & app.VersionString, 64, "PC-DMIS 版本信息"
Set app = Nothing
End Sub
自定义函数 – 无返回值
' 主入口 Main 必须写在最顶上
Sub Main()
' 动态数组
Dim myArgs() As String
ReDim myArgs(3)
myArgs(0) = "参数1"
myArgs(1) = "参数2"
myArgs(2) = "参数3"
myArgs(3) = "操作员: IYATT-yx"
processArray myArgs
End Sub
Sub processArray(ByRef targetArray() As String)
Dim boundString As String
boundString = ""
Dim i As Long
For i = LBound(targetArray) To UBound(targetArray)
boundString = boundString & "接收到索引 [" & i & "]：" & targetArray(i) & Chr(13) & Chr(10)
Next i
MsgBox boundString, 64, "子程序收到数组"
End Sub
自定义函数 – 有返回值和参数传出
' ==============================================================================
' 主入口：必须写在最顶上
' ==============================================================================
Sub Main()
Dim myArgs() As String
ReDim myArgs(3)
myArgs(0) = "参数1"
myArgs(1) = "参数2"
myArgs(2) = "参数3"
myArgs(3) = "操作员: IYATT-yx"
' 声明一个变量用来接收函数的返回值
Dim resultStatus As String
' --------------------------------------------------------------------------
' 调用函数：myArgs 既是输入参数，也会在执行后被函数内部“洗舱”物理传出
' --------------------------------------------------------------------------
resultStatus = processArrayAndModify(myArgs)
' --------------------------------------------------------------------------
' 验证参数传出：遍历已被函数物理修改后的 myArgs 数组
' --------------------------------------------------------------------------
Dim afterString As String
afterString = "【Main 函数验证原数组已被物理修改】" & Chr(13) & Chr(10)
Dim i As Long
For i = LBound(myArgs) To UBound(myArgs)
afterString = afterString & "槽位 [" & i & "] 现在的值：" & myArgs(i) & Chr(13) & Chr(10)
Next i
' 弹出提示：先显示函数返回值，再显示修改后的数组内容
MsgBox "函数显式返回值 -> " & resultStatus & Chr(13) & Chr(10) & Chr(13) & Chr(10) & afterString, 64, "执行完毕"
End Sub
' ==============================================================================
' 自定义函数：接收数组（ByRef 传出），并通过 Function 显式返回 String 状态
' ==============================================================================
Function processArrayAndModify(ByRef targetArray() As String) As String
Dim i As Long
Dim count As Long
count = 0
' --------------------------------------------------------------------------
' 物理修改数组内容（参数传出核心动作）
' 由于是 ByRef 传递，这里对 targetArray 的修改会直接映射到 Main 的 myArgs 中
' --------------------------------------------------------------------------
For i = LBound(targetArray) To UBound(targetArray)
' 给原有的字符串物理追加一个后缀
targetArray(i) = targetArray(i) & " [已被函数物理修改]"
count = count + 1
Next i
' --------------------------------------------------------------------------
' 显式设置函数返回值：在 VBA 中，通过将结果赋值给“函数名”来返回数据
' --------------------------------------------------------------------------
processArrayAndModify = "SUCCESS: 成功处理并物理传出 " & count & " 个元素"
End Function
写文件
Sub Main
Dim filePath As String
filePath = "C:\Temp\TestLog_UTF8.txt"
' 初始化包含中文的数据
Dim dataLines(2) As String
dataLines(0) = "Header: 日志开始"
dataLines(1) = "Status: 处理中"
dataLines(2) = "Status: 已完成"
' 创建 ADODB.Stream 对象
Dim stream As Object
Set stream = CreateObject("ADODB.Stream")
' 准备写入的二进制流
stream.Type = 2 ' 2 = adTypeText (处理文本)
stream.Charset = "utf-8" ' 关键：强制指定编码为 UTF-8 with BOM
stream.Open
' 遍历数组并写入内容
Dim i As Integer
For i = 0 To UBound(dataLines)
' 使用 WriteText 写入字符串，后续追加换行
stream.WriteText dataLines(i) & Chr(13) & Chr(10)
Next i
' 将流保存到文件
' 2 = adSaveCreateOverWrite (若文件存在则覆盖)
stream.SaveToFile filePath, 2
' 严格的资源清理
stream.Close
Set stream = Nothing
End Sub
读写测量程序中的变量 – 官方案例
测量程序参考：
注意用注释显示变量值内容的那段不要在对话框里填，而是要在命令模式下之输入进去，否则会直接原样显示："V1 最终值：" + V1
C1 =注释/输入,否,全屏=否,
输入一个整数：
赋值/V1=INT(C1.INPUT)
CS1 =脚本/文件名= C:\WORK\DEVELOPMENT\PCDMIS-EXPORT-DATA\测试.BAS
函数/Main,显示=是,,
开始脚本/
终止脚本/
注释/操作者,否,全屏=否,自动继续=否,OVC=否,
"V1 最终值：" + V1脚本：
Sub Main
' 获取 PC-DMIS 应用程序对象
Dim app As Object
Set app = CreateObject("PCDLRN.Application")
' 获取当前打开的测量程序对象
Dim part As Object
Set part = app.ActivePartProgram
' 获取测量程序中 V1 变量对象
Dim var As Object
Set var = part.GetVariableValue("V1")
If Not var Is Nothing Then
MsgBox "V1 初始值：" & var.LongValue, 0, "提示"
var.LongValue = var.LongValue + 1
' 修改测量程序中 V1 变量的值
part.SetVariableValue "V1", var
MsgBox "V1 修改后值：" & var.LongValue, 0, "提示"
Else
MsgBox "未找到 V1 变量", 0, "提示"
End If
End Sub我输入一个 V1 初始值 100
脚本读取到值
脚本提示修改后的值
测量程序中通过注释命令显示 V1 变量值
在测量程序中插入注释命令 – 官方案例
注意 PC-DMIS 种的命令文本是关联软件语言的，如果是中文版，插入命令就要写中文关键字，是英语版就要写英语关键字。
Sub Main
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 yourName As String
yourName = InputBox("请输入你的名字：", "操作者", "IYATT-yx")
' 将插入点设置到测量程序末尾
' 注意：如果是通过测量程序运行调用，由于 PC-DMIS 的保护机制，实际无效
' 会固定插入到“开始脚本”和“终止脚本”之间
' 通过 PC-DMIS 的 BASIC 编辑器执行或者外部 BASIC 执行时有效
Dim endCmd As Object
Set endCmd = cmds(1)
Dim isSet As Boolean
isSet = cmds.InsertionPointAfter(cmds(cmds.Count))
If isSet = False Then
MsgBox "错误：设置插入点失败！"
Exit Sub
End If
' 插入注释命令
Dim cmd As Object
Set cmd = cmds.Add(SET_COMMENT, True)
retvaltype = cmd.PutText("报告", COMMENT_TYPE, 0)
retvaltext = cmd.PutText(yourName, COMMENT_FIELD, 1)
If (retvaltype = False) Or (retvaltext = False) Then
MsgBox "错误：插入注释失败！类型代码：" & retvaltype & " 文本代码：" & retvaltext
Exit Sub
End If
' 重绘
cmd.ReDraw
End Sub我对官方案例做了修改，将插入点设置为测量程序的末尾。只是注意如果通过测量程序运行时不会生效，会直接插入到“开始脚本”和“终止脚本”之间。
要通过外部 BASIC 或者 PC-DMIS 脚本编辑器执行才有效，这应该是 PC-DMIS 的保护机制，防止测量程序运行中自动调用脚本反过来修改测量程序造成异常情况。
这样就是正常插入到程序的末尾了。
写 CSV 文件
目前重构数据导出项目的设想就是，BASIC 读取检测数据然后写到 CSV，通过内置 BASIC 执行数据读取效率极高，和外部读取可以相差百倍及以上的时间。然后剩下的工作交给 Python 处理，Python 实现读取 CSV 然后重写到 Excel 文件，完成制表、表头变更（检测项变更）追踪、超差标识等工作。
下面是一段写 CSV 的实现及测试案例
Sub Main
' ==========================================================================
' 核心集成测试：验证 CSV 拼接、转义、目录一键创建及持久化功能
' ==========================================================================
Dim targetPath As String
' 测试深层未知目录自动创建（假设 SubDir1 和 SubDir2 在物理硬盘上都不存在）
targetPath = "C:\Temp\SubDir1\SubDir2\PC_DMIS_TestReport.csv"
Dim rowFields() As String
Dim dataLines(3) As String
Dim resultLine As String
Dim isOk As Boolean
' --------------------------------------------------------------------------
' 测试用例 1：常规标准数据（测试默认英文逗号拼接）
' --------------------------------------------------------------------------
ReDim rowFields(5)
rowFields(0) = "1"
rowFields(1) = "圆特征1"
rowFields(2) = "THEO"
rowFields(3) = "10.024"
rowFields(4) = "0.000"
rowFields(5) = "-5.112"
' 传入空字符串 ""，触发内部默认转为英文逗号的防御机制
dataLines(0) = joinCsvRowFields(rowFields, "")
' --------------------------------------------------------------------------
' 测试用例 2：字段包含“分隔符”（测试 CSV 自动补全双引号包裹机制）
' --------------------------------------------------------------------------
ReDim rowFields(5)
rowFields(0) = "2"
rowFields(1) = "孔,带逗号的名字" ' 字段中存在英文逗号
rowFields(2) = "MEAS"
rowFields(3) = "10.025"
rowFields(4) = "0.002"
rowFields(5) = "-5.110"
dataLines(1) = joinCsvRowFields(rowFields, "")
' --------------------------------------------------------------------------
' 测试用例 3：字段包含“双引号和换行符”（测试 myReplace 严谨转义与 CRLF 容错）
' --------------------------------------------------------------------------
ReDim rowFields(5)
rowFields(0) = "3"
rowFields(1) = "构建""面""特征" ' 包含原始双引号
rowFields(2) = "TARG" & Chr(13) & Chr(10) & "备注内容" ' 包含复杂回车换行符
rowFields(3) = "0.000"
rowFields(4) = "0.000"
rowFields(5) = "100.000"
dataLines(2) = joinCsvRowFields(rowFields, "")
' --------------------------------------------------------------------------
' 测试用例 4：独立验证自定义分隔符模式（例如制表符 Tab 或 分号）
' --------------------------------------------------------------------------
ReDim rowFields(2)
rowFields(0) = "额外测试"
rowFields(1) = "分号测试1"
rowFields(2) = "分号测试2"
' 使用分号分流，且故意在内容里塞入分号触发包装机制
rowFields(1) = "数据;含有分号"
dataLines(3) = joinCsvRowFields(rowFields, ";")
' --------------------------------------------------------------------------
' 持久化测试阶段 1：覆写模式（Overwrite）
' --------------------------------------------------------------------------
' 期望行为：
' 1. Windows 自动静默建立 C:\Temp\SubDir1\SubDir2\ 多层路径
' 2. 创建全新的文件并写入 4 行数据
isOk = SaveCsv(targetPath, dataLines, False)
If isOk Then
MsgBox "测试阶段 1 完成：全新多层目录已建立，文件首次覆写保存成功！" & vbCrLf & _
"请至路径下用记事本或 Excel 确认转义格式。", 64, "集成测试成功"
End If
' --------------------------------------------------------------------------
' 持久化测试阶段 2：追加模式（Append）
' --------------------------------------------------------------------------
' 准备一条追加的单行测试数据
Dim appendLines(0) As String
ReDim rowFields(5)
rowFields(0) = "4"
rowFields(1) = "追加特征_平面4"
rowFields(2) = "THEO"
rowFields(3) = "0.000"
rowFields(4) = "50.000"
rowFields(5) = "0.000"
appendLines(0) = joinCsvRowFields(rowFields, "")
' 期望行为：保留原有 4 行内容，在文件末尾静默追加第 5 行
isOk = SaveCsv(targetPath, appendLines, True)
If isOk Then
MsgBox "测试阶段 2 完成：成功在已有文件末尾追加新行！", 64, "集成测试成功"
End If
End Sub
' 保存 CSV 文件
' 参数：
' filePath：目标文件路径
' dataLines：待保存的 CSV 数据行数组
' isAppendMode：是否追加模式（默认覆写模式）
' 返回值：布尔值，表示保存是否成功
Function SaveCsv(ByVal filePath As String, ByRef dataLines() As String, ByVal isAppendMode As Boolean) As Boolean
On Error GoTo ErrorHandler
SaveCsv = False
' 初始化 FSO 用于提取父目录路径
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim parentFolder As String
parentFolder = fso.GetParentFolderName(filePath)
' 使用 Windows 系统命令静默、同步创建多级文件夹
If Not fso.FolderExists(parentFolder) Then
Dim wsh As Object
Set wsh = CreateObject("WScript.Shell")
If Not wsh Is Nothing Then
Dim cmdString As String
cmdString = "cmd.exe /c mkdir """ & parentFolder & """"
wsh.Run cmdString, 0, True
End If
Set wsh = Nothing
End If
' 流写入
Dim stream As Object
Set stream = CreateObject("ADODB.Stream")
stream.Type = 2
stream.Charset = "utf-8"
stream.Open
' 追加模式
If isAppendMode And fso.FileExists(filePath) Then
stream.LoadFromFile filePath
stream.Position = stream.Size
End If
' 直接写入整行数据
Dim i As Long
For i = LBound(dataLines) To UBound(dataLines)
stream.WriteText dataLines(i) & Chr(13) & Chr(10)
Next i
' 覆盖写入最终持久化
stream.SaveToFile filePath, 2
' 资源清理
stream.Close
Set stream = Nothing
Set fso = Nothing
SaveCsv = True
Exit Function
ErrorHandler:
MsgBox "文件持久化发生异常: " & Err.Description, 16, "I/O 模块错误"
If Not stream Is Nothing Then
' 确保流处于打开状态时才执行关闭，防止二次崩溃
On Error Resume Next
stream.Close
Set stream = Nothing
End If
Set fso = Nothing
End Function
' 用于 CSV 的单行字段拼接
' 参数：
' fields: 字段数组
' delimiter: 分隔符，传空字符串时默认为逗号
' 返回值：拼接后的字符串
' 用于 CSV 的单行字段拼接（严谨字符转义版）
Function joinCsvRowFields(ByRef fields() As String, ByVal delimiter As String) As String
If delimiter = "" Then
delimiter = ","
ElseIf InStr(1, delimiter, """") > 0 Then
joinCsvRowFields = ""
Exit Function
End If
On Error Resume Next
Dim lowerBound As Long
Dim upperBound As Long
lowerBound = LBound(fields)
upperBound = UBound(fields)
If Err.Number <> 0 Or upperBound < lowerBound Then
Err.Clear
joinCsvRowFields = ""
Exit Function
End If
On Error GoTo 0
Dim i As Long
Dim resultBuffer As String
Dim field As String
Dim strCr As String
Dim strLf As String
strCr = Chr(13)
strLf = Chr(10)
For i = lowerBound To upperBound
field = fields(i)
If InStr(1, field, delimiter) > 0 Or _
InStr(1, field, """") > 0 Or _
InStr(1, field, strCr) > 0 Or _
InStr(1, field, strLf) > 0 Then
field = myReplace(field, """", """""")
field = """" & field & """"
End If
' 4. 字符串拼接
If i = lowerBound Then
resultBuffer = field
Else
resultBuffer = resultBuffer & delimiter & field
End If
Next i
joinCsvRowFields = resultBuffer
End Function
' BASIC 字符串比较模式常量定义
' ==============================================================================
Public Const vbBinaryCompare = 0 ' 二进制比较（区分大小写）
Public Const vbTextCompare = 1 ' 文本比较（不区分大小写）
' ==============================================================================
' 字符串替换函数
' 参数：
' sourceStr: 原字符串
' findStr: 要查找的子字符串
' replaceStr: 替换字符串
' 返回值：替换后的字符串
Function myReplace(ByVal sourceStr As String, ByVal findStr As String, ByVal replaceStr As String) As String
If findStr = "" Then
MyReplace = sourceStr
Exit Function
End If
' 循环查找子字符串
Dim pos As Long
Dim startPos As Long
Dim result As String
startPos = 1
result = ""
Do
pos = InStr(startPos, sourceStr, findStr, vbBinaryCompare)
If pos = 0 Then
' 没找到，拼接剩下的部分
result = result & Mid(sourceStr, startPos)
Exit Do
Else
' 拼接找到子串前的部分 + 替换字符串
result = result & Mid(sourceStr, startPos, pos - startPos) & replaceStr
' 移动起始位置到找到子串的后面
startPos = pos + Len(findStr)
End If
Loop
myReplace = result
End Function
如果出现：application defined or object defined error 错误，先检查要写的文件是不是处于打开状态，这是文件被占用了，导致写入失败。我偶尔都没反应过来。
读取特征坐标
注意需要使用“写 CSV 文件”章节的代码用于输出结果。
Sub Main
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 i As Long
Dim cmd As Object
Dim featCmd As Object
' 声明接收坐标的变量
Dim x As Double, y As Double, z As Double
' CSV 数据缓存数组与计数器
Dim dataLines() As String
Dim lineCount As Long
lineCount = 0
' 声明单行字段缓存数组
Dim fields(0 To 6) As String
' 初始化 CSV 表头 (特征名, 数据类型, X, Y, Z)
ReDim Preserve dataLines(0 To lineCount) ' 动态调整数组大小且保留数据
fields(0) = "标识符"
fields(1) = "数据类型"
fields(2) = "X"
fields(3) = "Y"
fields(4) = "Z"
dataLines(lineCount) = joinCsvRowFields(fields, ",")
' 开始遍历当前程序中的命令
For i = 1 To cmds.Count
Set cmd = cmds(i)
If cmd.IsFeature Then
fields(0) = cmd.ID
' 抓取理论值
fields(1) = "THEO(理论)"
fields(2) = cmd.GetFieldValue(THEO_X, 0)
fields(3) = cmd.GetFieldValue(THEO_Y, 0)
fields(4) = cmd.GetFieldValue(THEO_Z, 0)
lineCount = lineCount + 1
ReDim Preserve dataLines(0 To lineCount)
dataLines(lineCount) = joinCsvRowFields(fields, ",")
' 抓取实际值
fields(1) = "MEAS(实际)"
fields(2) = cmd.GetFieldValue(MEAS_X, 0)
fields(3) = cmd.GetFieldValue(MEAS_Y, 0)
fields(4) = cmd.GetFieldValue(MEAS_Z, 0)
lineCount = lineCount + 1
ReDim Preserve dataLines(0 To lineCount)
dataLines(lineCount) = joinCsvRowFields(fields, ",")
' 抓取目标值
fields(1) = "TARG(目标)"
fields(2) = cmd.GetFieldValue(TARG_X, 0)
fields(3) = cmd.GetFieldValue(TARG_Y, 0)
fields(4) = cmd.GetFieldValue(TARG_Z, 0)
lineCount = lineCount + 1
ReDim Preserve dataLines(0 To lineCount)
dataLines(lineCount) = joinCsvRowFields(fields, ",")
End If
Next i
' 检查是否有有效特征数据被录入，若有则保存文件
If lineCount > 0 Then
Dim isSuccess As Boolean
isSuccess = SaveCsv("C:\Temp\test.csv", dataLines, False)
If isSuccess Then
MsgBox "数据已成功保存至 C:\Temp\test.csv", 64, "保存成功"
End If
Else
MsgBox "未在当前测量程序中找到任何特征命令。", 48, "提示"
End If
' 资源释放
Set cmd = Nothing
Set cmds = Nothing
Set part = Nothing
Set app = Nothing
End Sub
读取尺寸
如果勾选了使用传统评价方式，这种方式的形位公差评价也被归类到尺寸里，可以通过这里读取出来。
注意需要使用“写 CSV 文件”章节的代码用于输出结果。
Sub Main
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 i As Long
Dim cmd As Object
' CSV 数据缓存数组与计数器
Dim dataLines() As String
Dim lineCount As Long
lineCount = 0
' 检测数据字段缓存数组
Dim fields(0 To 14) As String
' 初始化 CSV 表头（完整呈现所有检测要素）
ReDim Preserve dataLines(0 To lineCount)
fields(0) = "序号"
fields(1) = "标识符"
fields(2) = "特征1"
fields(3) = "特征2"
fields(4) = "特征3"
fields(5) = "头部信息"
fields(6) = "单位"
fields(7) = "轴"
fields(8) = "理论值"
fields(9) = "上极限偏差"
fields(10) = "下极限偏差"
fields(11) = "实测值"
fields(12) = "偏差值"
fields(13) = "超差值"
fields(14) = "实体补偿"
dataLines(lineCount) = joinCsvRowFields(fields, ",")
' 开始遍历当前程序中的命令
For i = 1 To cmds.Count
Set cmd = cmds(i)
' 判断当前命令是否为 尺寸评价 (Dimension)
If cmd.IsDimension Then
' 核心修改2：获取底层 DimensionCommand 对象以提取关联特征
Dim dimObj As Object
Set dimObj = cmd.DimensionCommand
' 填充基础数据
fields(0) = CStr(i)
fields(1) = cmd.ID
' 核心修改3：原汁原味同步 Python 中的特征与头部文本抓取（不做任何过滤与格式化）
fields(2) = dimObj.Feat1
fields(3) = dimObj.Feat2
fields(4) = dimObj.Feat3
fields(5) = CStr(cmd.GetFieldValue(DIM_HEADING, 0))
' 保持原有的 GetFieldValue 纯原始数据提取，不加任何 Format
fields(6) = CStr(cmd.GetFieldValue(UNIT_TYPE, 0))
fields(7) = CStr(cmd.GetFieldValue(AXIS, 0))
fields(8) = CStr(cmd.GetFieldValue(NOMINAL, 0))
fields(9) = CStr(cmd.GetFieldValue(F_PLUS_TOL, 0))
fields(10) = CStr(cmd.GetFieldValue(F_MINUS_TOL, 0))
fields(11) = CStr(cmd.GetFieldValue(DIM_MEASURED, 0))
fields(12) = CStr(cmd.GetFieldValue(DIM_DEVIATION, 0))
fields(13) = CStr(cmd.GetFieldValue(DIM_OUTTOL, 0))
fields(14) = CStr(cmd.GetFieldValue(DIM_BONUS, 0))
' 压入动态数组
lineCount = lineCount + 1
ReDim Preserve dataLines(0 To lineCount)
dataLines(lineCount) = joinCsvRowFields(fields, ",")
Set dimObj = Nothing
End If
Next i
' 检查并保存文件
If lineCount > 0 Then
Dim isSuccess As Boolean
' 写入目标 CSV 文件
isSuccess = SaveCsv("C:\Temp\test.csv", dataLines, False)
If isSuccess Then
MsgBox "尺寸数据已成功保存至 C:\Temp\test.csv", 64, "保存成功"
End If
Else
MsgBox "未在当前测量程序中找到任何尺寸评价命令。", 48, "提示"
End If
' 资源释放
Set cmd = Nothing
Set cmds = Nothing
Set part = Nothing
Set app = Nothing
End Sub可以注意到部分是无效值，如第 5 行，轴读取结果为 FALSE，后续的数据全为 0，这个命令应该是用来包裹“位置”的，本身无有效数据，后续可以根据轴为 FALSE 其它值为 0 的特点清洗掉。
读取形位公差（2021 版及以前）
在 PC-DMIS 2021 及以前，读取几何公差也是用 GetFieldValue 或 GetText，之后新增了专门的对象来访问。
注意需要使用“写 CSV 文件”章节的代码用于输出结果。
Sub Main
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 i As Long, j As Long
Dim cmd As Object
' CSV 数据缓存数组与计数器
Dim dataLines() As String
Dim lineCount As Long
lineCount = 0
' 对应 Python 字典的 17 个字段 (0 To 16)
Dim fields(0 To 16) As String
' 初始化 CSV 表头
ReDim Preserve dataLines(0 To lineCount)
fields(0) = "序号"
fields(1) = "标识符"
fields(2) = "子序号"
fields(3) = "子标识符"
fields(4) = "相关特征"
fields(5) = "单位"
fields(6) = "形位公差类型"
fields(7) = "形位公差值"
fields(8) = "跳动类型"
fields(9) = "轴"
fields(10) = "理论值"
fields(11) = "上极限偏差"
fields(12) = "下极限偏差"
fields(13) = "实测值"
fields(14) = "偏差值"
fields(15) = "超差值"
fields(16) = "实体补偿"
dataLines(lineCount) = joinCsvRowFields(fields, ",")
' 读取设置：是否启用了负公差显示负号
Dim showNegative As Boolean
showNegative = part.PartProgramSettings.MinusTolerancesShowNegative
' 声明每一层循环的行数计数器
Dim countLine1 As Long, countLine2 As Long, countLine3 As Long
Dim tempMinus As Variant
' 开始遍历当前程序中的命令
For i = 1 To cmds.Count
Set cmd = cmds(i)
' 判断当前命令是否为 形位公差 (FCF)
If cmd.IsFcfCommand Then
' 提取公共字段
Dim cmdId As String, cmdUnit As String
cmdId = cmd.ID
cmdUnit = CStr(cmd.GetFieldValue(UNIT_TYPE, 0))
' =================================================================
' 1. LINE1 循环：形位公差评价对象自身的尺寸信息
' =================================================================
countLine1 = cmd.GetDataTypeCount(LINE1_MEAS)
For j = 1 To countLine1
fields(0) = CStr(i)
fields(1) = cmdId
fields(2) = CStr(j)
fields(3) = CStr(cmd.GetFieldValue(LINE1_TBLHDR, j))
fields(4) = CStr(cmd.GetFieldValue(LINE1_FEATNAME, j))
fields(5) = cmdUnit
fields(6) = ""
fields(7) = ""
fields(8) = ""
fields(9) = ""
fields(10) = CStr(cmd.GetFieldValue(LINE1_NOMINAL, j))
fields(11) = CStr(cmd.GetFieldValue(LINE1_PLUSTOL, j))
' 下极限偏差处理（负公差显示负号）
tempMinus = cmd.GetFieldValue(LINE1_MINUSTOL, j)
If IsNumeric(tempMinus) And Not showNegative Then
fields(12) = CStr(-CDbl(tempMinus))
Else
fields(12) = CStr(tempMinus)
End If
fields(13) = CStr(cmd.GetFieldValue(LINE1_MEAS, j))
fields(14) = CStr(cmd.GetFieldValue(LINE1_DEV, j))
fields(15) = CStr(cmd.GetFieldValue(LINE1_OUTTOL, j))
fields(16) = CStr(cmd.GetFieldValue(LINE1_BONUS, j))
' 压入数组
lineCount = lineCount + 1
ReDim Preserve dataLines(0 To lineCount)
dataLines(lineCount) = joinCsvRowFields(fields, ",")
Next j
' =================================================================
' 2. LINE2 循环：核心几何公差数据
' =================================================================
countLine2 = cmd.GetDataTypeCount(LINE2_MEAS)
For j = 1 To countLine2
fields(0) = CStr(i)
fields(1) = cmdId
fields(2) = CStr(j)
fields(3) = CStr(cmd.GetFieldValue(LINE2_TBLHDR, j))
fields(4) = CStr(cmd.GetFieldValue(LINE2_FEATNAME, j))
fields(5) = cmdUnit
fields(6) = CStr(cmd.GetFieldValue(GDT_SYMBOL, 0))
fields(7) = CStr(cmd.GetFieldValue(LINE2_TOL, 0))
fields(8) = CStr(cmd.GetFieldValue(FCF_RUNOUT_TYPE, 0))
fields(9) = CStr(cmd.GetFieldValue(LINE2_AXIS, j))
fields(10) = CStr(cmd.GetFieldValue(LINE2_NOMINAL, j))
fields(11) = CStr(cmd.GetFieldValue(LINE2_PLUSTOL, j))
fields(12) = CStr(cmd.GetFieldValue(LINE2_MINUSTOL, j))
fields(13) = CStr(cmd.GetFieldValue(LINE2_MEAS, j))
fields(14) = CStr(cmd.GetFieldValue(LINE2_DEV, j))
fields(15) = CStr(cmd.GetFieldValue(LINE2_OUTTOL, j))
fields(16) = CStr(cmd.GetFieldValue(LINE2_BONUS, j))
' 压入数组
lineCount = lineCount + 1
ReDim Preserve dataLines(0 To lineCount)
dataLines(lineCount) = joinCsvRowFields(fields, ",")
Next j
' =================================================================
' 3. LINE3 循环：复合形位公差次要分量数据
' =================================================================
countLine3 = cmd.GetDataTypeCount(LINE3_MEAS)
For j = 1 To countLine3
fields(0) = CStr(i)
fields(1) = cmdId
fields(2) = CStr(j)
fields(3) = CStr(cmd.GetFieldValue(LINE3_TBLHDR, j))
fields(4) = CStr(cmd.GetFieldValue(LINE3_FEATNAME, j))
fields(5) = cmdUnit
fields(6) = ""
fields(7) = CStr(cmd.GetFieldValue(LINE3_TOL, 0))
fields(8) = ""
fields(9) = ""
fields(10) = CStr(cmd.GetFieldValue(LINE3_NOMINAL, j))
fields(11) = CStr(cmd.GetFieldValue(LINE3_PLUSTOL, j))
fields(12) = CStr(cmd.GetFieldValue(LINE3_MINUSTOL, j))
fields(13) = CStr(cmd.GetFieldValue(LINE3_MEAS, j))
fields(14) = CStr(cmd.GetFieldValue(LINE3_DEV, j))
fields(15) = CStr(cmd.GetFieldValue(LINE3_OUTTOL, j))
fields(16) = CStr(cmd.GetFieldValue(LINE3_BONUS, j))
' 压入数组
lineCount = lineCount + 1
ReDim Preserve dataLines(0 To lineCount)
dataLines(lineCount) = joinCsvRowFields(fields, ",")
Next j
End If
Next i
' 检查并保存文件
If lineCount > 0 Then
Dim isSuccess As Boolean
isSuccess = SaveCsv("C:\Temp\test.csv", dataLines, False)
If isSuccess Then
MsgBox "形位公差数据已成功保存至 C:\Temp\test.csv", 64, "保存成功"
End If
Else
MsgBox "未在当前测量程序中找到任何形位公差(FCF)命令。", 48, "提示"
End If
' 资源释放
Set cmd = Nothing
Set cmds = Nothing
Set part = Nothing
Set app = Nothing
End Sub注意要像图中报告里有形位公差符号的这种评价才能用这里的方法读取，否则使用上面章节读取尺寸的方法读取。
读取几何公差（2022 版及以后）
从 PC-DMIS 2022 版开始引入了 ToleranceCommand 对象，可以通过它来访问几何公差。
注意需要使用“写 CSV 文件”章节的代码用于输出结果。
注意要像图中报告里有形位公差符号的这种评价才能用这里的方法读取，否则使用上面章节读取尺寸的方法读取。
Sub Main
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 i As Long, j As Long, k As Long
Dim cmd As Object
' CSV 数据缓存数组与计数器
Dim dataLines() As String
Dim lineCount As Long
lineCount = 0
' 定义 18 个字段的抽屉 (0 To 17)
Dim fields(0 To 17) As String
' 初始化 CSV 表头，明确区分数据类型
ReDim Preserve dataLines(0 To lineCount)
fields(0) = "序号"
fields(1) = "标识符"
fields(2) = "数据归类"
fields(3) = "子序号"
fields(4) = "区段号"
fields(5) = "特征"
fields(6) = "轴"
fields(7) = "单位"
fields(8) = "形位类型"
fields(9) = "理论值"
fields(10) = "上极限偏差"
fields(11) = "下极限偏差"
fields(12) = "实测值"
fields(13) = "偏差值"
fields(14) = "超差值"
fields(15) = "实体补偿"
fields(16) = "命令详情"
dataLines(lineCount) = joinCsvRowFields(fields, ",")
' 读取设置：是否启用了负公差显示负号
Dim showNegative As Boolean
showNegative = part.PartProgramSettings.MinusTolerancesShowNegative
' 声明新模型专属对象与临时变量
Dim tolCmd As Object
Dim cmdId As String, rUnits As String, gdtSym As String
Dim tempSizeMinus As Variant
Dim infoStr As String
' 开始遍历当前程序中的命令
For i = 1 To cmds.Count
Set cmd = cmds(i)
' 判断是否包含强类型几何公差命令
If cmd.IsToleranceCommand Then
' 提取核心公差控制对象
Set tolCmd = cmd.ToleranceCommand
cmdId = tolCmd.ID
rUnits = CStr(tolCmd.ReportUnits)
gdtSym = CStr(tolCmd.gdtSymbol)
' 元数据看板存入 CSV 末尾列
infoStr = "特征数:" & tolCmd.FeatureCount & " 尺寸数:" & tolCmd.sizeCountCombined & " 区段数:" & tolCmd.SegmentCount
' =================================================================
' 1. 尺寸组合数据段
' =================================================================
For j = 1 To tolCmd.sizeCountCombined
fields(0) = CStr(i)
fields(1) = cmdId
fields(2) = "尺寸"
fields(3) = CStr(j)
fields(4) = "1" ' 尺寸属于基础层，默认区段 1
fields(5) = CStr(tolCmd.sizeText(j))
fields(6) = CStr(tolCmd.SizeAxis(j))
fields(7) = rUnits
fields(8) = gdtSym
fields(9) = CStr(tolCmd.sizeNominal(j))
fields(10) = CStr(tolCmd.sizePlusTol(j))
' 应用负公差显示负号开关
tempSizeMinus = tolCmd.sizeMinusTol(j)
If IsNumeric(tempSizeMinus) And Not showNegative Then
fields(11) = CStr(-CDbl(tempSizeMinus))
Else
fields(11) = CStr(tempSizeMinus)
End If
fields(12) = CStr(tolCmd.sizeMeasured(j))
fields(13) = CStr(tolCmd.sizeDeviation(j))
fields(14) = CStr(tolCmd.sizeOutOfTol(j))
fields(15) = "" ' 尺寸层通常无实体补偿
fields(16) = infoStr
' 压入数组
lineCount = lineCount + 1
ReDim Preserve dataLines(0 To lineCount)
dataLines(lineCount) = joinCsvRowFields(fields, ",")
Next j
' =================================================================
' 2. 外层嵌套：区段数据段
' =================================================================
For k = 1 To tolCmd.SegmentCount
' 2a. 基准尺寸数据段
For j = 1 To tolCmd.datumSizeCount
fields(0) = CStr(i)
fields(1) = cmdId
fields(2) = "基准"
fields(3) = CStr(j)
fields(4) = CStr(k)
fields(5) = CStr(tolCmd.datumFosId(j))
fields(6) = ""
fields(7) = rUnits
fields(8) = gdtSym
fields(9) = CStr(tolCmd.datumFosNominal(j))
fields(10) = CStr(tolCmd.datumFosPlusTol(j))
fields(11) = CStr(tolCmd.datumFosMinusTol(j))
fields(12) = CStr(tolCmd.datumFosMeasured(j))
fields(13) = CStr(tolCmd.datumFosDeviation(j))
fields(14) = CStr(tolCmd.datumFosOutTol(j))
fields(15) = ""
fields(16) = infoStr
lineCount = lineCount + 1
ReDim Preserve dataLines(0 To lineCount)
dataLines(lineCount) = joinCsvRowFields(fields, ",")
Next j
' 2b. 位置几何公差数据段
For j = 1 To tolCmd.FeatureCount
fields(0) = CStr(i)
fields(1) = cmdId
fields(2) = "位置"
fields(3) = CStr(j)
fields(4) = CStr(k)
fields(5) = CStr(tolCmd.FeatureID(j))
fields(6) = CStr(tolCmd.SegmentAxis(j))
fields(7) = rUnits
fields(8) = gdtSym
' 双参数 (k, j) 多区段二维属性读取
fields(9) = CStr(tolCmd.SegmentDimNominal(k, j))
fields(10) = CStr(tolCmd.SegmentDimPlusTol(k, j))
fields(11) = CStr(tolCmd.segmentDimMinusTol(k, j))
fields(12) = CStr(tolCmd.SegmentDimMeasured(k, j))
fields(13) = CStr(tolCmd.SegmentDimDeviation(k, j))
fields(14) = CStr(tolCmd.SegmentDimOutTol(k, j))
fields(15) = CStr(tolCmd.SegmentDimBonus(k, j))
fields(16) = infoStr
lineCount = lineCount + 1
ReDim Preserve dataLines(0 To lineCount)
dataLines(lineCount) = joinCsvRowFields(fields, ",")
Next j
Next k
Set tolCmd = Nothing
End If
Next i
' 检查并保存文件
If lineCount > 0 Then
Dim isSuccess As Boolean
isSuccess = SaveCsv("C:\Temp\test.csv", dataLines, False)
If isSuccess Then
MsgBox "2022新型几何公差数据已成功保存至 C:\Temp\test.csv", 64, "保存成功"
End If
Else
MsgBox "未在当前测量程序中找到任何新型几何公差(ToleranceCommand)命令。", 48, "提示"
End If
' 资源释放
Set cmd = Nothing
Set cmds = Nothing
Set part = Nothing
Set app = Nothing
End Sub
PC-DMIS 基于 BASIC 的二次开发