旗帜标签制作，刀型标签制作，网络标签制作，自动生成标签

旗帜标签制作，刀型标签制作，网络标签制作，自动生成标签

旗帜标签自动制作

网线标签的制作非常让人头疼，网线标签和旗帜标签用标签打印机非常慢，而且价格昂贵，用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