Генерация QR code из нескольких строк. Проблема с доступностью компоненты

@TorLink · Регистрация: 26.12.2014

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

Нужно собирать несколько данных из ячеек экселя, делать из них строку вида 123;656;25.05.19 и её преобразовать уже в QR кода.
Важно, что это нужно делать оффлайн, т.е. гуглапи не подходит.
Плагины так же мимо, т.к. их нужно устанавливать всем, а это нереально.

Нашел компоненту тут OcvitaBarcode.ocx
Тут вот есть готовый файлик и примером как сделать.
Но при нажатии на кнопку вылетает ошибка: "could not load some objects because they are not available on this machine"
Т.е. эксель не видит зарегеную компоненту и затыкается на строке Set oc = OcvitaBarcode1
Регил и в c:\Windows\System32\ и в c:\Windows\SysWOW64\ удалял обе регистрации, регил повторно x64 результат один.((
В той теме кто-то тоже писал об это ошибке, но решения не было.
Office x64

SoftIce · 15.08.2019, 16:18

А почему Вы не используете параметр в функции ?

@TorLink · 15.08.2019, 16:28 **[ТС]**

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

А почему Вы не используете параметр в функции ?

Да как только не пробовал.((
Ну вот так например тоже не работает.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Function QRCode(ByVal QR_Value As String)
 
 Dim xSRg As Range
 Dim xRRg As Range
 Dim xObjOLE As OLEObject
 
 
 Set xRRg = Range("C15")
    
Set xObjOLE = ActiveSheet.OLEObjects.Add("BARCODE.BarCodeCtrl.1")
 xObjOLE.Object.Style = 11
 xObjOLE.Object.Value = QR_Value
  ActiveSheet.Shapes.Item(xObjOLE.Name).Copy
 ActiveSheet.Paste xRRg
 
 QRCode = "Name"
 
End Function

SoftIce · 15.08.2019, 16:52

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

Ну вот так например тоже не работает

Надеюсь, это просто описка, так как функция возвращает "Name"/

Добавлено через 1 минуту
Всё-таки, я думаю, что Эксель не видит BARCODE.BarCodeCtrl, и не может его добавить на лист.

@TorLink · 15.08.2019, 20:00 **[ТС]**

Нет, это не описка. Это скопировано с рабочего файлика.)
Там так же формируется код, добавляется в таблицу, а потом просто возвращается параметр переданный в эту функцию.
Вот сам файл. https://yadi.sk/d/95GuRSAm8TQTRw

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
Function URL_QRCode_SERIES( _
    ByVal PictureName As String, _
    ByVal QR_Value As String, _
    Optional ByVal PictureSize As Long = 120, _
    Optional ByVal DisplayText As String = "", _
    Optional ByVal Updateable As Boolean = True) As Variant
 
Dim oPic As Shape, oRng As Excel.Range
Dim vLeft As Variant, vTop As Variant
Dim sURL As String
 
Const sRootURL As String = "https://chart.googleapis.com/chart?"
Const sSizeParameter As String = "chs="
Const sTypeChart As String = "cht=qr"
Const sDataParameter As String = "chl="
Const sJoinCHR As String = "&"
 
If Updateable = False Then
    URL_QRCode_SERIES = "outdated"
    Exit Function
End If
 
Set oRng = Application.Caller.Offset(, 1)
On Error Resume Next
Set oPic = oRng.Parent.Shapes(PictureName)
If Err Then
    Err.Clear
    vLeft = oRng.Left + 4
    vTop = oRng.Top
Else
    vLeft = oPic.Left
    vTop = oPic.Top
    PictureSize = Int(oPic.Width)
    oPic.Delete
End If
On Error GoTo 0
 
If Len(QR_Value) = 0 Then
    URL_QRCode_SERIES = CVErr(xlErrValue)
    Exit Function
End If
 
sURL = sRootURL & _
       sSizeParameter & PictureSize & "x" & PictureSize & sJoinCHR & _
       sTypeChart & sJoinCHR & _
       sDataParameter & UTF8_URL_Encode(VBA.Replace(QR_Value, " ", "+"))
 
Set oPic = oRng.Parent.Shapes.AddPicture(sURL, True, True, vLeft, vTop, PictureSize, PictureSize)
oPic.Name = PictureName
URL_QRCode_SERIES = DisplayText
End Function

Да, вероятно Эксель не видит её и поэтому просто вылетает без признаков ошибки. НО, опять же, вставляя этот же код в кнопку. Всё работает. Вот рабочий по кнопке через компоненту https://yadi.sk/d/sTNwkFeLsM-WWw
И сама компонента https://yadi.sk/d/ctzmKMTOYswacw

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
Sub setQR()
'Updated by Extendoffice 2018/8/22
    Dim xSRg As Range
    Dim xRRg As Range
    Dim xObjOLE As OLEObject
    On Error Resume Next
  
    ActiveSheet.Shapes.Range(Array("BarCodeCtrl2")).Select
    Selection.Delete
    
    'Set xSRg = Application.InputBox("Please select the cell you will create QR code based on", "Kutools for Excel", , , , , , 8)
    Set xSRg = Range("$B2")
    If xSRg Is Nothing Then Exit Sub
    'Set xRRg = Application.InputBox("Select a cell to place the QR code", "Kutools for Excel", , , , , , 8)
    Set xRRg = Range("C15")
    If xRRg Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Set xObjOLE = ActiveSheet.OLEObjects.Add("BARCODE.BarCodeCtrl.1")
    Application.CutCopyMode = True
    xObjOLE.Object.Style = 11
    xObjOLE.Object.Value = "d"
    ActiveSheet.Shapes.Item(xObjOLE.Name).Copy
    ActiveSheet.Paste xRRg
    xObjOLE.Delete
    Application.ScreenUpdating = True
   
End Sub

В результате получается, что 2 этих варианта работают. когда пытаюсь сделать из них один. По формированию оффлайн через функцию, ничего не выходит. (((

Добавлено через 8 минут
Вот что записывается в Макросе, при добавлении руками:

Visual Basic
1
2
3
 ActiveSheet.OLEObjects.Add(ClassType:="BARCODE.BarCodeCtrl.1", Link:=False _
        , DisplayAsIcon:=False, Left:=422.25, Top:=151.5, Width:=107.25, _
        Height:=81.75).Select

Добавлено через 2 часа 47 минут
Попробовал по другому. В модуле листа:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("G5")) Is Nothing Then
  
Dim xSRg As Range
 Dim xRRg As Range
 Dim xObjOLE As OLEObject
 
 Set xRRg = Range("C15")
    
 Set xObjOLE = ActiveSheet.OLEObjects.Add("BARCODE.BarCodeCtrl.1")
 xObjOLE.Object.Style = 11
 xObjOLE.Object.Value = Target
 ActiveSheet.Shapes.Item(xObjOLE.Name).Copy
 ActiveSheet.Paste xRRg
 xObjOLE.Delete
 
 End If
End Sub

Работает! Только пробоблема остаётся с тем, что при каждом изменении ячейки, QR код накладывается поверх старого, в итоге получаются кучи дублей. Как его найти и удалить до добавления нового или просто найти и и заменить параметры, пока не понял.((

Ну и опять же такая схема не подходит, потому что вызывается при изменении любой ячейки.
Копирую этот же код в отдельный модуль. Вызываю функцию из ячейки, и Опять код не отрабатывает.((

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Function QR_Code(ByVal QR_Value As String)
 
Dim xSRg As Range
 Dim xRRg As Range
 Dim xObjOLE As OLEObject
 
 Set xRRg = Range("C15")
    
 Set xObjOLE = ActiveSheet.OLEObjects.Add("BARCODE.BarCodeCtrl.1")
 xObjOLE.Object.Style = 11
 xObjOLE.Object.Value = Target
 ActiveSheet.Shapes.Item(xObjOLE.Name).Copy
 ActiveSheet.Paste xRRg
 xObjOLE.Delete
 
QR_Code = "Name"
 
End Function

SoftIce · 15.08.2019, 20:16

Не по теме:

TorLink, ничего не могу сказать. Нужно регистрировать опять, проверять на реальном файле, но мне пока недосуг.

@TorLink · 20.08.2019, 15:56 **[ТС]**

Получилось немного по другому. Код выполняется по изменению ячейки.
Компоненту надо добавлять руками в инструменты разработчика.
Судя по всему на 2013м офисе и ниже не работает, т.к. просто выдаёт ошибку при добавлении.
Авось кому пригодится, чтобы не тратить 2 недели на эти 15 строк кода.)))

@Anthony_K · 18.11.2019, 11:31

TorLink, а можно из этого макроса сделать функцию типа Function QREncode(DataToEncrypt)?

Например:
В ячейке A1 имеем значение 12345678

В ячейке B1 вводим = QREncode(A1). В результате, в этой же ячейке формируется QR-код из значения ячейки A1/

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Function QREncode(DataToEncrypt)
    Dim xSRg As Range
    Dim xRRg As Range
    Dim xObjOLE As OLEObject
    QRSource = CStr(DataToEncrypt)
 
    On Error Resume Next
    Set xRRg = Range(Selection.Address)
    Application.ScreenUpdating = False
    Set xObjOLE = ActiveSheet.OLEObjects.Add("BARCODE.BarCodeCtrl.1")
    xObjOLE.Object.Style = 11
    xObjOLE.Object.Value = QRSource
    ActiveSheet.Shapes.Item(xObjOLE.Name).Copy
    ActiveSheet.Paste xRRg
    xObjOLE.Delete
    Application.ScreenUpdating = True
End Function

Но в результате QR-код не формируется. Не могу понять, можно ли это реализовать таким образом?

@TorLink · 18.11.2019, 12:20 **[ТС]**

Добавлено через 50 секунд

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

TorLink, а можно из этого макроса сделать функцию типа Function QREncode(DataToEncrypt)?

У меня такая задача и была изначально.
Но по функции оно просто не работает. Я так и не понял почему.((
И на форумах никто не помог. Ещё у этой компоненты есть трабл, что она не пашет на офисе 365. И на версиях до 2013го.
Есть ещё ocvitabarcode но её не смог заставить работать в ячейке. Только на форме.(
Если кто-то найдёт другую компоненту работающую везде и которую можно добавить в ячейку, буду благодарен.)

Новые блоги и статьи Все статьи Все блоги /
Запустил конкурс "тем и промптов для текстовых квестов созданных почти чисто ИИ" Adler 06.10.2026 Всем привет! За последние три-четыре дня я создал более 16 текстовых квестовых игр используя преимущественно по одному запросу к ИИ на игру. Мне так понравилось смотреть все ветки/ сцены во всех. . .	ИИ не может найти нужный язык в списке Supersumestria 05.10.2026 Я ему даю вот такое изображение и прошу найти и подчеркнуть немецкий язык. Возвращает он вот это: https:/ / i. **********/ vqBWLe2. png Нужную строчку в 3й колонке просто выдумал. . Это. . .	Новая последняя моя музыка в SUNO zorxor 05.10.2026 Здравствуйте, дорогие мои друзья! С большой радостью я хотел бы представить вам свою новую последнею музыку, которую сгенерировала мне по моей просьбе нейросеть SUNO. С уважением, zorxor. Это. . .	Программный домашний кинотеатр russiannick 27.09.2026 Сподобился на программный домашний кинотеатр. В качестве ЯВУ по традиции выбрал js. В помощники взял Яндекс-Алису. Было создано три зала на разные интересы. исторические и ретро сериал Хичкок. . .
Беседа с ИИ о программистах, недопускающих к созданию и правке кода генеративные ИИ и причины этого zorxor 21.09.2026 Раньше я радовался или получал некоторые эмоции, пусть небольшие, но всё же, от самого процесса написания кода, рекомпиляции и запуска, видя постепенное развитие программы и прочее. А теперь лень. . .	Мобильное приложение ColorStep pavlinmavlin 17.09.2026 Реализовал приложение Красный, Зеленый, Синий в Unity3d + c#. Название изменил на ColorStep. Приложение прошло модерацию и теперь доступно для скачивания. Делал его сам, шаг за шагом — и вот,. . .	Запрет дублирования строк в табличной части Maks 13.09.2026 Реализация из решения ниже выполнена на нетиповом справочнике "Нормы ТО" с табличной часть "Виды ТО", разработанного в КА2, со следующими реквизитами: - ВидТО (СправочникСсылка. ВидыТО); - ВидГСМ. . .	Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Jin X 06.09.2026 Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Работая с форумом и нейросетями в браузере часто хочется что-то подкорректировать или добавить какого-то функционала. Ниже прикреплён. . .

@TorLink 2 / 2 / 0 Регистрация: 26.12.2014 Сообщений: 23

	Excel Генерация QR code из нескольких строк. Проблема с доступностью компоненты 08.08.2019, 19:11. Показов 14990. Ответов 27 Метки excel2016, qr (Все метки) Нужно собирать несколько данных из ячеек экселя, делать из них строку вида 123;656;25.05.19 и её преобразовать уже в QR кода. Важно, что это нужно делать оффлайн, т.е. гуглапи не подходит. Плагины так же мимо, т.к. их нужно устанавливать всем, а это нереально. Нашел компоненту тут OcvitaBarcode.ocx Тут вот есть готовый файлик и примером как сделать. Но при нажатии на кнопку вылетает ошибка: "could not load some objects because they are not available on this machine" Т.е. эксель не видит зарегеную компоненту и затыкается на строке Set oc = OcvitaBarcode1 Регил и в c:\Windows\System32\ и в c:\Windows\SysWOW64\ удалял обе регистрации, регил повторно x64 результат один.(( В той теме кто-то тоже писал об это ошибке, но решения не было. Office x64 0

SoftIce es geht mir gut 11275 / 4761 / 1183 Регистрация: 27.07.2011 Сообщений: 11,439
	15.08.2019, 16:18
	А почему Вы не используете параметр в функции ? 0

SoftIce
	15.08.2019, 20:16
	Не по теме: TorLink, ничего не могу сказать. Нужно регистрировать опять, проверять на реальном файле, но мне пока недосуг. 0