View Single Post
 
Old 04-29-2021, 11:33 PM
gmayor's Avatar
gmayor gmayor is offline Windows 10 Office 2019
Expert
 
Join Date: Aug 2014
Posts: 4,137
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

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
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote