The principles would be similar, but given the proposed layout, I suggest using a table.
The bigger problem is the missing values, so unless you have a better idea, you could define them as variables as shown below. The following works with your example and the VIN number is the last four digits
Code:
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
You can send your appreciation to my web site
