麻烦哪位大佬指证一下代码错误

ufong13 · 发表于 5 天前

经典图书

下面的宏代码用于在配置特定中自动生成项目号一栏，当文件名格式为E2401A000000000 零件，文件号的前6号代表了项目号，E为项目属性，24为年代号，代表2024年，01为项目序号，代表24年第一个项目号，A代表设备数量，A表示此项目只有一台设备，如果是B就表示此项目有两台设备，当项目只有一台设备时项目号格式就是E2024-01-1，最后的-1省略不做，项目号即为E2024-01。当项目有两台的设备时，文件名为E2401B000000000 零件,项目号就需要在最后加写上与B对应的-2，即项目号为E2024-01-2。

宏运行时提示用户定义类型未定义

Sub SetProjectNumberFromFileName()
Dim swApp As SldWorks.SldWorks
Dim Part As SldWorks.ModelDoc2
Dim custPropMgr As SldWorks.CustomPropertyManager
Dim fileName As String
Dim filePath As String
Dim projectCode As String
Dim projectYear As String
Dim projectNumber As String
Dim deviceCount As String
Dim finalProjectNumber As String
' 获取SolidWorks应用程序对象
Set swApp = Application.SldWorks
' 检查是否有活动文档
If swApp.ActiveDoc Is Nothing Then
MsgBox "没有打开的文档", vbExclamation
Exit Sub
End If
' 获取活动文档
Set Part = swApp.ActiveDoc
' 确保是零件文档
If Not TypeOf Part Is SldWorks.ModelDoc2 Then
MsgBox "当前文档不是零件文档", vbExclamation
Exit Sub
End If
' 获取文件名和路径
filePath = Part.GetPathName
fileName = Dir(filePath)
' 提取项目号信息
' 假设文件名格式为 "E2401A000000000 零件.sldprt" 或 "E2401B000000000 零件.sldprt"
projectCode = Left(fileName, 7) ' 提取前7个字符
projectYear = Mid(projectCode, 2, 2) ' 提取年份后两位
projectYear = "20" & projectYear ' 转换为完整的年份格式
projectNumber = Mid(projectCode, 4, 2) ' 提取项目序号
deviceCount = Mid(projectCode, 7, 1) ' 提取设备数量标识
' 根据设备数量格式化最终的项目号
If deviceCount = "A" Then
finalProjectNumber = "E" & projectYear & "-" & projectNumber
ElseIf deviceCount = "B" Then
finalProjectNumber = "E" & projectYear & "-" & projectNumber & "-2"
Else
MsgBox "无法识别的设备数量标识：" & deviceCount, vbExclamation
Exit Sub
End If
' 获取特定配置的自定义属性管理器
' 注意：这里假设我们操作的是默认配置，如果要针对特定配置，需要额外处理
Set custPropMgr = Part.Extension.CustomPropertyManager("") ' 空字符串表示默认配置
' 尝试设置或更新项目号自定义属性
Dim errCode As Long
errCode = custPropMgr.Add2("项目号", finalProjectNumber, swCustomInfo_ConfigurationSpecific, swCustPropertyTypeText, "")
' 如果属性已存在，则更新它
If errCode = swCustomPropertyInfo_AlreadyExists Then
errCode = custPropMgr.Edit2("项目号", finalProjectNumber, swCustomInfo_ConfigurationSpecific, swCustPropertyTypeText)
End If
' 检查是否有错误
If errCode <> 0 And errCode <> swCustomPropertyInfo_AlreadyExists Then
MsgBox "设置自定义属性时出错：" & errCode, vbExclamation
Else
MsgBox "项目号已成功设置为：" & finalProjectNumber, vbInformation
End If
' 清理
Set custPropMgr = Nothing
Set Part = Nothing
Set swApp = Nothing
End Sub

复制代码

沉默的人 · 发表于 4 天前

顶一下，坐等高手！

wjbg2019 · 发表于 4 天前

经典图书

那一句报错？

ufong13 · 发表于 4 天前

已经解决了，我把图号分离的代码与上面项目号的代码合在一起了，现在可能实现项目号、图号、名称根据文件名进行自动填写，下一步准备解决根据文件名自动识别填写材料号、焊接件、组件及部件

Dim a As Integer
Dim b As String
Dim m As String
Dim e As String
Dim k As String
Dim t As String
Dim c As String
Dim j As Integer
Dim strmat As String
Dim tempvalue As String
Dim Part As SldWorks.ModelDoc2
Dim swApp As SldWorks.SldWorks
Dim swModelDoc As SldWorks.ModelDoc2
Dim swConfig As SldWorks.Configuration
Dim CustPropMgr As SldWorks.CustomPropertyManager
Dim swModel As SldWorks.ModelDoc2
Dim projectCode As String
Dim projectYear As String
Dim projectNumber As String
Dim deviceCount As String
Dim finalProjectNumber As String
Dim fileName As String
Dim filePath As String
Sub main()
Set swApp = Application.SldWorks
Set swModelDoc = swApp.ActiveDoc
Set swConfig = swModelDoc.ConfigurationManager.ActiveConfiguration
Set swModel = swApp.ActiveDoc
Set CustPropMgr = swModel.Extension.CustomPropertyManager(swModel.ConfigurationManager.ActiveConfiguration.Name)
'设定变量
c = swApp.ActiveDoc.GetTitle() '零件名
strmat = Chr(34) + Trim("SW-Material" + "@") + c + Chr(34)
a = InStr(c, " ") - 1 '重点：分隔标识符，这里是一个空格，也可换成其他符号
If a > 0 Then
k = Left(c, a)
t = Left(LTrim(e), 3)
If t = "GBT" Then
e = "GB/T" + Mid(k, 4)
Else
e = k
End If
b = Mid(c, a + 2)
t = Right(c, 7)
If t = ".SLDPRT" Or t = ".SLDASM" Or t = ".sldprt" Or t = ".sldasm" Then
j = Len(b) - 7
Else
j = Len(b)
End If
m = Left(b, j)
End If
' 获取SolidWorks应用程序对象
Set swApp = Application.SldWorks
' 检查是否有活动文档
If swApp.ActiveDoc Is Nothing Then
MsgBox "没有打开的文档", vbExclamation
Exit Sub
End If
' 获取活动文档
Set Part = swApp.ActiveDoc
' 确保是零件文档
If Not TypeOf Part Is SldWorks.ModelDoc2 Then
MsgBox "当前文档不是零件文档", vbExclamation
Exit Sub
End If
' 获取文件名和路径
filePath = Part.GetPathName
fileName = Dir(filePath)
' 提取项目编号信息
' 假设文件名格式为 "E2401A000000000 零件.sldprt" 或 "E2401B000000000 零件.sldprt"
projectCode = Left(fileName, 7) ' 提取前7个字符
projectYear = Mid(projectCode, 2, 2) ' 提取年份后两位
projectYear = "20" & projectYear ' 转换为完整的年份格式
projectNumber = Mid(projectCode, 4, 2) ' 提取项目序号
deviceCount = Mid(projectCode, 6, 1) ' 提取设备数量标识
' 根据设备数量格式化最终的项目编号
If deviceCount = "A" Then
finalProjectNumber = "E" & projectYear & "-" & projectNumber
ElseIf deviceCount = "B" Then
finalProjectNumber = "E" & projectYear & "-" & projectNumber & "-2"
ElseIf deviceCount = "C" Then
finalProjectNumber = "E" & projectYear & "-" & projectNumber & "-3"
ElseIf deviceCount = "D" Then
finalProjectNumber = "E" & projectYear & "-" & projectNumber & "-4"
ElseIf deviceCount = "E" Then
finalProjectNumber = "E" & projectYear & "-" & projectNumber & "-5"
ElseIf deviceCount = "F" Then
finalProjectNumber = "E" & projectYear & "-" & projectNumber & "-6"
ElseIf deviceCount = "G" Then
finalProjectNumber = "E" & projectYear & "-" & projectNumber & "-7"
ElseIf deviceCount = "H" Then
finalProjectNumber = "E" & projectYear & "-" & projectNumber & "-8"
ElseIf deviceCount = "I" Then
finalProjectNumber = "E" & projectYear & "-" & projectNumber & "-9"
Else
MsgBox "无法识别的设备数量标识：" & deviceCount, vbExclamation
Exit Sub
End If
'删除原有
CustPropMgr.Delete ("项目编号")
CustPropMgr.Delete ("代号")
CustPropMgr.Delete ("名称")
'新增
CustPropMgr.Add2 "项目编号", swCustomInfoText, finalProjectNumber
CustPropMgr.Add2 "代号", swCustomInfoText, e
CustPropMgr.Add2 "名称", swCustomInfoText, m
End Sub

复制代码

tantingshuai123 · 发表于 3 天前

经典案例图书

好东西，努力学习学习！

		自动登录	找回密码
密码			立即注册

麻烦哪位大佬指证一下代码错误

最佳新人

活跃会员

热心会员

宣传达人

灌水之王

突出贡献