博客

问题引入

制作可燃气体检测报警系统气体探头（即气体检测报警仪）位号标签

思路

1. 创建艺术文本对象，填入字符。连续编号用遍历循环即可，Format函数加前导零。亦可通过读取Office对象（Excel）中的内容提取需要填入的位号，时间有限，本文不做探讨。后续在《VBA实例4 Excel隐患排查治理台账》详细讲解。
2. 根据组合所在行列调整水平位置和垂直位置。
3. 同样的思路也可用于反应釜位号、仪表位号等批量创建。

效果

懒得插视频了，视频审核万把年……

参数

主要用到Layer.CreateArtisticText方法

Function CreateArtisticText(Left As Double, Bottom As Double, Text As String, 
	[LanguageID As cdrTextLanguage = cdrLanguageNone], 
	[CharSet As cdrTextCharSet = cdrCharSetMixed], [Font As String], 
	[Size As Single], 
	[Bold As cdrTriState = cdrUndefined], 
	[Italic As cdrTriState = cdrUndefined], 
	[Underline As cdrFontLine = cdrMixedFontLine], 
	[Alignment As cdrAlignment = cdrMixedAlignment]) As Shape
VGCore.Layer 的成员
Creates artistic text on a layer

实现

Function drawOne(x0 As Double, y0 As Double, i As String) As Shape
    Dim s1 As Shape, s2 As Shape, s3 As Shape, s4 As Shape
    Dim cm As Double
    cm = 1 / 2.54
    
    Set s1 = Application.ActiveLayer.CreateArtisticText(x0, y0 + 59.2 * cm, "100", _
        Font:="Times New Roman", Size:=24, Bold:=cdrTrue)
    Set s2 = Application.ActiveLayer.CreateArtisticText(x0, y0 + 55.7 * cm, "气体报警器", _
        Font:="SimHei", Size:=30, Bold:=cdrTrue)
    Set s3 = Application.ActiveLayer.CreateArtisticText(x0, y0 + 52.2 * cm, i, _
        Font:="Times New Roman", Size:=24, Bold:=cdrTrue)
    
    Set s4 = Application.ActiveLayer.CreateRectangle(x0, y0 + 60 * cm, x0 + 2.5 * cm, y0 + 52 * cm)
    
    Application.ActiveDocument.CreateShapeRangeFromArray(s1, s2, s3, s4).AlignAndDistribute 3, 0, 0, 0, False, 2
    
    Set drawOne = s2
End Function

Sub draw_one()
    Dim s2 As Shape, arr(), count As Integer, shp As Shape
    
    Set s2 = drawOne(0, 0, "01")
    ReDim Preserve arr(count)
    arr(count) = s2.ZOrder
    
    For Each shp In ThisDocument.ActiveLayer.Shapes
        Debug.Print shp.StaticID
        Debug.Print shp.ZOrder
        ThisDocument.ActiveLayer.Shapes(shp.ZOrder).CreateSelection
    Next shp
    
    ActiveLayer.CreateArtisticText Left
    
    ThisDocument.ActiveLayer.Shapes.All.CreateSelection
End Sub

Sub drawMore()
    Dim s2 As Shape, arr(), count As Integer, shp As Shape
    Dim idx, curRow, curCol
    Dim x As Double, y As Double, i As String, cm As Double
    Dim startTime As Single, endTime As Single
    startTime = Timer
    
    cm = 1 / 2.54
    For idx = 1 To 40
        x = curCol * 5 * cm
        y = curRow * -10 * cm
        i = Format(idx, "00")
        Debug.Print i
        
        Set s2 = drawOne(x, y, i)
        ReDim Preserve arr(count)
        Set arr(count) = s2
        count = count + 1
        
        If (idx Mod 10) = 0 Then
            curRow = curRow + 1
            curCol = 0
        Else
            curCol = curCol + 1
        End If
    Next idx
    
    ThisDocument.CreateShapeRangeFromArray(arr).CreateSelection
    
    endTime = Timer - startTime
    tempString = "Create all shapes successful." & vbCrLf & _
        "It takes " & Format(Timer - startTime, "0.000") & " seconds."
    
    ThisDocument.ActiveWindow.ActiveView.ToFitAllObjects
        
    MsgBox tempString, Title:=Now()
    
'    Call deleteAll
End Sub

Sub deleteAll()
    ThisDocument.ActiveLayer.Shapes.All.CreateSelection
    ThisDocument.Selection.Delete
End Sub