Сделал я скрипт, все по совковым ГОСТам делает
Читается замечательно, лучше чем Corelовским Barcod ом
Можно через скрипт задавать поворот, редукцию штрихов, расположение, проверяет соответствие ГОСТам, ну а остальное ручками если надо, или доработаю
Пример использования
EAN13(MMInInch(5), MMInInch(5), "481183800002", , , 0.8, 30, 0, 0.02)
EAN13(MMInInch(50), MMInInch(5), "481183800008")
Set TempShape = EAN13(MMInInch(100), MMInInch(5), "481183802356", MMInInch(42), MMInInch(33), 2, 30, 90, 0.06)
А вообще делал, программку для печатания бирок для швейников с базой данных из которой брались артикулы, госты, размеры, EAN коды для каждой модели и размера
Если что пишите
Читается замечательно, лучше чем Corelовским Barcod ом
Можно через скрипт задавать поворот, редукцию штрихов, расположение, проверяет соответствие ГОСТам, ну а остальное ручками если надо, или доработаю
Пример использования
EAN13(MMInInch(5), MMInInch(5), "481183800002", , , 0.8, 30, 0, 0.02)
EAN13(MMInInch(50), MMInInch(5), "481183800008")
Set TempShape = EAN13(MMInInch(100), MMInInch(5), "481183802356", MMInInch(42), MMInInch(33), 2, 30, 90, 0.06)
А вообще делал, программку для печатания бирок для швейников с базой данных из которой брались артикулы, госты, размеры, EAN коды для каждой модели и размера
Если что пишите
Как приверженец той мысли что, ЕСЛИ ХОЧЕШЬ ЧЕГО-ТО ПОЛУЧИТЬ ТО НАПРЯГАЙСЯ ИЛИ ПОМОГИ ЧЕЛОВЕКУ КТО ПОМОГАЕТ ТЕБЕ
ДЛЯ ТЕХ КТО УМЕЕТ НАПРЯГАТЬСЯ ЧАСТЬ КОДА, остальные пишите будем договариваться
Public Function EAN13(x As Double, y As Double, Kod As String, Optional W As Double, Optional H As Double, _
Optional SKScale As Double, Optional SKTruncation As Double, _
Optional SRotate As Double, Optional SXPrintErr As Double) As Shape
Call SetMyConst(Kod)
If (SKScale = 0) Then KScale = 1 Else: _
If SKScale > 2 Then KScale = 2 Else: _
If SKScale < 0.8 Then KScale = 0.8 Else KScale = SKScale
If SKTruncation = 0 Then KTruncation = 0 Else: _
If SKTruncation > 30 Then KTruncation = 30 Else KTruncation = SKTruncation
If SRotate = 0 Then Rotate = 0 Else Rotate = SRotate
If SXPrintErr = 0 Then XPrintErr = 0 Else XPrintErr = MMInInch(SXPrintErr)
XPrintErr2 = XPrintErr / 2
If (Len(Kod) <> 12) Then Exit Function
For i = 1 To 12
TKod(i) = CByte(Mid(Kod, i, 1))
Next i
W1 = W: H1 = H
x1 = XPage + x: y1 = YPage + y
XW = MMInInch(0.33)
XH = MMInInch(22.85)
XH = XH - XH / 100 * KTruncation
XAddH = 5 * XW
XH1 = XH + XAddH
'Проверяем ширину и высоту прямоугольника
W3 = 113 * XW: H3 = XH + XW * 10
W2 = W3 * KScale: H2 = H3 * KScale
If W2 > W1 Then W1 = W3
If H2 > H1 Then H1 = H3
'Определяем базовые точки X, Y для рисования штрихов
LW = XW * 11 ': RW = XW * 7
W4 = (W1 - W3) / 2: H4 = (H1 - H3) / 2
XHt0 = x1 + LW + W4: YHt0 = y1 + XW * 4 + H4
'Рамка кода
Set EANSh = ActiveLayer.CreateRectangle2(x1, y1, W1, H1)
EANSh.Fill.UniformColor.CMYKAssign 0, 0, 0, 0
EANSh.Outline.SetProperties 0#
EANSh.ObjectData("Name").Value = "EANRamka"
EANOb.Add EANSh
'Определение последней цифры
Numbe0 = VerifyN(TKod)
If Numbe0 <> False Then TKod(13) = CByte(Numbe0) 'Else Exit Sub
'Перевод в двоичную кодировку
Call ToDooble(TKod)
'Прорисовка кода
Pk = "0"
PXHt = XHt0
For i = 1 To 5
PL = Len(TDo01(i, 0))
For j = 1 To PL
PN = Mid(TDo01(i, 0), j, 1)
If PN = "1" Then
If PL = j Then
PXWH = PXWH + XW
Call Shtrih(TDo01(i, 1), PXHt, YHt0, PXWH, XH, XH1, XAddH)
PXHt = PXHt + PXWH: PXWH = 0
Else
PXWH = PXWH + XW: Pk = "1"
End If
Else
If Pk = "1" Then
Call Shtrih(TDo01(i, 1), PXHt, YHt0, PXWH, XH, XH1, XAddH)
PXHt = PXHt + PXWH + XW: PXWH = 0: Pk = "0"
Else
PXHt = PXHt + XW
End If
End If
Next j
Next i
'Написание цифр
PTX = XHt0 - 10 * XW
TY = YHt0 - 3 * XW
For i = 1 To 13
Set EANSh = ActiveLayer.CreateArtisticText(PTX, TY, TKod(i), cdrEnglishUS, , "OCR-B 10 BT", 10, , , , cdrLeftAlignment)
EANSh.ObjectData("Name").Value = "EANS"
EANOb.Add EANSh
If i = 1 Then
PTX = PTX + 14 * XW
ElseIf i = 7 Then
PTX = PTX + 11 * XW
Else
PTX = PTX + 7 * XW
End If
Next i
PTX = PTX + 4 * XW
Set EANSh = ActiveLayer.CreateArtisticText(PTX, TY, ">", cdrEnglishUS, , "OCR-B 10 BT", 10, , , , cdrLeftAlignment)
EANSh.ObjectData("Name").Value = "EANS"
EANOb.Add EANSh
'Группировка
Dim EanGr1 As Shape
'Set EanGr1 = EANSh
ActiveDocument.CreateSelection
For Each EANSh In EANOb
ActiveDocument.AddToSelection EANSh
Next EANSh
Set EANGr = ActiveSelection.Group
EANGr.ObjectData("Name").Value = "EAN" + Kod
'Масштабирование
EANGr.GetPosition x, y
EANGr.SetSizeEx x, y, W1 * KScale
'Поворот относительно центра
EANGr.RotateEx Rotate, x + EANGr.SizeWidth / 2, y - EANGr.SizeHeight / 2
For Num = 1 To EANOb.Count ' Remove name from the collection.
EANOb.Remove 1 ' Since collections are reindexed automatically, remove the first
Next
Set EAN13 = EANGr
End Function
Sub Shtrih(PsLen, PsXHt, YHt0, PsXLH, SXH, SXH1, SXAddH) '(Длинный/короткий штрих, координата X, координата Y, ширина штриха, высота штриха, высота длинного штриха, разница в высоте)
If PsLen Then PsYLHt = SXH: PsYHt = SXAddH Else PsYLHt = SXH1: PsYHt = 0
Set EANSh = ActiveLayer.CreateRectangle2(PsXHt, YHt0 + PsYHt + XPrintErr2, PsXLH - XPrintErr, PsYLHt)
EANSh.Fill.UniformColor.CMYKAssign 0, 0, 0, 100
EANSh.Outline.SetProperties 0#
EANSh.ObjectData("Name").Value = "EANI"
EANOb.Add EANSh
End Sub
Public Function VerifyN(Key)
Vk1 = 0
Vk2 = 0
For i = 1 To 12 Step 2
Vk1 = Vk1 + Key(i)
Next i
For i = 2 To 12 Step 2
Vk2 = Vk2 + Key(i)
Next i
VerifyN = CByte(Right(CStr(10 - CByte(Right(CStr(Vk1 + Vk2 * 3), 1))), 1))
End Function
ДЛЯ ТЕХ КТО УМЕЕТ НАПРЯГАТЬСЯ ЧАСТЬ КОДА, остальные пишите будем договариваться
Public Function EAN13(x As Double, y As Double, Kod As String, Optional W As Double, Optional H As Double, _
Optional SKScale As Double, Optional SKTruncation As Double, _
Optional SRotate As Double, Optional SXPrintErr As Double) As Shape
Call SetMyConst(Kod)
If (SKScale = 0) Then KScale = 1 Else: _
If SKScale > 2 Then KScale = 2 Else: _
If SKScale < 0.8 Then KScale = 0.8 Else KScale = SKScale
If SKTruncation = 0 Then KTruncation = 0 Else: _
If SKTruncation > 30 Then KTruncation = 30 Else KTruncation = SKTruncation
If SRotate = 0 Then Rotate = 0 Else Rotate = SRotate
If SXPrintErr = 0 Then XPrintErr = 0 Else XPrintErr = MMInInch(SXPrintErr)
XPrintErr2 = XPrintErr / 2
If (Len(Kod) <> 12) Then Exit Function
For i = 1 To 12
TKod(i) = CByte(Mid(Kod, i, 1))
Next i
W1 = W: H1 = H
x1 = XPage + x: y1 = YPage + y
XW = MMInInch(0.33)
XH = MMInInch(22.85)
XH = XH - XH / 100 * KTruncation
XAddH = 5 * XW
XH1 = XH + XAddH
'Проверяем ширину и высоту прямоугольника
W3 = 113 * XW: H3 = XH + XW * 10
W2 = W3 * KScale: H2 = H3 * KScale
If W2 > W1 Then W1 = W3
If H2 > H1 Then H1 = H3
'Определяем базовые точки X, Y для рисования штрихов
LW = XW * 11 ': RW = XW * 7
W4 = (W1 - W3) / 2: H4 = (H1 - H3) / 2
XHt0 = x1 + LW + W4: YHt0 = y1 + XW * 4 + H4
'Рамка кода
Set EANSh = ActiveLayer.CreateRectangle2(x1, y1, W1, H1)
EANSh.Fill.UniformColor.CMYKAssign 0, 0, 0, 0
EANSh.Outline.SetProperties 0#
EANSh.ObjectData("Name").Value = "EANRamka"
EANOb.Add EANSh
'Определение последней цифры
Numbe0 = VerifyN(TKod)
If Numbe0 <> False Then TKod(13) = CByte(Numbe0) 'Else Exit Sub
'Перевод в двоичную кодировку
Call ToDooble(TKod)
'Прорисовка кода
Pk = "0"
PXHt = XHt0
For i = 1 To 5
PL = Len(TDo01(i, 0))
For j = 1 To PL
PN = Mid(TDo01(i, 0), j, 1)
If PN = "1" Then
If PL = j Then
PXWH = PXWH + XW
Call Shtrih(TDo01(i, 1), PXHt, YHt0, PXWH, XH, XH1, XAddH)
PXHt = PXHt + PXWH: PXWH = 0
Else
PXWH = PXWH + XW: Pk = "1"
End If
Else
If Pk = "1" Then
Call Shtrih(TDo01(i, 1), PXHt, YHt0, PXWH, XH, XH1, XAddH)
PXHt = PXHt + PXWH + XW: PXWH = 0: Pk = "0"
Else
PXHt = PXHt + XW
End If
End If
Next j
Next i
'Написание цифр
PTX = XHt0 - 10 * XW
TY = YHt0 - 3 * XW
For i = 1 To 13
Set EANSh = ActiveLayer.CreateArtisticText(PTX, TY, TKod(i), cdrEnglishUS, , "OCR-B 10 BT", 10, , , , cdrLeftAlignment)
EANSh.ObjectData("Name").Value = "EANS"
EANOb.Add EANSh
If i = 1 Then
PTX = PTX + 14 * XW
ElseIf i = 7 Then
PTX = PTX + 11 * XW
Else
PTX = PTX + 7 * XW
End If
Next i
PTX = PTX + 4 * XW
Set EANSh = ActiveLayer.CreateArtisticText(PTX, TY, ">", cdrEnglishUS, , "OCR-B 10 BT", 10, , , , cdrLeftAlignment)
EANSh.ObjectData("Name").Value = "EANS"
EANOb.Add EANSh
'Группировка
Dim EanGr1 As Shape
'Set EanGr1 = EANSh
ActiveDocument.CreateSelection
For Each EANSh In EANOb
ActiveDocument.AddToSelection EANSh
Next EANSh
Set EANGr = ActiveSelection.Group
EANGr.ObjectData("Name").Value = "EAN" + Kod
'Масштабирование
EANGr.GetPosition x, y
EANGr.SetSizeEx x, y, W1 * KScale
'Поворот относительно центра
EANGr.RotateEx Rotate, x + EANGr.SizeWidth / 2, y - EANGr.SizeHeight / 2
For Num = 1 To EANOb.Count ' Remove name from the collection.
EANOb.Remove 1 ' Since collections are reindexed automatically, remove the first
Next
Set EAN13 = EANGr
End Function
Sub Shtrih(PsLen, PsXHt, YHt0, PsXLH, SXH, SXH1, SXAddH) '(Длинный/короткий штрих, координата X, координата Y, ширина штриха, высота штриха, высота длинного штриха, разница в высоте)
If PsLen Then PsYLHt = SXH: PsYHt = SXAddH Else PsYLHt = SXH1: PsYHt = 0
Set EANSh = ActiveLayer.CreateRectangle2(PsXHt, YHt0 + PsYHt + XPrintErr2, PsXLH - XPrintErr, PsYLHt)
EANSh.Fill.UniformColor.CMYKAssign 0, 0, 0, 100
EANSh.Outline.SetProperties 0#
EANSh.ObjectData("Name").Value = "EANI"
EANOb.Add EANSh
End Sub
Public Function VerifyN(Key)
Vk1 = 0
Vk2 = 0
For i = 1 To 12 Step 2
Vk1 = Vk1 + Key(i)
Next i
For i = 2 To 12 Step 2
Vk2 = Vk2 + Key(i)
Next i
VerifyN = CByte(Right(CStr(10 - CByte(Right(CStr(Vk1 + Vk2 * 3), 1))), 1))
End Function