旗帜标签制作，刀型标签制作，网络标签制作，自动生成标签
<iframe allowfullscreen="true" data-mediaembed="csdn" frameborder="0" id="JdIVPRIq-1723626082776" src="https://live.csdn.net/v/embed/417198"></iframe>旗帜标签自动制作
网线标签的制作非常让人头疼，网线标签和旗帜标签用标签打印机非常慢，而且价格昂贵，用A4纸打印标签虽然快速，节省资源但是排版确实大问题，总是对不齐，浪费非常多的标签纸，往往1毫米的误差就导致整张纸作废，很是让人头疼，而且浪费非常多的时间来排版。
现在我们就这个问题，创造软件，让软件自动根据标签纸的尺寸和规律自动生成文本框，自动排版，只需要测量十来个参数就可以适配你购买的标签纸。
简单测量几个点的直线距离输入文本框，就可以自动根据你的购买的A4标签纸自动生成旗帜标签，一次设置终身使用。
下边就分享给大家核心部分源代码，大家可以二次开发和优化。
Private Sub cmd_ChuangJianWenDang_Click()
'创建旗帜标签
Dim ExcelPath$
Dim DataArray() As Variant
Dim wb As Workbook '必须引入excel库
Dim ws As Worksheet
Dim FieldName As String, SZ_FieldIndex() As Variant, iFieldIndex%
Dim BoxWidth As Double, BoxHeight As Double
Dim Txt_FountSize As Double
Dim i%, j%, jj%, J1%, J2%, Jx%, Jy%
Dim ZBJX#, SBJY#, Zbjx1#, Sbjy1#, StrX, StrY, JianGeX#, JianGeY#, X1#, Y1#, X2#, Y2#
Dim StrRow As Long, EndRow As Long
Dim NoOfPage%, BookMarkName$, BuChang%
ExcelPath = T_ExcelPath.Text
' 打开Excel文件
Set wb = Workbooks.Open(ExcelPath)
Set ws = wb.Sheets(1)
' 确定字段数据范围
Dim LastCol As Long
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
'文本框宽度13mm，高度40mm
'xy,起始坐标
'每行每列的间隔
BoxWidth = T_BoxWidth.Text
BoxHeight = T_BoxHeight.Text
ZBJX = T_ZBJX.Text
SBJY = T_SBJY.Text
Zbjx1 = T_ZBJX1.Text
Sbjy1 = T_SBJy1.Text
StrX = T_StrX.Text
StrY = T_StrY.Text
JianGeX = T_JianGeX.Text
JianGeY = T_JianGeY.Text
StrRow = T_StrRow.Text
EndRow = T_EndRow.Text
'根据字段内容，确定要打印的字段所在的列号
ReDim SZ_FieldIndex(1 To listZiDuan.ListCount)
DataArray = ReadExcel2SZ(ExcelPath, 1, 1, 1, LastCol)
iFieldIndex = 1
For j = 1 To listZiDuan.ListCount
' 查找字段在数组中的列索引
For i = 1 To UBound(DataArray, 2)
If DataArray(1, i) = listZiDuan.List(j - 1) Then
SZ_FieldIndex(iFieldIndex) = i
iFieldIndex = iFieldIndex + 1
End If
Next i
Next
'获取每行对应字段的内容，输入数组
ReDim dataarry(1 To EndRow)
DataArray = ReadExcel2SZBOX(ExcelPath, StrRow, EndRow, SZ_FieldIndex)
MoveToDocStart '光标移动到文档开始
'创建文本框
NoOfPage = T_NoOfPage.Text
Dim myPage%
myPage = 1
For i = LBound(DataArray) To UBound(DataArray)
j = i - 6 * (myPage - 1)
'一组间距9mm，两组之间间距8mm，需要做补偿
jj = j
Select Case jj
Case 1 To 5
'BuChang = -1
J1 = 1
J2 = 0
Jx = jj - 1
Jy = 0
'MsgBox Jx
Case 6 To 10
'BuChang = -1
J1 = 0
J2 = 1
Jx = jj - 1 - 5
Jy = 0
'MsgBox Jx
Case 11 To 15
'BuChang = -3
J1 = 1
J2 = 0
Jx = jj - 1 - 10
Jy = 1
Case 16 To 20
'BuChang = -3
J1 = 0
J2 = 1
Jx = jj - 1 - 15
Jy = 1
Case 21 To 25
'BuChang = -8
J1 = 1
J2 = 0
Jx = jj - 1 - 20
Jy = 2
Case 26 To 30
'BuChang = -9
J1 = 0
J2 = 1
Jx = jj - 1 - 25
Jy = 2
End Select
'X1 = ZBJX + StrX * (((j - 1) \ 5 + 1) Mod 2) + ((j - 1) Mod 5) * (BoxWidth) * 2 + ((j - 1) Mod 5) * JianGeX
'左边距+起始坐标奇数偶数不同+5的倍数不同+5的倍数间隔不同
'Y1 = SBJY + StrY + ((j - 1) \ 5) * (JianGeY + BoxHeight) + BuChang
X1 = J1 * ZBJX + J2 * Zbjx1 + Jx * (T_JianGeX.Text)
Y1 = J1 * SBJY + J2 * Sbjy1 + Jy * (T_JianGeY.Text)
X2 = X1 + BoxWidth
Y2 = Y1
Call CreateTextBoxFromData((DataArray(i)), BoxHeight, BoxWidth, X1, Y1, wdTextOrientationUpward)
Call CreateTextBoxFromData((DataArray(i)), BoxHeight, BoxWidth, X2, Y2, wdTextOrientationDownward)
'检查是否需要插入分页符
If i Mod NoOfPage = 0 And i <> UBound(DataArray) Then
Delay1 (1000)
MoveToDocEnd1 '将光标移动到当前页面底部
Delay1 (1000)
Selection.InsertBreak Type:=wdPageBreak
Delay1 (1000)
MoveToDocStart1 '将光标移动到下一页的开头
Delay1 (1000)
myPage = myPage + 1
Delay1 (1000) '毫秒
End If
Next i
End Sub
Sub MoveToDocEnd1()
Selection.EndKey Unit:=wdStory
End Sub
Sub MoveToDocStart1()
Selection.HomeKey Unit:=wdStory
End Sub
Public Sub CreateTextBoxFromData(ByVal BoxText As String, ByVal height As Double, ByVal width As Double, ByVal xCoord As Double, ByVal yCoord As Double, ByVal orientation As MsoTextOrientation)
'变量定义：field字段
'DATAARRAY:2维数组
'height：文本框高度
'width：文本框宽度
'xcoord：x绝对坐标
'ycoord：y绝对坐标
'orientation:方向
'autosize:自动尺寸
Dim fieldValue As Variant
Dim txtBox As Shape
Dim txtFrame As TextFrame
Dim txtRange As Range
Dim fontSize As Integer
Dim pt2mm As Double
pt2mm = 0.352778 'vba单位是pt，1pt=0.352778mm
height = height / pt2mm
width = width / pt2mm
xCoord = xCoord / pt2mm
yCoord = yCoord / pt2mm
' 创建文本框
Set txtBox = ActiveDocument.Shapes.AddTextbox(orientation, xCoord, yCoord, width, height)
With txtBox
'禁止随文字移动
.LockAnchor = True
' 固定文本框尺寸，禁止自动改变大小
.LockAspectRatio = msoTrue
' 设置文本框的填充为无色（透明）
.Fill.Visible = msoFalse
' 设置文本框的线条为无色（透明），即无边框
.Line.Visible = msoFalse
'设置文本框文本的边距,将0.1cm转化为VBA的点数，CentimetersToPoints函数
End With
With txtBox.TextFrame
.MarginLeft = CentimetersToPoints(0.2) ' 左边距
.MarginTop = CentimetersToPoints(0.5) ' 上边距
.MarginRight = CentimetersToPoints(0.1) ' 右边距
.MarginBottom = CentimetersToPoints(0.1) ' 下边距
End With
' 设置文本框文本
Set txtFrame = txtBox.TextFrame
Set txtRange = txtFrame.TextRange
txtFrame.VerticalAnchor = msoAnchorMiddle '文本框中文字垂直剧中
txtRange.Text = BoxText
' 设置文本为5号字
txtRange.Font.Size = T_FontSize.Text ' 注意：Word VBA中的字体大小单位是点（pt），5号字大约等于5/2=2.5磅
txtRange.Font.Name = "宋体" ' 更改字体，如果需要
' 设置固定行距为11磅
txtRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
txtRange.ParagraphFormat.LineSpacing = T_ZiJianJu.Text ' 单位是磅
Set txtBox = Nothing
End Sub
Private Function ReadExcel2SZBOX(ByVal iPath As String, ByVal iStrRow As Long, ByVal iEndRow As Long, ByVal iSz_FieldIndex As Variant) As Variant
'读取excel指定字段数组的内容，存入新数组
Dim ExcelPath$
Dim wb As Workbook '必须引入excel库
Dim ws As Worksheet
Dim tem_Str As String
Dim DataArray() As Variant
Dim i As Long, j As Long
ExcelPath = iPath
' 打开Excel文件
Set wb = Workbooks.Open(ExcelPath)
Set ws = wb.Sheets(1)
ReDim DataArray(1 To iEndRow - iStrRow + 1)
' 读取数据到数组
For i = iStrRow To iEndRow
tem_Str = ""
For j = LBound(iSz_FieldIndex) To UBound(iSz_FieldIndex)
tem_Str = tem_Str & ws.Cells(i, iSz_FieldIndex(j)).Value & vbCrLf
Next j
tem_Str = Left(tem_Str, Len(tem_Str) - 2) '去掉最后一个回车
DataArray(i - iStrRow + 1) = tem_Str
Next i
' 关闭Excel文件
wb.Close SaveChanges:=False
ReadExcel2SZBOX = DataArray
End Function
Public Function ReadExcel2SZ(ByVal iPath As String, ByVal iStrRow As Long, ByVal iEndRow As Long, ByVal iStrCol As Long, ByVal iEndCol As Long) As Variant
Dim ExcelPath$
Dim wb As Workbook '必须引入excel库
Dim ws As Worksheet
Dim DataArray() As Variant
Dim i As Long, j As Long
ExcelPath = iPath
' 打开Excel文件
Set wb = Workbooks.Open(ExcelPath)
Set ws = wb.Sheets(1)
' 确定数据范围
Dim lastRow As Long, LastCol As Long
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
If lastRow > 0 And LastCol > 0 Then
ReDim DataArray(1 To lastRow, 1 To LastCol)
' 读取数据到数组
For i = iStrRow To iEndRow
For j = iStrCol To iEndCol
DataArray(i, j) = ws.Cells(i, j).Value
Next j
Next i
Else
Debug.Print "No data found in the worksheet."
End If
' 关闭Excel文件
wb.Close SaveChanges:=False
ReadExcel2SZ = DataArray
End Function
'===================================================
Public Sub chushihua_qizhibiaoqian()
Combox_FangXiang.AddItem "正,反"
Combox_FangXiang.AddItem "反,正"
Combox_FangXiang.AddItem "正"
Combox_FangXiang.ListIndex = 0
End Sub
'===========================================================================================================
Public Function del_StrEnter(ByVal iStr As String)
'去除换行符
Dim str As String
str = iStr
' 移除开头和结尾的回车符
str = Replace(str, vbCrLf, "", 1, 1) ' 移除开头的回车符
str = Replace(str, vbCrLf, "", , 1) ' 移除结尾的回车符
' 由于Replace函数只移除了回车符，你可能还需要移除换行符("\n")
str = Replace(str, vbCrLf, "", 1, 1) ' 移除开头的换行符
str = Replace(str, vbCrLf, "", , 1) ' 移除结尾的换行符
' 最后，使用Trim移除两端的空白字符
str = Trim(str)
del_StrEnter = str
End Function
Public Sub CreateTextBoxFromData(ByVal BoxText As String, ByVal height As Double, ByVal width As Double, ByVal xCoord As Double, ByVal yCoord As Double, ByVal orientation As MsoTextOrientation)
'变量定义：field字段
'DATAARRAY:2维数组
'height：文本框高度
'width：文本框宽度
'xcoord：x绝对坐标
'ycoord：y绝对坐标
'orientation:方向
'autosize:自动尺寸
Dim fieldValue As Variant
Dim txtBox As Shape
Dim txtFrame As TextFrame
Dim txtRange As Range
Dim fontSize As Integer
Dim pt2mm As Double
pt2mm = 0.352778 'vba单位是pt，1pt=0.352778mm
height = height / pt2mm
width = width / pt2mm
xCoord = xCoord / pt2mm
yCoord = yCoord / pt2mm
' 创建文本框
Set txtBox = ActiveDocument.Shapes.AddTextbox(orientation, xCoord, yCoord, width, height)
With txtBox
'禁止随文字移动
.LockAnchor = True
' 固定文本框尺寸，禁止自动改变大小
.LockAspectRatio = msoTrue
' 设置文本框的填充为无色（透明）
.Fill.Visible = msoFalse
' 设置文本框的线条为无色（透明），即无边框
.Line.Visible = msoFalse
'设置文本框文本的边距,将0.1cm转化为VBA的点数，CentimetersToPoints函数
End With
With txtBox.TextFrame
.MarginLeft = CentimetersToPoints(0.2) ' 左边距
.MarginTop = CentimetersToPoints(0.5) ' 上边距
.MarginRight = CentimetersToPoints(0.1) ' 右边距
.MarginBottom = CentimetersToPoints(0.1) ' 下边距
End With
' 设置文本框文本
Set txtFrame = txtBox.TextFrame
Set txtRange = txtFrame.TextRange
txtFrame.VerticalAnchor = msoAnchorMiddle '文本框中文字垂直剧中
txtRange.Text = BoxText
' 设置文本为5号字
txtRange.Font.Size = T_FontSize.Text ' 注意：Word VBA中的字体大小单位是点（pt），5号字大约等于5/2=2.5磅
txtRange.Font.Name = "宋体" ' 更改字体，如果需要
' 设置固定行距为11磅
txtRange.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
txtRange.ParagraphFormat.LineSpacing = T_ZiJianJu.Text ' 单位是磅
Set txtBox = Nothing
End Sub
' 将厘米转换为点的函数
Function CentimetersToPoints(cm As Double) As Double
CentimetersToPoints = cm * 28.3464567 ' 1厘米=28.3464567点
End Function
Private Sub Cmd_cjwh_Click()
Dim i%, j%, k%
Dim n_Str%, n_End%
Dim s_Stic$, s_New$
n_Str = Asc(T_wh_str.Text)
n_End = Asc(T_wh_end.Text)
s_Stic = T_weihao.Text
For i = n_Str To n_End
If i <= 57 Or i >= 65 Then '排除特殊字符，保留0-9，A-F
s_New = s_Stic & Chr(i) & T_wh_hz.Text
T_INS.Text = T_INS.Text & s_New & vbCrLf
End If
Next i
End Sub
Private Sub Cmd_clr_zt_Click()
T_Equ.Text = ""
End Sub