QR-Code

[koter]

Zint war ein guter Tip!

Mit der Zint Komanndozeile und ein paar Zeilen VBA-Code kann man sogar schnell QRCodes einfügen, ohne Zint manuell zu starten.

Bei mir (winXP/CorelDrawX4) funktioniert es so:

Code:

Sub zintQR()
    Dim Text As String
    Dim ZintPfad As String
    Dim ECCLevel As String * 1
    Dim Skalierung As String
    Dim Befehl As String
    Dim ExitCode As Long
        
    ZintPfad = "C:\Programme\Zint\" 'der Pfad zu zind.exe
    
    ECCLevel = 2 '1 = Level L, 2 = Level M, 3 = Level Q, 4 = Level  H
    
    Skalierung = "4.5"
    
    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, Chr(34), "\" & Chr(34)) 'Zollzeichen maskieren
            Text = Chr(34) & Text & Chr(34)
            Text = Replace(Text, Chr(13), "\n") ' Zeilenumbrüche ersetzen
            Text = Replace(Text, Chr(11), "\n") ' Zeilenumbrüche ersetzen
            Befehl = ZintPfad & "zint -o " & Chr(34) & ZintPfad _
            & "temp.eps" & Chr(34) & " --binary -b 58 --secure=" & ECCLevel _
            & " --scale=" & Skalierung _
            & " -d " & Text
            Debug.Print Befehl
            warte Befehl 'Ausführen und warten bis Zint fertig ist
            If DateiVorhanden(ZintPfad & "temp.eps") Then
                epsImport ZintPfad & "temp.eps" 'Importieren
                Kill ZintPfad & "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 PosX As Double, PosY As Double
    Dim x As Double, y1 As Double, y2 As Double
    PosX = ActiveDocument.Selection.Shapes(1).PositionX
    PosY = ActiveDocument.Selection.Shapes(1).PositionY
    ActiveShape.GetSize x, y1
    Dim impopt As StructImportOptions
    Set impopt = CreateStructImportOptions
    impopt.MaintainLayers = True
    Dim impflt As ImportFilter
    Set impflt = ActiveLayer.ImportEx(Datei, cdrPSInterpreted, impopt)
    impflt.Finish
    ActiveShape.GetSize x, y2
    ActiveShape.Move PosX, PosY - y1 - y2 - 0.1
End Sub

Grafiktext auswählen und das Macro starten.

nochmals Danke für den Tip!