PowerPoint Macro Insert QR Code

Attached you will find a Macro that inserts QR Code to your actual Slide at PowerPoint.

Its important to add VBA References in order to work (Probably you can use less than the ones i post). As well, the code goes in a module called "Functions" (You can use an other one if preferred, just change the call routines on the code)

To execute the code, use subroutine: GenerateQRCode

Enjoy it!

' VBA References for this file (Tools > References...)
'   - Visual Basic For Applications
'   - Microsoft PowerPoint 16.0 Object Library
'   - OLE Automation
'   - Microsoft Office 16.0 Object Libary
'   - Microsoft Forms 2.0 Object Library
'   - Microsoft Excel 16.0 Object Library
'   - Microsoft Outlook 16.0 Object Library
'   - Microsoft Word 16.0 Object Library
'   - Microsoft ActiveX Data Objects 6.1 Library
'   - Microsoft Internet Controls
'   - Microsoft Script Control 1.0
'   - Microsoft Scripting Runtime
'   - Microsoft Visual Basic for Aplications Extensibility 5.3
'   - Microsoft XML, v6.0
'   - Windows Script Host Object Model

Option Explicit

#If VBA7 Then        'Microsoft Office x64

    Public Declare PtrSafe Function ChooseColor_Dlg Lib "comdlg32.dll" Alias "ChooseColorA" (pcc As CHOOSECOLOR_TYPE) As LongPtr
    
    Public hHook        As LongPtr        ' handle to the Hook procedure (global variable)
    
    Public Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As LongPtr
    
    Public Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As LongPtr

#Else        'Microsoft Office x86
    
    Public Declare Function ChooseColor_Dlg Lib "comdlg32.dll" Alias "ChooseColorA" (pcc As CHOOSECOLOR_TYPE) As Long
    
    Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
    
    Public Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
    
    Public hHook    As Long        ' handle to the Hook procedure (global variable)
    
#End If

    'Color Picker Variables Definition (comdl32.dll)
    Public Type CHOOSECOLOR_TYPE
        lStructSize     As LongPtr
        hwndOwner       As LongPtr
        hInstance       As LongPtr
        rgbResult       As LongPtr
        lpCustColors    As LongPtr
        flags           As LongPtr
        lCustData       As LongPtr
        lpfnHook        As LongPtr
        lpTemplateName  As String
    End Type
    
    'Color Picker Public Variables Definition
    Public HexColorPick As String
    
    Public Const CC_ANYCOLOR = &H100
    Public Const CC_ENABLEHOOK = &H10
    Public Const CC_ENABLETEMPLATE = &H20
    Public Const CC_ENABLETEMPLATEHANDLE = &H40
    Public Const CC_FULLOPEN = &H2
    Public Const CC_PREVENTFULLOPEN = &H4
    Public Const CC_RGBINIT = &H1
    Public Const CC_SHOWHELP = &H8
    Public Const CC_SOLIDCOLOR = &H80
    
    'Code Generator Variables Definition
    Public CodeType     As String
    
    'Public Integer Variables used to Count / Incrementals
    Public i            As Integer
    Public j            As Integer
    Public x            As Integer
    Public y            As Integer
    
    'Public Other Variables definition
    Public oPres        As Presentation
    Public sld          As Slide
    Public ActivePres   As Object
    
    Public PPApp        As PowerPoint.Application
    Public PPPres       As PowerPoint.Presentation
    Public PPSlide      As PowerPoint.Slide
    
    Public oSld         As Slide
    Public oSh, oShp    As Shape
    Public oTitle       As TextRange
    
    Public TrapFlag     As Boolean

'*** QR Code START ***

Sub GenerateQRCode()
    
    Dim URL$, FilePath$
    
    On Error GoTo ErrorHandler
    
    Dim QRCodeData  As String
    
    CodeType = "QRCode"        'Defines Code to Generate
    
    QRCodeData = InputBox("Type desired information Or data To generate QR Code." & vbCrLf & vbCrLf & vbCrLf & "**This code Type encodes alphanumeric data (Latin-1, Kanji) And Bytes", "QR Code Generator")
    
    If QRCodeData = "" Or QRCodeData = vbNullString Then GoTo ErrorHandler
    
    Call Functions.ColorPickerDialog        'Call Color Picker
    
    DeleteUrlCacheEntry URL
    
    ' QR Code Code Settings
    ' Min Size=10 | Max=500
    URL = "https://barcode.tec-it.com/barcode.ashx?data=" & QRCodeData & "&code=MobileQRCode&translate-esc=true&eclevel=L&Color=" & HexColorPick & "&Height=25&width=25" & "&imagetype=Png"
    
    FilePath = ActivePresentation.Path & "\" & CodeType & ".png"
    
    URLDownloadToFile 0, URL, FilePath, 0, 0
    
    Call Functions.AddCodeToSlide(FilePath)
    
    Exit Sub
    
ErrorHandler:
    
    'MsgBox "Code cant be generated without information at input box, please run function again and include an input.", vbCritical, "Error Message - Code Generator"
    
    Exit Sub
    
End Sub

'*** QR Code FINISH ***

'*** Color Picker Function START ***

Public Function ColorPickerDialog() As Long
    
    Dim FakeControl As IRibbonControl        'pass it an iRibbonControl object, declared a fake one
    Dim CC_T        As CHOOSECOLOR_TYPE, Retval As Variant
    Dim FullColorCode As Variable
    
    On Error GoTo ErrorHandler
    
    Static BDF(16)  As Long
    BDF(0) = RGB(0, 255, 0)        'first defined color
    BDF(1) = RGB(255, 0, 0)        'second defined color
    BDF(2) = RGB(0, 0, 255)        'third defined color
    
    With CC_T
        .lStructSize = Len(CC_T)
        .flags = CC_RGBINIT Or CC_ANYCOLOR Or CC_FULLOPEN Or CC_PREVENTFULLOPEN
        .rgbResult = RGB(0, 0, 0)
        .lpCustColors = VarPtr(BDF(0))
    End With
    
    Retval = ChooseColor_Dlg(CC_T)
    
    If Retval <> 0 Then
        
        ' Reference existing instance of PowerPoint
        On Error Resume Next
        
        Set PPApp = GetObject(, "Powerpoint.Application")
        
        On Error GoTo 0
        
        If PPApp Is Nothing Then
            Set PPApp = CreateObject("Powerpoint.Application")
            PPApp.Visible = msoCTrue
        Else
            Set PPPres = PPApp.ActivePresentation
            
        End If
        
        ' Reference active slide
        Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
        
        ''Converts decimal (Long) value to RGB from: CC_T.rgbResult
        'R = CC_T.rgbResult Mod 256
        'G = Int(CC_T.rgbResult / 256) Mod 256
        'B = Int(CC_T.rgbResult / 256 / 256) Mod 256
        
        ' Converts decimal (Long) value to HEX from: CC_T.rgbResult
        HexColorPick = VBA.Right$("00" & VBA.Hex(CC_T.rgbResult Mod 256), 2) & VBA.Right$("00" & VBA.Hex(Int(CC_T.rgbResult / 256) Mod 256), 2) & VBA.Right$("00" & VBA.Hex(Int(CC_T.rgbResult / 256 / 256) Mod 256), 2)

    End If
    
ErrorHandler:
    
    Exit Function
    
End Function

'*** Color Picker Function FINISH***

'*** Add QR Code to Slide START  ***

Private Function AddCodeToSlide(ByVal strFile As String)
    
    Dim objPresentaion As Presentation
    Dim objSlide    As Slide
    
    Set objPresentaion = ActivePresentation
    
    Set objSlide = ActivePresentation.Slides(ActiveWindow.Selection.SlideRange.SlideIndex)
    
    Call objSlide.Shapes.AddPicture(ActivePresentation.Path & "\" & CodeType & ".png", msoCTrue, msoCTrue, 100, 100)
    
    Kill ActivePresentation.Path & "\" & CodeType & ".png"        ' Deletes downloaded code image
    
End Function

'*** Add QR Code to Slide Finish***