Barcode 128 in Grafik umwandeln

Code:
Sub Code128()

    Dim Text As String

    Dim TempPfad As String

    Dim ZintPfad As String

    Dim Skalierung As String

    Dim Befehl As String

    

    ActiveDocument.Unit = cdrMillimeter

    

    ZintPfad = WoIstZint

    TempPfad = Environ("TEMP") & "\"

    

    Skalierung = "1.5"

    a = Chr(34)

    If ActiveDocument.Selection.Shapes.Count = 0 Then

        MsgBox "nichts ausgewählt!", vbExclamation

        Exit Sub

    End If

    If ActiveDocument.Selection.Shapes(1).Type = cdrTextShape Then

        Text = ActiveDocument.Selection.Shapes(1).Text.Story 'Text des selektierten Objekts

        Text = Trim(Text)

        If Text <> "" Then

            Text = Replace(Text, a, "\" & Chr(34)) 'Zollzeichen maskieren

            Text = Chr(34) & Text & a

            Text = Replace(Text, Chr(13), "\n") ' Zeilenumbrüche ersetzen

            Text = Replace(Text, Chr(11), "\n") ' Zeilenumbrüche ersetzen

            Befehl = _

            a & ZintPfad & "zint" & a _

            & " " & a & "-o" & a & " " _

            & a & TempPfad _

            & "temp.eps" & a _

            & " --binary -b 60" _

            & " --scale=" & Skalierung _

            & " -d " _

            & Text

'            Debug.Print Befehl

            warte Befehl 'Ausführen und warten bis Zint fertig ist

            If DateiVorhanden(TempPfad & "temp.eps") Then

                epsImport TempPfad & "temp.eps" 'Importieren

                Kill TempPfad & "temp.eps" 'temporäre Datei löschen

            Else

                MsgBox "Codierungsfehler", vbExclamation

                Exit Sub

            End If

            Else

            MsgBox "Keinen Text gefunden", vbExclamation

        End If

        Else

        MsgBox "Keinen Text gefunden", vbExclamation

    End If

End Sub



Sub warte(ByVal strPath As String)

    Dim WshShell As Object

    Set WshShell = CreateObject("WScript.Shell")

    WshShell.Run strPath, 7, 1

    Set WshShell = Nothing

End Sub



Function DateiVorhanden(Datei As String) As Boolean

    Dim FS As Object

    Set FS = CreateObject("Scripting.FileSystemObject")

    DateiVorhanden = FS.FileExists(Datei)

    Set FS = Nothing

End Function



Sub epsImport(Datei As String)

    Dim cx As Double, ct As Double

    Dim s As Shape

    cx = ActiveShape.CenterX

    ct = ActiveShape.TopY

    Dim impopt As StructImportOptions

    Set impopt = CreateStructImportOptions

    impopt.MaintainLayers = True

    Dim impflt As ImportFilter

    Set impflt = ActiveLayer.ImportEx(Datei, cdrPSInterpreted, impopt)

    impflt.Finish

    ActiveShape.CenterX = cx

    ActiveShape.BottomY = ct

    For Each s In ActiveShape.Shapes

        If s.Type = cdrTextShape Or s.Fill.UniformColor.RGBValue <> 0 Then

            s.Delete

        End If

    Next

    With ActiveShape

        .Shapes.All.Combine

        .Ungroup

    End With

    ActiveSelection.Shapes.All.RemoveFromSelection

End Sub



Function WoIstZint() As String

    On Error GoTo fehler

    Dim WshShell As Object

    Set WshShell = CreateObject("WScript.Shell")

    If DateiVorhanden("C:\Program Files (x86)\Zint\zint.exe") Then

        WoIstZint = "C:\Program Files (x86)\Zint\"

        Set WshShell = Nothing

        Exit Function

    Else

        WoIstZint = WshShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\qtZint.exe\Path") & "\"

        Set WshShell = Nothing

        Exit Function

    End If

fehler:

    WoIstZint = ""

End Function