Option Explicit

Sub AddBarCode()
'Graham Mayor - https://www.gmayor.com - Last updated - 30 Apr 2021
Dim olItem As AppointmentItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim oPara As Object
Dim oParRng As Object
Dim oTable As Object
Dim oCell As Object
Dim lngCell As Long
Dim sEmail As String
Dim sType As String
Dim sInspector As String
Dim sPin As String
Dim sDate As String
Dim sUnlicensed As String
Dim sBar As String

'define the missing values

    sEmail = "someone@somewhere.com"
    sType = "CAR/TRUCK"
    sInspector = "KOMOBU"
    sPin = "1234"
    sDate = Format(Date, "mm/dd/yyyy")
    sUnlicensed = "False"

    On Error Resume Next
    Select Case Outlook.Application.ActiveWindow.Class
        Case olInspector
            Set olItem = ActiveInspector.currentItem
        Case olExplorer
            Set olItem = Application.ActiveExplorer.Selection.Item(1)
    End Select
    With olItem
        .Save
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        oRng.Text = Replace(oRng.Text, Chr(11), Chr(13))
        oRng.collapse 1
        Set oTable = oRng.Tables.Add(oRng, 3, 4)
        oRng.Start = oTable.Range.End
        oRng.End = wdDoc.Range.End
        For Each oPara In oRng.Paragraphs
            Set oParRng = oPara.Range
            oParRng.End = oParRng.End - 1
            If InStr(1, oParRng.Text, ":") > 0 Then
                Select Case Trim(UCase(Split(oParRng.Text, ":")(0)))
                    Case "VIN"
                        Set oCell = oTable.Range.cells(12).Range
                        oCell.End = oCell.End - 1
                        oCell.Text = oParRng.Text
                    Case "OD"
                        Set oCell = oTable.Range.cells(7).Range
                        oCell.End = oCell.End - 1
                        oCell.Text = oParRng.Text
                    Case "PLATE"
                        Set oCell = oTable.Range.cells(11).Range
                        oCell.End = oCell.End - 1
                        oCell.Text = oParRng.Text
                    Case "STICKER NUMBER"
                        Set oCell = oTable.Range.cells(6).Range
                        oCell.End = oCell.End - 1
                        oCell.Text = oParRng.Text
                    Case "INSERT NUMBER"
                        Set oCell = oTable.Range.cells(8).Range
                        oCell.End = oCell.End - 1
                        oCell.Text = oParRng.Text
                End Select
            End If
        Next oPara
        Set oCell = oTable.Range.cells(1).Range
        oCell.End = oCell.End - 1
        oCell.Text = "INSPECTOR: " & sInspector
        Set oCell = oTable.Range.cells(2).Range
        oCell.End = oCell.End - 1
        oCell.Text = "PIN: " & sPin
        Set oCell = oTable.Range.cells(3).Range
        oCell.End = oCell.End - 1
        oCell.Text = "EMAIL: " & sEmail
        Set oCell = oTable.Range.cells(4).Range
        oCell.End = oCell.End - 1
        oCell.Text = "CONFIRM EMAIL: " & sEmail
        Set oCell = oTable.Range.cells(5).Range
        oCell.End = oCell.End - 1
        oCell.Text = "VEHICLE TYPE: " & sType
        Set oCell = oTable.Range.cells(9).Range
        oCell.End = oCell.End - 1
        oCell.Text = "DATE: " & sDate
        Set oCell = oTable.Range.cells(10).Range
        oCell.End = oCell.End - 1
        oCell.Text = "ULICENSED: " & sUnlicensed

        For lngCell = 1 To 12
            Set oCell = oTable.Range.cells(lngCell).Range
            oCell.End = oCell.End - 1
            oCell.MoveStartUntil ":"
            oCell.Start = oCell.Start + 2
            If lngCell = 12 Then
                sBar = Right(oCell.Text, 4)
            Else
                sBar = oCell.Text
            End If
            wdDoc.Fields.Add oCell, 99, Chr(34) & sBar & Chr(34) & Chr(32) & "QR" & " \t", False
        Next lngCell
        'oRng.Delete 'Optionally delete the original text
        .Display
    End With
lbl_Exit:
    Exit Sub
End Sub