文章目录
-
- 问题引入
- 思路
- 效果
- 参数
- 实现
问题引入
制作可燃气体检测报警系统气体探头（即气体检测报警仪）位号标签
思路
- 创建艺术文本对象，填入字符。连续编号用遍历循环即可，Format函数加前导零。亦可通过读取Office对象（Excel）中的内容提取需要填入的位号，时间有限，本文不做探讨。后续在《VBA实例4 Excel隐患排查治理台账》详细讲解。
- 根据组合所在行列调整水平位置和垂直位置。
- 同样的思路也可用于反应釜位号、仪表位号等批量创建。
效果
懒得插视频了，视频审核万把年……
参数
主要用到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
| 参数 | 描述 | 默认值 |
|---|---|---|
| Left | 指定左边水平位置 | 默认值为0 |
| Bottom | 指定底部垂直位置 | 默认值为0 |
| Text | 指定艺术文本的内容 | 需填入的文本内容 |
| LanguageID | 指定的语言 | 可选，默认值为cdrLanguageNone(0) |
| CharSet | 指定字符集。 | 可选，默认值为cdrCharSetMixed(-1) |
| Font | 指定字体 | 可选，CDR默认字体 |
| Size | 指定字体大小 | 可选，默认值为0 |
| Bold | 指定是否应用粗体 | 可选，默认值为cdrUndefined(-2) |
| Italic | 指定是否应用斜体 | 可选，默认值为cdrUndefined(-2) |
| Underline | 指定要应用的下划线 | 可选，默认值为cdrMixedFontLine(7) |
| Alignment | 指定对齐 | 可选，默认值为cdrMixedAlignment(6) |
实现
Function drawOne(x0 As Double, y0 As Double, i As String) As ShapeDim s1 As Shape, s2 As Shape, s3 As Shape, s4 As ShapeDim cm As Doublecm = 1 / 2.54Set 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, 2Set drawOne = s2
End FunctionSub draw_one()Dim s2 As Shape, arr(), count As Integer, shp As ShapeSet s2 = drawOne(0, 0, "01")ReDim Preserve arr(count)arr(count) = s2.ZOrderFor Each shp In ThisDocument.ActiveLayer.ShapesDebug.Print shp.StaticIDDebug.Print shp.ZOrderThisDocument.ActiveLayer.Shapes(shp.ZOrder).CreateSelectionNext shpActiveLayer.CreateArtisticText LeftThisDocument.ActiveLayer.Shapes.All.CreateSelection
End SubSub drawMore()Dim s2 As Shape, arr(), count As Integer, shp As ShapeDim idx, curRow, curColDim x As Double, y As Double, i As String, cm As DoubleDim startTime As Single, endTime As SinglestartTime = Timercm = 1 / 2.54For idx = 1 To 40x = curCol * 5 * cmy = curRow * -10 * cmi = Format(idx, "00")Debug.Print iSet s2 = drawOne(x, y, i)ReDim Preserve arr(count)Set arr(count) = s2count = count + 1If (idx Mod 10) = 0 ThencurRow = curRow + 1curCol = 0ElsecurCol = curCol + 1End IfNext idxThisDocument.CreateShapeRangeFromArray(arr).CreateSelectionendTime = Timer - startTimetempString = "Create all shapes successful." & vbCrLf & _"It takes " & Format(Timer - startTime, "0.000") & " seconds."ThisDocument.ActiveWindow.ActiveView.ToFitAllObjectsMsgBox tempString, Title:=Now()' Call deleteAll
End SubSub deleteAll()ThisDocument.ActiveLayer.Shapes.All.CreateSelectionThisDocument.Selection.Delete
End Sub