一种cdr图纸编号批量处理方法_自适应垫白框

相较之前版本，此次更新了垫白框的宽高处理问题，不在指定其宽高，使其图号字符串宽高自适应垫白框宽高的一种优化算法。

Sub DelTH()
'cdrpath = ThisDocument.FilePath
cdrpath = InputBox("请输入cdr文件路径:", "FilePath", "示例：D:\cdr") & "\"
th_old = InputBox("请输入cdr旧编号(任意一个):", "th_old ", "示例：RM.SDS1.920.000001")
cdrFile = Dir(cdrpath & "*.cdr")
Do While cdrFile <> ""
Set Doc = OpenDocument(cdrpath & cdrFile)
'================================================
TH = Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".", -1) - 1)
For Each pg In ActiveDocument.Pages
    xth = Left(TH, Len(TH) - 10)
'     qz = Left(th, Len(th) - 1)
'     xh = Right(th, 1)
'    xth = qz & xh

    For Each Atext In pg.ActiveLayer.Shapes
        If Atext.Type = cdrTextShape Then
            If Len(Atext.Text.Story.Text) >= Len(th_old) - 10 Then
                If Left(Atext.Text.Story.Text, Len(Atext.Text.Story.Text) - 10) = Left(th_old, Len(th_old) - 10) Then
                Atext.Delete
                End If
            End If
        End If
    Next
'    For Each Atext In pg.ActiveLayer.Shapes
'        If Atext.Type = cdrRectangleShape Then
'            If Atext.Outline.Type = cdrNoOutline Then
'            Atext.Delete
'            End If
'        End If
'    Next
Next
'================================================
ActiveDocument.Save
ActiveDocument.Close
cdrFile = Dir
Loop
End Sub
Sub FillTH()
'cdrpath = ThisDocument.FilePath
cdrpath = InputBox("请输入cdr文件路径：", "FilePath", "示例：E:\cdrFiles") & "\"
cdrFile = Dir(cdrpath & "*.cdr")
Do While cdrFile <> ""
Set Doc = OpenDocument(cdrpath & cdrFile)
'================================================
TH = Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".", -1) - 1)
For Each pg In ActiveDocument.Pages
    ' i = i + 1
    
'     qz0 = Left(TH, Len(TH) - 1)
'     qz1 = Left(TH, Len(TH) - 2)
'     xh = Right(TH, 1)
'        If xh >= 10 Then
'            xth = qz1 & xh
'        ElseIf xh < 10 Then
'                xth = qz0 & xh
'        End If

    xth = Replace(TH, "EN", "")
    
    'xth = qz + Str(xh)
    ActiveDocument.Unit = cdrMillimeter
    pgWidth = pg.SizeWidth - 2
    Dim s1 As Shape
    Set s1 = pg.ActiveLayer.CreateArtisticText(0, 0, xth, , , "Arial", 6)
'填充垫白层
    Dim s0 As Shape
    zk = s1.SizeWidth
    zh = s1.SizeHeight
'垫白框宽高及其坐标
    Set s0 = pg.ActiveLayer.CreateRectangle(pgWidth - zk, 2 + zh, pgWidth, 2)
    With s0
    .Outline.SetNoOutline
    .Fill.UniformColor.CMYKAssign 0, 0, 0, 0
    End With
    ActiveDocument.ReferencePoint = cdrBottomRight
    s0.SetPosition pgWidth, 2
'填充图号
    With s1
    .Fill.UniformColor.CMYKAssign 0, 0, 0, 100
    .Outline.SetNoOutline
    End With
    ActiveDocument.ReferencePoint = cdrBottomRight
    s1.SetPosition pgWidth, 2
    s0.OrderBackOf s1
Next
'================================================
ActiveDocument.Save
ActiveDocument.Close
cdrFile = Dir
Loop
End Sub