寻求一个将dxf文件批量转换成cdr的插件或动作

alexcc

这个要求，应该是要单独开发的。

xiyanghxc

yiweimeigong 发表于 2025-4-14 10:02
我这种没技术的搬运工就不凑热闹了。
个人建议，你其实可以像6楼大神说的，报出你的预算。
你节省时间别人 ...

如果仅仅开个VIP会员就可以得到满意解决方案，也未尝不可。在运气面前我还是更相信米的动力，为付出买单才理所应当。只是尝试是否有哪路神仙兴趣上头、心血来潮小试牛刀了呢

zhgx998

看楼主的增加要求，没5K都不好接单的

xiyanghxc

试着用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