[VBA][Outlook] สำหรับใช้เพื่อแก้ไขข้อความที่พิมพ์ผิดภาษาในหน้าจอแก้ไขอีเมล Outlook โดยจะแก้ไขจากอังกฤษเป็นไทยตรงส่วนข้อความที่เลือกไว้

ETCorrectionOutlook.bas

Sub ETCorrection()
'For convert miss spelling in keyboard language from English to Thai (Spelling Thai in English Keyboard)
'by Pongsathorn Sraouthai
Dim i, s
Dim EngChar
Dim ThaChar
Dim EngArray As Variant
Dim ThaArray As Variant

Dim msg As Outlook.MailItem
Dim insp As Outlook.Inspector

EngChar = "1 2 3 4 5 6 7 8 9 0 - = ! @ # $ % ^ & * ( ) _ + q w e r t y u i o p [ ] \ Q W E R T Y U I O P { } | a s d f g h j k l ; ' A S D F G H J K L : "" z x c v b n m , . / Z X C V B N M < > ?"
EngArray = Split(EngChar, " ")
ThaChar = "ๅ / - ภ ถ ุ ึ ค ต จ ข ช + ๑ ๒ ๓ ๔ ู ฿ ๕ ๖ ๗ ๘ ๙ ๆ ไ ำ พ ะ ั ี ร น ย บ ล ฃ ๐ "" ฎ ฑ ธ ํ ๊ ณ ฯ ญ ฐ , ฅ ฟ ห ก ด เ ้ ่ า ส ว ง ฤ ฆ ฏ โ ฌ ็ ๋ ษ ศ ซ . ผ ป แ อ ิ ื ท ม ใ ฝ ( ) ฉ ฮ ฺ ์ ? ฒ ฬ ฦ"
ThaArray = Split(ThaChar, " ")

If Application.ActiveInspector Is Nothing Then
    If Application.ActiveExplorer.Selection.Count = 1 Then
        If Application.ActiveExplorer.Selection.Item(1).Class = olMail Then
            Set msg = Application.ActiveExplorer.Selection.Item(1)
        End If
    Else
        'to many items selected
        MsgBox "Please select one email"
    End If
Else
    Set insp = Application.ActiveInspector
    If insp.CurrentItem.Class = olMail Then
        Set msg = insp.CurrentItem
    End If
End If

If msg Is Nothing Then
    MsgBox "Could not determine the mail item"
Else
    If msg.GetInspector.EditorType = olEditorWord Then
        Set hed = msg.GetInspector.WordEditor
        Set appWord = hed.Application
        Set rng = appWord.Selection
        MsgBox (rng)
        s = rng.Text
        s = Replace(s, ChrW(8217), "'")
        s = Replace(s, ChrW(8216), "'")
        s = Replace(s, ChrW(8220), """")
        s = Replace(s, ChrW(8221), """")
        For i = LBound(EngArray) To UBound(EngArray)
            s = Replace(s, EngArray(i), ThaArray(i))
        Next i
        rng.Text = s
        MsgBox (rng)
    End If
End If

Set appWord = Nothing
Set insp = Nothing
Set rng = Nothing
Set hed = Nothing
Set msg = Nothing

End Sub