Attribute VB_Name = "NewMacros"
Sub ConvertToEAN8()
'
' Konvertuje označený číselný řetězec, maximálně sedmiznakový, na
' čárový kód typu EAN8, resp. UPC-E
'
' MsgBox Str(ActiveWindow.ActivePane.View.SeekView) + ", " + Str(wdSeekCurrentPageHeader) + ", " + Str(wdSeekCurrentPageFooter)
' Set ssel = ActiveWindow.ActivePane.Selection
' Exit Sub
    Const bcfontfam As String = "CarovyKod", ocrfontfam As String = "OCR-B-10 BT"
    Const bcfontsize As Integer = 30, bcguardsize As Integer = 35, bcfontposition As Single = 4.5
    Const ocrfontsize As Integer = 12, ocrfontspacing = -1
'    Const bcfontsize As Integer = 48, bcguardsize As Integer = 53, ocrfontsize As Integer = 12, ocrfontspacing = -1
    Const asc0 As Integer = 48, gbar As String * 3 = "AaA", cbar As String * 5 = "aAaAa"
'    Const asc0 As Integer = 48, gbar As String * 3 = "NnN", cbar As String * 5 = "nNnNn"
    Dim ldop(0 To 9) As String, rdep(0 To 9) As String
    Dim iean As String * 7, oean As String * 8, cean As String, s As String
    Dim sstart As Integer, I As Integer, c As Integer, flen As Integer, slen As Integer
    Dim sel, tb As Shape
    
' pro Dobson2of9
'    ldop(0) = "wNNnN"
'    ldop(1) = "nnNNnnN"
'    ldop(2) = "nnNnnNN"
'    ldop(3) = "nWNnN"
'    ldop(4) = "nNwNN"
'    ldop(5) = "nNNWn"
'    ldop(6) = "nNnWN"
'    ldop(7) = "nWnNN"
'    ldop(8) = "nNNnW"
'    ldop(9) = "wNnNN"
'    rdep(0) = "WnnNn"
'    rdep(1) = "NNnnNNn"
'    rdep(2) = "NNnNNnn"
'    rdep(3) = "NwnNn"
'    rdep(4) = "NnWnn"
'    rdep(5) = "NnnWn"
'    rdep(6) = "NnNwn"
'    rdep(7) = "NwNnn"
'    rdep(8) = "NnnNw"
'    rdep(9) = "WnNnn"
    
' pro CarovyKod
'    ldop = Array("cBaA", "bBbA", "bAbB", "aDaA", "aAcB", "aBcA", "aAaD", "aCaB", "aBaC", "cAaB")
    ldop(0) = "cBaA"
    ldop(1) = "bBbA"
    ldop(2) = "bAbB"
    ldop(3) = "aDaA"
    ldop(4) = "aAcB"
    ldop(5) = "aBcA"
    ldop(6) = "aAaD"
    ldop(7) = "aCaB"
    ldop(8) = "aBaC"
    ldop(9) = "cAaB"
    rdep(0) = "CbAa"
    rdep(1) = "BbBa"
    rdep(2) = "BaBb"
    rdep(3) = "AdAa"
    rdep(4) = "AaCb"
    rdep(5) = "AbCa"
    rdep(6) = "AaAd"
    rdep(7) = "AcAb"
    rdep(8) = "AbAc"
    rdep(9) = "CaAb"
    
    Set sel = Selection
    If Not IsNumeric(sel.Text) Then
        MsgBox prompt:="Řetězec vybraný pro konverzi (" + sel.Text + ") musí odpovídat číslu!", Title:="Chyba konverze do kódu EAN8", buttons:=vbOKOnly + vbCritical
        Exit Sub
    End If
    sstart = Selection.Start
    iean = sel.Text
    Do While Right(iean, 1) = " "
        iean = "0" + Left(iean, Len(iean) - 1)
    Loop
    oean = iean
    c = 0
    For I = 1 To Len(iean)
        If I Mod 2 = 0 Then ' sudá poloha
            c = c + (Asc(Mid(iean, I, 1)) - asc0)
        Else ' lichá poloha
            c = c + ((Asc(Mid(iean, I, 1)) - asc0) * 3)
        End If
    Next I
    If c Mod 10 = 0 Then
        c = 0
    Else
        c = ((Int(c / 10) + 1) * 10) - c
    End If
    oean = Replace(oean, " ", Chr(asc0 + c))
    cean = gbar
    c = Len(oean) / 2
    flen = 0
    For I = 1 To c
        s = ldop(Asc(Mid(oean, I, 1)) - asc0)
        cean = cean + s
        flen = flen + Len(s)
    Next I
    cean = cean + cbar
    slen = 0
    For I = c + 1 To Len(oean)
        s = rdep(Asc(Mid(oean, I, 1)) - asc0)
        cean = cean + s
        slen = slen + Len(s)
    Next I
    cean = cean + gbar
    With Selection
'        .CreateTextbox
        .Text = cean
        With .Font
            .Name = bcfontfam
            .Size = bcfontsize
            .Scaling = 60
        End With
        ' úprava čárového kódu
        .SetRange Start:=sstart, End:=sstart
        .MoveRight Unit:=wdCharacter, Count:=Len(gbar), Extend:=wdExtend
        .Font.Size = bcguardsize
        .Start = Selection.Start + Len(gbar)
        .MoveRight Unit:=wdCharacter, Count:=flen + 1, Extend:=wdExtend
        .Font.Position = bcfontposition
        .Start = Selection.Start + flen + 1
        .MoveRight Unit:=wdCharacter, Count:=Len(cbar) - 2, Extend:=wdExtend
        .Font.Size = bcguardsize
        .Start = Selection.Start + Len(cbar) - 2
        .MoveRight Unit:=wdCharacter, Count:=slen, Extend:=wdExtend
        .Font.Position = bcfontposition
        .Start = Selection.Start + slen + 1
        .MoveRight Unit:=wdCharacter, Count:=Len(gbar), Extend:=wdExtend
        .Font.Size = bcguardsize
        .Start = Selection.End
    End With
'    Set tb = ActiveDocument.Sections(3).Footers(wdHeaderFooterPrimary).Shapes.AddTextbox(msoTextOrientationHorizontal, 11, bcguardsize, 40, 10, sel)
'    Set tb = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes.AddTextbox(msoTextOrientationHorizontal, MillimetersToPoints(1.3), bcguardsize, MillimetersToPoints(12), MillimetersToPoints(3.2), sel)
    Set tb = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, MillimetersToPoints(1.3), bcguardsize, MillimetersToPoints(12), MillimetersToPoints(3.2), sel)
    With tb
        .Fill.Visible = False
        .Line.Visible = False
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionCharacter
        .Width = (Len(oean) / 2) * 1.2 * .TextFrame.TextRange.CharacterWidth
        .Left = MillimetersToPoints(1.3)
'        .LockAnchor = True
        With .TextFrame
            .TextRange.FitTextWidth = True
            .MarginBottom = 0
            .MarginLeft = 0
            .MarginRight = 0
            .MarginTop = 0
            With .TextRange
                .FitTextWidth = True
                With .Font
                    .Name = ocrfontfam
                    .Size = ocrfontsize
                    .Spacing = ocrfontspacing
                End With
                .Text = Left(oean, Len(oean) / 2)
            End With
        End With
    End With
    Set tb = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, CentimetersToPoints(1.13), bcguardsize, MillimetersToPoints(12), MillimetersToPoints(3.2), sel)
    With tb
        .Fill.Visible = False
        .Line.Visible = False
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionCharacter
        .Width = (Len(oean) / 2) * 1.2 * .TextFrame.TextRange.CharacterWidth
        .Left = CentimetersToPoints(1.13)
'        .LockAnchor = True
        With .TextFrame
            .MarginBottom = 0
            .MarginLeft = 0
            .MarginRight = 0
            .MarginTop = 0
            With .TextRange
                .FitTextWidth = True
                With .Font
                    .Name = ocrfontfam
                    .Size = ocrfontsize
                    .Spacing = ocrfontspacing
                End With
                .Text = Right(oean, Len(oean) / 2)
            End With
        End With
    End With
    Selection.SetRange Start:=sstart, End:=sstart
End Sub

Sub ConvertToCode128()
'
' Konvertuje označený alfanumerický řetězec na čárový kód typu Code128(A,B,C)
'
'Const bcfontfam As String = "Code 128", ocrfontfam As String = "OCR-B-10 BT"
Const bcfontfam As String = "Code128bWin", ocrfontfam As String = "OCR-B-10 BT"
Const bcfontsize As Integer = 24, ocrfontsize As Integer = 12
Dim stocode As String

With Selection
    stocode = .Text
    .Text = Code128Utils.Code128B(stocode)
    With .Font
        .Name = bcfontfam
        .Size = bcfontsize
    End With
'    .CreateTextbox
    .EndKey Unit:=wdLine
End With
With Selection
    .TypeParagraph
    With .Font
        .Name = ocrfontfam
        .Size = ocrfontsize
    End With
    .TypeText Text:=stocode
    .MoveUp Unit:=wdLine
    .EndKey Unit:=wdLine
    .MoveRight Unit:=wdCharacter, Extend:=True
    With .Font
        .Name = "Times New Roman"
        .Size = 12
    End With
    .EndKey Unit:=wdLine
End With
With Selection
    .ParagraphFormat.KeepWithNext = True
    .MoveDown Unit:=wdLine, Extend:=True
End With
With Selection
    .ParagraphFormat.Alignment = wdAlignParagraphCenter
    .EndKey Unit:=wdLine
End With
End Sub

Sub ToEAN8All()
'
' Konvertuje všechny řetězce napsané písmem Curier New velikosti 10 na čárový kód EAN8.
' Řetězec musí odpovídat číslu, ve kterém je maximálně 7 cifer.
' Pokud některý řetězec nevyhovuje předchozí podmínce, otevře se okno s varovnou zprávou
' a řetězec se změní na velikost písma 11.
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Font.Name = "Courier New"
        .Font.Size = 10
    End With
    Selection.HomeKey Unit:=wdStory
    Selection.Find.Execute
    Do While Selection.Find.Found
        Selection.Font.Size = 11
        If Asc(Right(Selection.Text, 1)) = 13 Then
            Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        End If
        ConvertToEAN8
        Selection.HomeKey Unit:=wdStory
        Selection.Find.Execute
    Loop
End Sub

Sub ToCode128All()
'
' Konvertuje všechny řetězce napsané písmem Curier New velikosti 9 na čárový kód Code128.
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Font.Name = "Courier New"
        .Font.Size = 9
    End With
    Selection.HomeKey Unit:=wdStory
    Selection.Find.Execute
    Do While Selection.Find.Found
        Selection.Font.Size = 11
        If Asc(Right(Selection.Text, 1)) = 13 Then
            Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        End If
        ConvertToCode128
        Selection.HomeKey Unit:=wdStory
        Selection.Find.Execute
    Loop
End Sub