我这种没技术的搬运工就不凑热闹了。
个人建议，你其实可以像6楼大神说的，报出你的预算。
你节省时间别人 ...
如果仅仅开个VIP会员就可以得到满意解决方案，也未尝不可。在运气面前我还是更相信米的动力，为付出买单才理所应当。只是尝试是否有哪路神仙兴趣上头、心血来潮小试牛刀了呢 看楼主的增加要求，没5K都不好接单的 本帖最后由 xiyanghxc 于 2025-4-19 08:55 编辑
试着用deepseek生成的，但运行报错，哪位大神指导一下，有偿感谢！
Sub ProcessDXF()
Dim origFilePath As String
Dim newFilePath As String
Dim layerMark As Layer, layerCut As Layer
Dim oldLayer As Layer
Dim group As Shape
Dim s As Shape
Dim doc As Document
Dim page As Page
Dim i As Integer
' 设置单位系统为毫米
Application.Unit = cdrMillimeter
' 选择DXF文件
With Application.FileDialog(cdrFileDialogOpen)
.Filter = "DXF 文件 (*.dxf)|*.dxf"
If .ShowOpen() <> -1 Then Exit Sub
origFilePath = .SelectedFiles(1)
End With
' 创建新文档
Set doc = Application.CreateDocument
Set page = doc.Pages(1)
' 导入DXF文件
doc.ImportEx origFilePath, cdrRangeAllPages, cdrAppendPage, cdrMillimeters, , , , "DXF"
' 群组所有对象
If doc.ActiveLayer.Shapes.Count > 0 Then
Set group = doc.ActiveLayer.Shapes.All.Group
Else
MsgBox "导入文件为空！"
Exit Sub
End If
' 检查并旋转方向
If group.SizeWidth > group.SizeHeight Then
group.Rotate 90, group.CenterX, group.CenterY
End If
' 设置页面尺寸
page.SetSize 320, 464
page.Orientation = cdrPortrait
' 居中对象
group.AlignToPage cdrAlignHCenter + cdrAlignVCenter
' 处理标记层
On Error Resume Next
Set layerMark = doc.Layers("标记层")
If layerMark Is Nothing Then Set layerMark = doc.CreateLayer("标记层")
For i = doc.Layers.Count To 1 Step -1
Set oldLayer = doc.Layers(i)
If oldLayer.Name = "标记层" And oldLayer.Index <> layerMark.Index Then
oldLayer.Shapes.All.MoveToLayer layerMark
oldLayer.Delete
End If
Next i
' 处理切割层
Set layerCut = doc.Layers("切割层")
If layerCut Is Nothing Then Set layerCut = doc.CreateLayer("切割层")
For i = doc.Layers.Count To 1 Step -1
Set oldLayer = doc.Layers(i)
If oldLayer.Name = "切割层" And oldLayer.Index <> layerCut.Index Then
oldLayer.Shapes.All.MoveToLayer layerCut
oldLayer.Delete
End If
Next i
' 调整图层顺序
layerMark.Order 1
layerCut.Order 2
' 解组所有对象
group.UngroupAll
' 移动圆形到标记层
For Each s In page.AllShapes
If s.Type = cdrEllipseShape Then
If Abs(s.SizeWidth - 5) < 0.001 And Abs(s.SizeHeight - 5) < 0.001 Then
s.MoveToLayer layerMark
End If
End If
Next s
' 移动剩余对象到切割层
For Each s In page.AllShapes
If s.Layer <> layerMark And s.Layer <> layerCut Then
s.MoveToLayer layerCut
End If
Next s
' 保存文件
newFilePath = Replace(origFilePath, ".dxf", ".cdr", 1, -1, vbTextCompare)
doc.SaveAs newFilePath, cdrVersion17
doc.Close
MsgBox "处理完成！保存路径：" & newFilePath
End Sub
页:
1
[2]