Как создать штрихкод?

@rvafexa · Регистрация: 13.08.2012

Студворк — интернет-сервис помощи студентам

приветствую всех,

как создать штрихкод в аксесс, можете выложить пример са шрифтом?

@VladOle · 06.09.2024, 21:57

Сообщение от Swa111

Пришлите, пожалуйста, шаблон, для анализа проблемы
Добавлено через 56 минут
Еще уточните в какой версии офиса готовите шаблон

прошу прощения, все работает! как только удалил из своей БД старый krnReport, все заработало!
подскажите как в шаблоне написать { f(a.[Дата рождения]) } чтобы выводило дату ДД.ММ.ГГГГ вместо ДД.ММ.ГГ.
Спасибо Огромное!

@Swa111 · 06.09.2024, 22:00

{f(<Выражение>)} Выводит выражение в отчете. Опционально вторым параметром можно задать формат. В этом случае перед выводом в отчет значение выражение будет пропущено через функцию format. Более подробно с функцией format ознакомьтесь на сайте Microsoft. Пример:

Code
1
{ f(a.[Дата рождения],'dd.mm.yyyy') }

@Insight_YR · 18.09.2025, 14:45

Всем добрейшего дня!

Заранее прошу прощения у почтенной публики, я вообще не программист ни разу, но пришлось искать решение как печатать штрих коды EAN-13 в Access при помощи программирования, потому, что сторонние модули стоят диких денег, не доступны сейчас в России, да и работают криво (проверял на триальном периоде).

Вобщем, кто ищет решение и мучается как я, вот как мне удалось решить проблему:

1. Устанавливаете себе шрифт Code EAN-13, скачать сам шрифт можно отсюд https://grandzebu.net/informat... /ean13.htm Или погуглите
2. Дальше небольшие танцы с бубном для тех, кто не шарит как я. В Access нужно создать модуль для конвертации числового кода в буквенно-числовой, именно его понимает шрифт и выглядит как правильный штрих код, который читается сканером. Модули выкладываю. Один с подсчетом контролной суммы, другой без. Мне коды выдали сразу с контрольной суммой, поэтому мне так удобнее.
3. В отчете в том, поле в которую выводится числовое значение штрих кода нужно вызвать этот модуль - например: =EAN13CodeWithoutChecksum([Штрих Код]), где "Штрих Код" это поле из таблицы.

Проверьте чтобы были включены нужные Библиотеки (References)

Visual Basic for Applications
Microsoft Access xx.x Object Library
OLE Automation
Microsoft DAO 3.6 Object Library

Но в этом я вообще не шарю, может уважаемые люди подскажут, что точно должно быть включено.
4. Профит. Штрих код выводится в Отчетах, при печати и сканирутся сканером.

@Insight_YR · 19.09.2025, 09:50

Вот еще один вариант. Рабочий код, штрих код тут рисуется полосками без использования специального шрифта.
Работает при выводе на печать и в предварительном просмотре. Для вывода штрих кода в отчете нужно создать поле с типом рисунок и назвать его как в коде, в данном случае "imgBarcode". Цифры под штрихами выводятся тремя текстовыми полями, их надо вручную созать и расставить в режиме Конструктор, имена полей
txtEAN_First
txtEAN_Left
txtEAN_Right

Может кому пригодится.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
Attribute VB_Name = "EAN13_BMP"
Option Compare Database
Option Explicit
 
' =================================================================
' MakeEAN13BitmapFile: генерирует BMP EAN-13 с разной высотой полос
' Возвращает путь к временному файлу BMP
' =================================================================
Public Function MakeEAN13BitmapFile(code13 As String, Optional barWidth As Long = 2, Optional barHeight As Long = 80) As String
    Dim bits As String
    bits = BuildEAN13Bits(code13)
    If bits = "" Then Exit Function
 
    Dim widthPx As Long, heightPx As Long
    widthPx = Len(bits) * barWidth
    heightPx = barHeight + 15        ' запас для длинных полос
 
    Dim rowSize As Long
    rowSize = ((widthPx * 3 + 3) \ 4) * 4             ' выравнивание строки до кратности 4 байт
    Dim pixelArraySize As Long
    pixelArraySize = CLng(rowSize) * CLng(heightPx)
    Dim bfSize As Long
    bfSize = 14 + 40 + pixelArraySize                 ' file header + info header + pixels
 
    ' Временный путь
    Dim tmpPath As String
    tmpPath = Environ$("TEMP") & "\ean13_" & code13 & ".bmp"
 
    Dim fnum As Integer
    fnum = FreeFile
    Open tmpPath For Binary Access Write As #fnum
 
    ' --- Заголовки BMP ---
    Dim header As String
    header = "BM" & LE4(bfSize) & LE2(0) & LE2(0) & LE4(54) _
             & LE4(40) & LE4(widthPx) & LE4(heightPx) & LE2(1) & LE2(24) _
             & LE4(0) & LE4(pixelArraySize) & LE4(2835) & LE4(2835) & LE4(0) & LE4(0)
    Put #fnum, , header
 
    ' --- Пиксели ---
    Dim rowBuf() As Byte
    ReDim rowBuf(0 To rowSize * heightPx - 1) As Byte
 
    Dim i As Long, Y As Long, barH As Long, idx As Long, X As Long
 
    For i = 1 To Len(bits)
        ' Определяем высоту штриха
        Select Case i
            Case 1 To 3, Len(bits) - 2 To Len(bits), Int(Len(bits) / 2) - 2 To Int(Len(bits) / 2) + 2
                barH = barHeight + 15
            Case Else
                barH = barHeight
        End Select
 
        For Y = 0 To heightPx - 1
            For X = 0 To barWidth - 1
                ' Индекс с разворотом на 180°
                idx = (heightPx - 1 - Y) * rowSize + (Len(bits) - i) * barWidth * 3 + X * 3
                If idx + 2 <= UBound(rowBuf) Then
                    If Y < barH And Mid$(bits, i, 1) = "1" Then
                        rowBuf(idx) = 0
                        rowBuf(idx + 1) = 0
                        rowBuf(idx + 2) = 0
                    Else
                        rowBuf(idx) = 255
                        rowBuf(idx + 1) = 255
                        rowBuf(idx + 2) = 255
                    End If
                End If
            Next X
        Next Y
    Next i
 
    ' Записываем BMP
    Put #fnum, , rowBuf
    Close #fnum
 
    MakeEAN13BitmapFile = tmpPath
End Function
 
' --- Little-endian helpers ---
Private Function LE4(value As Long) As String
    LE4 = Chr$(value And &HFF) & Chr$((value \ 256) And &HFF) _
          & Chr$((value \ 65536) And &HFF) & Chr$((value \ 16777216) And &HFF)
End Function
 
Private Function LE2(value As Long) As String
    LE2 = Chr$(value And &HFF) & Chr$((value \ 256) And &HFF)
End Function
 
' --- Построение битовой строки EAN-13 ---
Private Function BuildEAN13Bits(code13 As String) As String
    If Len(code13) <> 13 Or Not code13 Like String(13, "#") Then
        BuildEAN13Bits = ""
        Exit Function
    End If
 
    Dim tblA(0 To 9) As String, tblB(0 To 9) As String, tblC(0 To 9) As String
    Dim parityPattern(0 To 9) As String
    Dim i As Long, d As Integer
    Dim firstDigit As Integer, leftPart As String, rightPart As String
    Dim bits As String
 
    tblA(0) = "0001101": tblA(1) = "0011001": tblA(2) = "0010011": tblA(3) = "0111101"
    tblA(4) = "0100011": tblA(5) = "0110001": tblA(6) = "0101111": tblA(7) = "0111011"
    tblA(8) = "0110111": tblA(9) = "0001011"
 
    tblB(0) = "0100111": tblB(1) = "0110011": tblB(2) = "0011011": tblB(3) = "0100001"
    tblB(4) = "0011101": tblB(5) = "0111001": tblB(6) = "0000101": tblB(7) = "0010001"
    tblB(8) = "0001001": tblB(9) = "0010111"
 
    tblC(0) = "1110010": tblC(1) = "1100110": tblC(2) = "1101100": tblC(3) = "1000010"
    tblC(4) = "1011100": tblC(5) = "1001110": tblC(6) = "1010000": tblC(7) = "1000100"
    tblC(8) = "1001000": tblC(9) = "1110100"
 
    parityPattern(0) = "AAAAAA"
    parityPattern(1) = "AABABB"
    parityPattern(2) = "AABBAB"
    parityPattern(3) = "AABBBA"
    parityPattern(4) = "ABAABB"
    parityPattern(5) = "ABBAAB"
    parityPattern(6) = "ABBBAA"
    parityPattern(7) = "ABABAB"
    parityPattern(8) = "ABABBA"
    parityPattern(9) = "ABBABA"
 
    firstDigit = CInt(Mid$(code13, 1, 1))
    leftPart = Mid$(code13, 2, 6)
    rightPart = Mid$(code13, 8, 6)
 
    bits = "101"
    For i = 1 To 6
        d = CInt(Mid$(leftPart, i, 1))
        If Mid$(parityPattern(firstDigit), i, 1) = "A" Then
            bits = bits & tblA(d)
        Else
            bits = bits & tblB(d)
        End If
    Next i
    bits = bits & "01010"
    For i = 1 To 6
        d = CInt(Mid$(rightPart, i, 1))
        bits = bits & tblC(d)
    Next i
    bits = bits & "101"
 
    BuildEAN13Bits = bits
End Function

Код для отчета:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
' ================================
' Процедура для отчета
' ================================
 
Private Sub ОбластьДанных_Format(Cancel As Integer, FormatCount As Integer)
Dim code As String
    Dim tmpFile As String
    
    ' Берём код из поля таблицы/запроса
    code = Nz(Me![Штрих Код], "")   ' замените Штрих Код на ваше поле
    
    If Len(code) = 13 Then
        ' Генерация BMP для этого кода
        tmpFile = MakeEAN13BitmapFile(code, 2, 80)   ' barWidth=2, barHeight=80
        Me!imgBarcode.Picture = tmpFile
        
        ' Подписи цифр под штрихкодом
        Me!txtEAN_First = Left$(code, 1)
        Me!txtEAN_Left = Mid$(code, 2, 6)
        Me!txtEAN_Right = Mid$(code, 8, 6)
    Else
        ' Если поле пустое — очищаем
        Me!imgBarcode.Picture = ""
        Me!txtEAN_First = ""
        Me!txtEAN_Left = ""
        Me!txtEAN_Right = ""
    End If
End Sub

@Insight_YR · 20.09.2025, 23:17

Вот еще вариант рабочего кода для создания штрих-кодов EAN-13.
Коды здесь рисуются в векторе сразу с цифрами

Модуль.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
Option Compare Database
Option Explicit
 
'========================================================================
'======Генератор штрих-кода по стандарту EAN-13 в векторной графике======
'========================================================================
 
' ============ Объявления API (x64 / x86 через PtrSafe и LongPtr) ============
#If VBA7 Then
    Private Declare PtrSafe Function CreateEnhMetaFile Lib "gdi32" Alias "CreateEnhMetaFileA" ( _
        ByVal hdcRef As LongPtr, ByVal lpFilename As String, ByVal lpRect As LongPtr, ByVal lpDescription As String) As LongPtr
    Private Declare PtrSafe Function CloseEnhMetaFile Lib "gdi32" (ByVal hmf As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function Rectangle Lib "gdi32" (ByVal hdc As LongPtr, ByVal left As Long, ByVal top As Long, ByVal right As Long, ByVal bottom As Long) As Long
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As LongPtr, ByVal nXStart As Long, ByVal nYStart As Long, ByVal lpString As String, ByVal cbString As Long) As Long
    Private Declare PtrSafe Function CreateFontA Lib "gdi32" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, _
        ByVal fnWeight As Long, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, _
        ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As LongPtr
    Private Declare PtrSafe Function DeleteEnhMetaFile Lib "gdi32" (ByVal hmf As LongPtr) As Long
    Private Declare PtrSafe Function PatBlt Lib "gdi32" (ByVal hdc As LongPtr, _
        ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal dwRop As Long) As Long
#Else
 ' ============ Объявления API для 32-битной версии ============
    Private Declare Function CreateEnhMetaFile Lib "gdi32" Alias "CreateEnhMetaFileA" ( _
        ByVal hdcRef As Long, ByVal lpFilename As String, ByVal lpRect As Long, ByVal lpDescription As String) As Long
    Private Declare Function CloseEnhMetaFile Lib "gdi32" (ByVal hmf As Long) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal left As Long, ByVal top As Long, ByVal right As Long, ByVal bottom As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" Alias "SetBkMode" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal nXStart As Long, ByVal nYStart As Long, ByVal lpString As String, ByVal cbString As Long) As Long
    Private Declare Function CreateFontA Lib "gdi32" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, _
        ByVal fnWeight As Long, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, _
        ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
    Private Declare Function DeleteEnhMetaFile Lib "gdi32" Alias "DeleteEnhMetaFile" (ByVal hmf As Long) As Long
    Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, _
        ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal dwRop As Long) As Long
#End If
 
' ============ Константы ============
Private Const TRANSPARENT As Long = 1
Private Const PATCOPY As Long = &HF00021
 
' Вспомогательная функция для создания COLORREF (0x00BBGGRR)
Private Function ColorRef(r As Long, g As Long, b As Long) As Long
    ColorRef = (b * 65536) Or (g * 256) Or r
End Function
 
' ============ Построение битовой последовательности (стандарт EAN-13) ============
Private Function BuildEAN13Bits(code13 As String) As String
    If Len(code13) <> 13 Or Not code13 Like String(13, "#") Then
        BuildEAN13Bits = ""
        Exit Function
    End If
 
    Dim tblA(0 To 9) As String, tblB(0 To 9) As String, tblC(0 To 9) As String
    Dim parityPattern(0 To 9) As String
    Dim firstDigit As Integer, leftPart As String, rightPart As String
    Dim i As Long, d As Integer, bits As String
 
    tblA(0) = "0001101": tblA(1) = "0011001": tblA(2) = "0010011": tblA(3) = "0111101"
    tblA(4) = "0100011": tblA(5) = "0110001": tblA(6) = "0101111": tblA(7) = "0111011"
    tblA(8) = "0110111": tblA(9) = "0001011"
 
    tblB(0) = "0100111": tblB(1) = "0110011": tblB(2) = "0011011": tblB(3) = "0100001"
    tblB(4) = "0011101": tblB(5) = "0111001": tblB(6) = "0000101": tblB(7) = "0010001"
    tblB(8) = "0001001": tblB(9) = "0010111"
 
    tblC(0) = "1110010": tblC(1) = "1100110": tblC(2) = "1101100": tblC(3) = "1000010"
    tblC(4) = "1011100": tblC(5) = "1001110": tblC(6) = "1010000": tblC(7) = "1000100"
    tblC(8) = "1001000": tblC(9) = "1110100"
 
    parityPattern(0) = "AAAAAA"
    parityPattern(1) = "AABABB"
    parityPattern(2) = "AABBAB"
    parityPattern(3) = "AABBBA"
    parityPattern(4) = "ABAABB"
    parityPattern(5) = "ABBAAB"
    parityPattern(6) = "ABBBAA"
    parityPattern(7) = "ABABAB"
    parityPattern(8) = "ABABBA"
    parityPattern(9) = "ABBABA"
 
    firstDigit = CInt(Mid$(code13, 1, 1))
    leftPart = Mid$(code13, 2, 6)
    rightPart = Mid$(code13, 8, 6)
 
    bits = "101"
    For i = 1 To 6
        d = CInt(Mid$(leftPart, i, 1))
        If Mid$(parityPattern(firstDigit), i, 1) = "A" Then
            bits = bits & tblA(d)
        Else
            bits = bits & tblB(d)
        End If
    Next i
    bits = bits & "01010"
    For i = 1 To 6
        d = CInt(Mid$(rightPart, i, 1))
        bits = bits & tblC(d)
    Next i
    bits = bits & "101"
 
    BuildEAN13Bits = bits
End Function
 
' ============ Основная часть: создание EMF-файла с полосками и цифрами (фиксированные тихие зоны, без рамки) ============
Public Function MakeEAN13EMFFile(code13 As String, _
                                 Optional barWidthPx As Long = 2, _
                                 Optional barHeightPx As Long = 80, _
                                 Optional leftQuietModules As Long = 7, _
                                 Optional rightQuietModules As Long = 7) As String
    Dim bits As String
    bits = BuildEAN13Bits(code13)
    If bits = "" Then Exit Function
 
    Dim leftQuietPx As Long, rightQuietPx As Long
    leftQuietPx = leftQuietModules * barWidthPx
    rightQuietPx = rightQuietModules * barWidthPx
 
    Dim widthPx As Long, heightPx As Long
    widthPx = Len(bits) * barWidthPx + leftQuietPx + rightQuietPx
    heightPx = barHeightPx + 20
 
    Dim tmpPath As String
    tmpPath = Environ$("TEMP") & "\ean13_" & code13 & ".emf"
 
    Dim hEmfDC As LongPtr
    hEmfDC = CreateEnhMetaFile(0, tmpPath, 0, "EAN13")
    If hEmfDC = 0 Then
        MakeEAN13EMFFile = ""
        Exit Function
    End If
 
    ' Заполнить фон белым (без рамки)
    Dim hBrushWhite As LongPtr, hOldBrush As LongPtr
    hBrushWhite = CreateSolidBrush(ColorRef(255, 255, 255))
    hOldBrush = SelectObject(hEmfDC, hBrushWhite)
    Call PatBlt(hEmfDC, 0, 0, widthPx, heightPx, PATCOPY)
    SelectObject hEmfDC, hOldBrush
    DeleteObject hBrushWhite
 
    ' Черная кисть для штрихов
    Dim hBrushBlack As LongPtr
    hBrushBlack = CreateSolidBrush(ColorRef(0, 0, 0))
    hOldBrush = SelectObject(hEmfDC, hBrushBlack)
 
    Dim i As Long, leftX As Long, topY As Long, rightX As Long, bottomY As Long
    For i = 1 To Len(bits)
        If Mid$(bits, i, 1) = "1" Then
            leftX = leftQuietPx + (i - 1) * barWidthPx
            topY = 0
            If i <= 3 Or i > Len(bits) - 3 Or (i >= Int(Len(bits) / 2) - 2 And i <= Int(Len(bits) / 2) + 2) Then
                bottomY = barHeightPx + 10 'Длинные полоски
            Else
                bottomY = barHeightPx
            End If
            rightX = leftX + barWidthPx
            Call Rectangle(hEmfDC, leftX, topY, rightX, bottomY)
        End If
    Next i
 
    SelectObject hEmfDC, hOldBrush
    DeleteObject hBrushBlack
 
    ' Цифры под штрих-кодом, Шрифт, размер
    Dim fontHeight As Long
    fontHeight = -CLng(barWidthPx * 10)
    Dim hFont As LongPtr, hOldFont As LongPtr
    hFont = CreateFontA(fontHeight, 0, 0, 0, 400, 0, 0, 0, 0, 0, 0, 1, 0, "Arial")
    hOldFont = SelectObject(hEmfDC, hFont)
 
    Call SetBkMode(hEmfDC, TRANSPARENT)
 
    Dim xPos As Long, yPos As Long, j As Long, groupStart As Long
    yPos = barHeightPx + 1 ' вертикальная координата для цифр
 
    ' первая цифра
    xPos = (leftQuietPx \ 2) - (barWidthPx)
    If xPos < 0 Then xPos = 0
    Call TextOut(hEmfDC, xPos, yPos, Mid$(code13, 1, 1), 1)
 
    ' левая группа цифр
    groupStart = leftQuietPx + (3) * barWidthPx
    For j = 1 To 6
        xPos = groupStart + ((j - 1) * 7) * barWidthPx
        Call TextOut(hEmfDC, xPos, yPos, Mid$(code13, j + 1, 1), 1)
    Next j
 
    ' правая группа цифр
    groupStart = leftQuietPx + (3 + 42 + 5) * barWidthPx
    For j = 1 To 6
        xPos = groupStart + ((j - 1) * 7) * barWidthPx
        Call TextOut(hEmfDC, xPos, yPos, Mid$(code13, j + 7, 1), 1)
    Next j
 
    SelectObject hEmfDC, hOldFont
    DeleteObject hFont
 
    Dim hEmf As LongPtr
    hEmf = CloseEnhMetaFile(hEmfDC)
    If hEmf = 0 Then
        MakeEAN13EMFFile = ""
        Exit Function
    End If
 
    MakeEAN13EMFFile = tmpPath
End Function
 
'=========================================================
'Секция для формирования штрихкодов в режиме Report View
'       Инструкция:
'       В Control Source указать ссылку на функцию=GetBarcodePath([Штрих Код]) Название поля подставить свое
'=========================================================
 
' Функция возвращает путь к EMF по штрих-коду
' === Основная функция для Image-control ===
Public Function GetBarcodePath(code13 As String) As String
    Dim tmpFolder As String
    Dim fName As String
    
    If Len(code13) <> 13 Or Not code13 Like String(13, "#") Then
        GetBarcodePath = ""
        Exit Function
    End If
    
    tmpFolder = Environ$("TEMP") & "\"
    
    ' Чистим старые файлы перед поиском
    Call CleanupOldBarcodes(tmpFolder, 1) ' 1 = старше 1 дня
    
    On Error Resume Next       ' <-- отключаем ошибки
    
    ' Ищем файл ean13_XXXXXXXXXXXXX.emf
    fName = Dir(tmpFolder & "ean13_" & code13 & "*.emf")
    
    If fName <> "" Then
        ' Нашли готовый файл
        GetBarcodePath = tmpFolder & fName
    Else
    On Error GoTo 0            ' <-- возвращаем стандартную обработку ошибок
        ' Не нашли — создаём новый
        GetBarcodePath = MakeEAN13EMFFile(code13)
    End If
End Function
 
' === Удаляем старые штрих-коды ===
Private Sub CleanupOldBarcodes(folder As String, maxAgeDays As Long)
    Dim fName As String
    Dim fullPath As String
    Dim fileDate As Date
 
    fName = Dir(folder & "ean13_*.emf")
    Do While fName <> ""
        fullPath = folder & fName
        fileDate = FileDateTime(fullPath)
        If Now - fileDate > maxAgeDays Then
            On Error Resume Next
            Kill fullPath
            On Error GoTo 0
        End If
        fName = Dir
    Loop
End Sub

Для вывода в отчете:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Private Sub ОбластьДанных_Format(Cancel As Integer, FormatCount As Integer)
Dim code13 As String
    Dim tempPath As String
    Dim fName As String
    Dim fso As Object
    Dim fileFound As Boolean
    
    code13 = Nz(Me![Штрих Код], "")
    
    ' Проверка корректности кода
    If Len(code13) = 13 And code13 Like String(13, "#") Then
        
                tempPath = Environ$("TEMP") & "\"
        Set fso = CreateObject("Scripting.FileSystemObject")
        fileFound = False
        
        ' Ищем файл, в имени которого есть код штрих-кода
        fName = Dir(tempPath & "ean13_*" & code13 & "*.emf")
        If fName <> "" Then
            ' Файл найден
            Me.imgBarcode.Picture = tempPath & fName
            fileFound = True
            
        End If
        
        ' Если не найден, создаем новый
        If Not fileFound Then
            Dim tmpFile As String
            tmpFile = MakeEAN13EMFFile(code13, 2, 80, 7, 7)
            If tmpFile <> "" Then
                Me.imgBarcode.Picture = tmpFile
            Else
                Me.imgBarcode.Picture = vbNullString
            End If
        End If
        
    Else
        ' Некорректный код
        Me.imgBarcode.Picture = vbNullString
    End If
    
    Set fso = Nothing
End Sub

@alvk · 15.10.2025, 05:03

Сообщение от Insight_YR

потому, что сторонние модули стоят диких денег, не доступны сейчас в России, да и работают криво (проверял на триальном периоде).

Ложь. В 1с минимум 15 лет встроен этот штрих-код, печатай хоть тысячу в день.

Новые блоги и статьи Все статьи Все блоги /
Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Jin X 06.09.2026 Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Работая с форумом и нейросетями в браузере часто хочется что-то подкорректировать или добавить какого-то функционала. Ниже прикреплён. . .	Программа опроса у.з. расходомера SLS-720F Argus19 02.09.2026 Программа опроса у. з. расходомера SLS-720F Программа опрашивает один раз в минуту три ультразвуковых расходомера SLS-720F через интерфейс RS-485 по протоколу Modbus RTU. Опрашиваются регистры. . .	Hyper-V: Компьютер должен поддерживать доверенный платформенный модуль 2.0. Maks 31.08.2026 При установке Windows 11 на виртуальную машину Hyper-V 2-го поколения вылезла такая ошибка: Решение: в параметрах виртуальной машины, в разделе "Безопасность" (Security) активировать флаг. . .	Архитектура биовида Стива в Майнкрафте: Зачем бонобо кубический каннибализм anaschu 30.08.2026 Кубический Вагинокапитализм в Minecraft: Математический инвариант ОДУ и рок Стивов-бонобо Главная задача разработанной «Модели Всего» — наглядно продемонстрировать наличие системной «судьбы». . .
Оттачиваю умение писать js программы. russiannick 30.08.2026 Проектом выходного дня стало написание Книги шифров Виженера. Итогом стала версия 200, синий туман. Синий туман назван так, потому что замораживает текст под собой. Нажатие синих кнопок управляют. . .	мат медиц модель 30. презентация проекта anaschu 27.08.2026 хоп хоп хоп хидахоп, а я кладую))	Как у меня протекала болезнь zorxor 27.08.2026 Здравствуйте, друзья! Эта запись блога предназначена именно для вас - для моих дорогих друзей, которые знали меня лично. Чтобы ответить на вопрос - а что же со мной произошло на самом деле? Я учился. . .	Нашел вот забавное видео о измерениях. Лучшее что я видел на эту тему kumehtar 26.08.2026 ILETXiw9bMQ Основная суть и тезисы по измерениям: 0D (Нулевое измерение): точка, не имеющая длины, ширины, высоты или объема. Объект не может перемещаться в 0D. 1D (Первое измерение):. . .

@rvafexa 96 / 17 / 4 Регистрация: 13.08.2012 Сообщений: 490

	Как создать штрихкод? 10.07.2023, 06:47. Показов 11591. Ответов 65 Метки нет (Все метки) приветствую всех, как создать штрихкод в аксесс, можете выложить пример са шрифтом? 0

Опции темы

Как создать штрихкод?

Решение