macro genera QRcode

Question

Buongiorno a tutti,

da internet ho scaricato il seguente control MSBCODE964.OCX ed installato su due PC (Office 365 ufficio e Office 2021 casa).

La seguente macro, attivabile da un pulsante che ho posto sul foglio6 , tramite due inputbox chiede il testo sorgente (Dim xSRg As Range) e la destinazione (Dim xRRg As Range ).

Vorrei modificarlo in modo automatico che su entrata nel foglio6 senza attivare le due inputbox

prenda i valori dalla cella B30 composta da =concatena

ed inserisca il QRcode in B31 formata da range (B31-F36)

ed ad ogni variazione di B30 aggiorni ilQRcode.

Spero solo di essere stato chiaro.

Sub setQR()

'Updated by Extendoffice 2018/8/22

Dim xSRg As Range 

Dim xRRg As Range 

Dim xObjOLE As OLEObject 

On Error Resume Next 

Set xSRg = Application.InputBox("Please select the cell you will create QR code based on", "tools for Excel", , , , , , 8) 

If xSRg Is Nothing Then Exit Sub 

Set xRRg = Application.InputBox("Select a cell to place the QR code", "tools for Excel", , , , , , 8) 

If xRRg Is Nothing Then Exit Sub 

Application.ScreenUpdating = False 

Set xObjOLE = ActiveSheet.OLEObjects.Add("BARCODE.BarCodeCtrl.1") 

xObjOLE.Object.Style = 11 

xObjOLE.Object.Value = xSRg.Text 

ActiveSheet.Shapes.Item(xObjOLE.Name).Copy 

ActiveSheet.Paste xRRg 

xObjOLE.Delete 

Application.ScreenUpdating = True 

End Sub

saluti

Massimo

Answer 1

Ciao Paolo,

grazie per il tuo aiuto,

ho applicato le modifiche che mi hai proposto, con integrazione del suggerimento di Eleuterio.

La macro non genera nessun codiceQR sull'evento change del foglio6.

Con questa lo genera e lo porta in B31, le celle che originano B30 sono altre, per cui il target va incrociato con un altro intervallo:

Private Sub Worksheet_Change(ByVal Target As Range) 

Dim xObjOLE As OLEObject, shpTemp As Shape 

    ' Verifica se la modifica è avvenuta in B30 

    If Not Intersect(Target, Range("D7:J7")) Is Nothing Then 

        On Error GoTo Xit 

        Application.ScreenUpdating = False 

        Application.EnableEvents = False 

        For Each shpTemp In ActiveSheet.Shapes 

            shpTemp.Delete 

        Next shpTemp 

        ' Crea il QR code 

        Set xObjOLE = Me.OLEObjects.Add("BARCODE.BarCodeCtrl.1") 

        With xObjOLE 

            .Object.Style = 11 

            .Object.Value = Range("B30") 

        End With 

        ' Copia il QR code in B31 

        With ActiveSheet 

            .Shapes.Item(xObjOLE.Name).Copy 

            .Paste Range("B31") 

            With .Shapes(.Shapes.Count) 

                .Width = 144.75 

                .Height = 120.75 

            End With 

        End With 

        ' Elimina l'oggetto OLE temporaneo 

        xObjOLE.Delete 

    End If 

Xit: 

    Application.ScreenUpdating = True 

    Application.EnableEvents = True 

End Sub

Ciao.

Answer 2

Semplicemente perfetto!

Grazie

Answer 3

Ciao Paolo,

grazie per il tuo aiuto,

ho applicato le modifiche che mi hai proposto, con integrazione del suggerimento di Eleuterio.

La macro non genera nessun codiceQR sull'evento change del foglio6.

Ad ogni modo allego il file di esempio

https://www.dropbox.com/scl/fi/fbob9wmreciw0ccjls4xw/Test-QRcode.xlsm?rlkey=52hhrk6apf8axf5lcvxun0yx1&dl=0

saluti

Massimo

Answer 4

Premesso che la soluzione te l'ha correttamente proposta Paolo, ricordati, insieme ad Application.ScreenUpdating, di disattivare anche gli eventi con Application.EnableEvents = False, da riattivare come fai per Application.ScreenUpdating.

Ciao.

Ricordati anche che vanno contrassegnate le risposte in questa discussione rimasta aperta,

grazie.

Answer 5

Ciao Massimo,

Per automatizzare la generazione del QR code basato sulla cella B30 e inserirlo nella cella B31, puoi modificare la tua macro come segue. Assicurati di salvare una copia del tuo file prima di apportare modifiche alla macro.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xSRg As Range
    Dim xRRg As Range
    Dim xObjOLE As OLEObject

    ' Definisci il range B30
    Set xSRg = Me.Range("B30")

    ' Definisci il range B31
    Set xRRg = Me.Range("B31")

    ' Verifica se la modifica è avvenuta in B30
    If Not Intersect(Target, xSRg) Is Nothing Then
        Application.ScreenUpdating = False

        ' Crea il QR code
        Set xObjOLE = Me.OLEObjects.Add("BARCODE.BarCodeCtrl.1")
        xObjOLE.Object.Style = 11
        xObjOLE.Object.Value = xSRg.Text

        ' Copia il QR code in B31
        Me.Shapes.Item(xObjOLE.Name).Copy
        xRRg.PasteSpecial

        ' Elimina l'oggetto OLE temporaneo
        xObjOLE.Delete

        Application.ScreenUpdating = True
    End If
End Sub

Questa modifica sfrutta l'evento Worksheet_Change che viene attivato ogni volta che avviene una modifica nel foglio. La macro verifica se la modifica è avvenuta nella cella B30 e, in caso affermativo, genera il QR code e lo inserisce nella cella B31.

Ricorda che questa macro verrà attivata ad ogni modifica nel foglio, quindi potrebbe essere necessario aggiungere ulteriori controlli o adattamenti in base alle tue esigenze specifiche.

Spero che questo ti aiuti! Fammi sapere se hai ulteriori domande o se c'è qualcos'altro in cui posso assisterti.