Sub SPTiberian_To_Unicode()
    OldText$ = Selection.Text
    
    ZeroWidths$ = "YZ%UOFAE""I?JV:03GQR\\{XS@uofae'i/jv;24HWT|}$&,^=7"
    oldmap$ = "!""#$%&'()*+,-./012347:;=?@ACEFGHIJKMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"
    
    newmap$ = ChrW(1472) + ChrW(1461) + ChrW(1513) + ChrW(1473) + ChrW(1468) + ChrW(1474) + ChrW(1461) + ChrW(1506) + ChrW(1488) + "." + ChrW(1496)
    newmap = newmap + ChrW(1468) + ChrW(1470) + ChrW(1475) + ChrW(1459) + ChrW(1451) + ChrW(1464) + ChrW(1451) + ChrW(1425) + ChrW(1425) + ChrW(1456)
    newmap = newmap + ChrW(1456) + ChrW(1456) + ChrW(1468) + ChrW(1459) + ChrW(1468) + ChrW(1463) + ChrW(1509) + ChrW(1462) + ChrW(1464) + ChrW(1455)
    newmap = newmap + ChrW(1455) + ChrW(1460) + ChrW(1458) + ChrW(1498) + ChrW(1501) + ChrW(1503) + ChrW(1465) + ChrW(1507) + ChrW(803) + ChrW(805)
    newmap = newmap + ChrW(1476) + ChrW(805) + ChrW(1467) + ChrW(1457) + ChrW(803) + ChrW(1455) + ChrW(1455) + ChrW(1476) + "]" + ChrW(1469) + "[" + ChrW(1468)
    newmap = newmap + ChrW(8211) + ChrW(1523) + ChrW(1463) + ChrW(1489) + ChrW(1510) + ChrW(1491) + ChrW(1462) + ChrW(1464) + ChrW(1490) + ChrW(1492)
    newmap = newmap + ChrW(1460) + ChrW(1458) + ChrW(1499) + ChrW(1500) + ChrW(1502) + ChrW(1504) + ChrW(1465) + ChrW(1508) + ChrW(1511) + ChrW(1512)
    newmap = newmap + ChrW(1505) + ChrW(1514) + ChrW(1467) + ChrW(1457) + ChrW(1493) + ChrW(1495) + ChrW(1497) + ChrW(1494) + ChrW(1471) + ChrW(1469)
    newmap = newmap + ChrW(1471) + ChrW(1524)

    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Text = "^p"
        .Replacement.Text = ""
        .Font.Name = "SPTiberian"
        .Replacement.Font.Name = "Courier New"
        .Execute Replace:=wdReplaceAll
        
        .Text = "^n"
        .Replacement.Text = ""
        .Execute Replace:=wdReplaceAll
        
        .Text = ""
        .Replacement.Text = ""
        .Execute
        While .Found
            OldText$ = Selection.Text
            'Selection.Font.Name = "SBL Hebrew"
            Selection.Font.NameBi = "SBL Hebrew"
            Selection.TypeText Alef
            Selection.TypeBackspace
            NewText$ = ""
            For i% = 1 To Len(OldText$)
                c$ = Mid$(OldText$, i, 1)
                If AscW(c$) < 0 Then c$ = ChrW(AscW(c$) - &HF000)
                p% = InStr(oldmap$, c$)
                If p > 0 Then
                    u$ = Mid$(newmap$, p%, 1)
                Else
                    u$ = c$
                End If
                If InStr(ZeroWidths, c$) = 0 Then
                    NewText$ = u$ + NewText$
                Else
                    NewText$ = Left$(NewText$, 1) + u$ + Mid$(NewText, 2)
                End If
            Next i
            Selection.TypeText NewText$
            .Execute
        Wend
    End With

End Sub