[VBA] RTF(Rich Text Format) 을 Plain Text로 변경

RTF 자료를 일반 문자열로 변경이 필요할 때

 

클래스 모듈을 삽입하고 이름을 clsRTFParsser 로 하고 아래 코드를 삽입합니다.

Option Explicit
'//32bit 버전 출처 : https://stackoverflow.com/a/1747886
#If VBA7 Then
'// 64Bit용에는 PtrSafe 적용, LongPtr로 변경
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal Hwnd As Long) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

#Else
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long

Private Declare Function OpenClipboard Lib "user32" (ByVal Hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
#End If

'Dim wdDoc As Word.Document 'Ref: Microsoft Word 16.0 Object Library'
Dim wdDoc As Object

Private Sub Class_Initialize()
    'Set wdDoc = New Word.Document
    Set wdDoc = CreateObject("Word.Document")
End Sub

Private Sub Class_Terminate()
    wdDoc.Close False
    Set wdDoc = Nothing
End Sub


Private Function CopyRTF(strCopyString As String) As Boolean
    Dim hGlobalMemory  As LongPtr
    Dim lpGlobalMemory As LongPtr
    Dim hClipMemory    As LongPtr
    Dim lngFormatRTF   As Long
    
    On Error Resume Next
    'Allocate and copy string to memory'
    hGlobalMemory = GlobalAlloc(&H42, Len(strCopyString) + 1)
    lpGlobalMemory = GlobalLock(hGlobalMemory)
    lpGlobalMemory = lstrcpy(lpGlobalMemory, strCopyString)
    
    'Unlock the memory and then copy to the clipboard'
    If GlobalUnlock(hGlobalMemory) = 0 Then
        If OpenClipboard(0&) <> 0 Then
            Call EmptyClipboard
            lngFormatRTF = RegisterClipboardFormat("Rich Text Format")
            hClipMemory = SetClipboardData(lngFormatRTF, hGlobalMemory)
    
            CopyRTF = CBool(CloseClipboard)
        End If
    End If
End Function

Private Function PasteRTF() As String
    Dim strOutput As String
    
    wdDoc.Range.Paste
    strOutput = wdDoc.Range.Text
    
    '// vbCrLf와 vbCr을 모두 vbLf=Chr(10)으로 변경하고 앞/뒤에 있는 것을 제거
    strOutput = Trim(Replace(Replace(strOutput, vbCrLf, vbLf), vbCr, vbLf))
    Do While Left(strOutput, 1) = vbLf: strOutput = Mid(strOutput, 2): Loop
    Do While Right(strOutput, 1) = vbLf: strOutput = Left(strOutput, Len(strOutput) - 1): Loop
    
    PasteRTF = strOutput
End Function

Public Function ParseRTF(strRTF As String) As String
    If CopyRTF(strRTF) Then
        '// 시간 Delay가 없을 경우 Error가 발생함
        Application.Wait Now() + 0.00000001
        ParseRTF = PasteRTF
    Else
        ParseRTF = "Error in copying to clipboard"
    End If
End Function

 

 

Cell 범위를 선택하여 매크로를 사용할 경우

Sub RTF2TEXTwithClipboard()
    Dim C As Range, strRTF  As String
    Dim RTFParser As clsRTFParser
    Set RTFParser = New clsRTFParser
    
    For Each C In Selection.Cells
        If Left(Trim(C.Value2), 1) = "{" Then
            strRTF = RTFParser.ParseRTF(C.Value2)
            C = strRTF
            C.WrapText = False
        End If
    Next
End Sub

 

함수로 사용할 경우

Function RTFtoText(RTFcode As String)
    Dim RTFParser As clsRTFParser
    Set RTFParser = New clsRTFParser
    RTFtoText = RTFParser.ParseRTF(RTFcode)
End Function

 

ConvertRTFtoText.xlsm

0.04MB