Barcode 128 in Grafik umwandeln

[koter]

Hallo N...;-),

Das Makro muss man natürlich für Code 128 umstricken.
Unter X7 läuft es:



Das Makro codiert allerdings Umlaute falsch.
Wenn das noch nachgerüstet werden soll, müsste man wissen,
ob der Scanner FNC4 beherrscht oder Umlaute anders umgewandelt werden müssen.

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

Gruß

Koter