Ir ao conteúdo
  • Cadastre-se

Douglas Immer

Membro Júnior
 Perfil  Explorar Conteúdo

  • Posts

    8

  • Cadastrado em

  • Última visita

 Tipo de conteúdo 

posts postados por Douglas Immer

    Excel com celulas em formatação RTF

    em Microsoft Office e similares

    Postado

    Tive um problema com texto em formatação RTF, exemplo do texto:

     

    {\rtf1\ansi\ansicpg1252\deff0{\fonttbl{\f0\fnil\fcharset0 Arial;}}
    \viewkind4\uc1\pard\lang1046\fs20 Observa\'e7\'f5es
    \par 
    \par OBSERVA\'c7\'d5ES
    \par }

     

     

    utilizei este vba para retirar apenas o texto que me interessava:

     

     
    Public Function Rtf2Txt(tText As String) As String
    ' De reeks RtfCode(1-60) wordt gebruikt om extra rare tekens in vast te leggen welke
    ' bij het tonen van de tekxt uit de verschillende NOTES uit MARVAL weggehaald moeten / kunnen
    ' worden, deze kan aan naar gelang aangepast gewijzigd worden.
    Dim x As Integer
    Dim xPos As Integer, xNext As Integer, yPos As Integer
    Dim ttxt As String
     
    Dim RtfCode(100) As String
     
    RtfCode(1) = "@@@"
    RtfCode(2) = "///"
    RtfCode(3) = "???"
    RtfCode(4) = "'''"
    RtfCode(5) = "***"
    RtfCode(6) = "---"
    RtfCode(7) = "==="
    RtfCode(8) = ">>>"
    RtfCode(9) = "\tab "
    RtfCode(10) = "\par }"
    RtfCode(11) = ""
    RtfCode(12) = "-=- "
    RtfCode(13) = ";;;"
    RtfCode(14) = "\b0"
    RtfCode(15) = "\cf2"
    RtfCode(16) = "\f1"
    RtfCode(17) = "\fs24"
    RtfCode(18) = "\fx"
    RtfCode(19) = "\pard"
    RtfCode(20) = "\fs20"
    RtfCode(21) = "\f0"
    RtfCode(22) = "\f1"
    RtfCode(23) = "\cf1"
    RtfCode(24) = "\f3"
    RtfCode(25) = "\protect0"
    RtfCode(26) = "\protect"
    RtfCode(27) = "\sa96"
    RtfCode(28) = "cf0"
    RtfCode(29) = "\tab"
    RtfCode(30) = "\fi"
    RtfCode(31) = "\~"
    RtfCode(32) = "\fnil"
    RtfCode(33) = "\deflang1046"
    RtfCode(34) = "\fz"
    RtfCode(35) = "\f4"
    RtfCode(36) = "\b"
    RtfCode(37) = "\sb"
    RtfCode(38) = "\ulnone"
    RtfCode(39) = "\ul"
    RtfCode(40) = "\f2"
    RtfCode(41) = "\sa100\"
    RtfCode(42) = "\fs18"
    RtfCode(43) = "\ri360100"
    RtfCode(44) = "\li360"
    RtfCode(45) = "\fs16"
    RtfCode(46) = "\'bf"
    RtfCode(47) = "\ltrpar96"
    RtfCode(48) = "\ltrpar"
    RtfCode(49) = "\fs17"
    RtfCode(50) = "\kerning0"
    RtfCode(51) = "\keepn"
    RtfCode(52) = "\sa60"
    RtfCode(53) = "\sa40"
    RtfCode(54) = "\s1"
    RtfCode(55) = "\qjct"
    RtfCode(56) = "\qj"
    RtfCode(57) = "\li720"
    RtfCode(58) = "' -> '"
    RtfCode(59) = "\ansicpg1252"
    RtfCode(60) = "\deff0"
    RtfCode(61) = "\red0"
    RtfCode(62) = "\blue0"
    RtfCode(63) = "\green0"
    RtfCode(64) = "\uc1"
    RtfCode(65) = "\viewkind4"
    RtfCode(66) = "\rtf1"
    RtfCode(67) = "\ansi"
    RtfCode(68) = "\colortbl"
    RtfCode(69) = "\fswiss\fprq2\fcharset0"
    RtfCode(70) = "ttbl;"
    RtfCode(71) = "blue255"
    RtfCode(72) = "\fonttbl"
    RtfCode(73) = ";"
    RtfCode(74) = "\fcharset0"
    RtfCode(75) = "\fs22 "
    RtfCode(76) = "\ "
    RtfCode(77) = "\fbidis\fswiss\fprq2"
    RtfCode(78) = "\fswiss\fprq2"
    RtfCode(79) = "\fmodern\fcharset0 Courier New"
    RtfCode(80) = "\fbidis"
    RtfCode(81) = "}"
    RtfCode(82) = Space(2)
    RtfCode(83) = "{"
    RtfCode(84) = "\f2\froman\fcharset0"
    RtfCode(85) = "Times New Roman"
    RtfCode(86) = " Arial"
    RtfCode(87) = "\fswiss\froman"
    RtfCode(88) = " MS Sans Serif"
    RtfCode(89) = " Verdana"
    RtfCode(90) = "\fswiss"
    RtfCode(91) = "\lang1046"
    RtfCode(92) = ""
    RtfCode(93) = ""
    RtfCode(94) = ""
    RtfCode(95) = ""
    RtfCode(96) = ""
    RtfCode(97) = ""
    RtfCode(98) = ""
    RtfCode(99) = ""
    RtfCode(100) = ""
    ' Aan de hand van bovenstaande reeks worden die tekens vervangen door ""
    ' X = 1
    For x = 1 To 100
        tText = Replace(tText, RtfCode(x), Space(0))
        ' X = X + 1
    Next x  'Loop While RtfCode(X) <> "" And X < 100
     
    tText = Replace(tText, Chr(13), vbNullString)
    tText = Replace(tText, Chr(10), vbNullString)
     
    ttxt = "#"
    For xPos = 1 To Len(tText)
        If Mid(tText, xPos, Len(tempTxt)) = ttxt Then
            tText = ReduceTxt(tText, xPos)
            Exit For
        End If
    Next xPos
     
    tempTxt = "HHA"
    For xPos = 1 To Len(tText)
        If Mid(tText, xPos, Len(tempTxt)) = ttxt Then
            tText = ReduceTxt(tText, xPos)
            Exit For
        End If
    Next xPos
     
    tempTxt = "2009"
    For xPos = 1 To Len(tText)
        If Mid(tText, xPos, Len(tempTxt)) = ttxt Then
            tText = ReduceTxt(tText, xPos)
            Exit For
        End If
    Next xPos
     
    tempTxt = "BO g"
    For xPos = 1 To Len(tText)
        If Mid(tText, xPos, Len(tempTxt)) = ttxt Then
            tText = ReduceTxt(tText, xPos)
            Exit For
        End If
    Next xPos
     
    For xPos = 1 To Len(Trim(tText))
        If Mid(tText, xPos, 1) <> " " Then
            tText = ReduceTxt(tText, xPos)
            Exit For
        End If
    Next xPos
     
    For xPos = Len(Trim(tText)) To 1 Step -1
        If Mid(tText, xPos, 1) <> " " Then
            tText = Left(tText, xPos)
            Exit For
        End If
    Next xPos
     
    x = 1
    xPos = 1
    xNext = 1
    ' Haalt bij de RTF opmaak de eerste accolade weg
    tText = Replace(tText, "{", "")
     
    ' Er komen een serie codes voor, voorafgegaan door /tx en dan cijfers
    ' Deze routine zoekt de \tx op en de daarop volgende \ en verwijderd de
    ' reeks \tx???????
    ' Dit doet ie totdat er geen \tx meer voorkomt
    If InStr(1, tText, "\tx") = 0 Then GoTo Doorgaan
     
    Do
        xPos = InStr(xPos, tText, "\tx")
        yPos = IIf(InStr(xPos + 1, tText, "\") <= xPos, 1, -1)
        If xPos > 0 And yPos >= xPos Then tText = Replace(tText, Mid(tText, xPos, yPos), "")
    Loop While InStr(1, tText, "\tx") > 0
    xPos = 1
     
    Doorgaan:
    tText = Replace(tText, "}", "")
    tText = Replace(tText, "{", "")
    ' hier wordt de RTF opmaak afsluit commando verwijderd \par }
    tText = Replace(tText, "\par }", "")
    tText = Replace(tText, "\'e7", "ç")
    tText = Replace(tText, "\'c7", "Ç")
    tText = Replace(tText, "\'f5", "õ")
    tText = Replace(tText, "\'d5", "Õ")
    tText = Replace(tText, "\'c3", "Ã")
    tText = Replace(tText, "\'e3", "ã")
    tText = Replace(tText, "\'ea", "ê")
    tText = Replace(tText, "\'ca", "Ê")
    tText = Replace(tText, "\'e1", "á")
    tText = Replace(tText, "\'c1", "Á")
    tText = Replace(tText, "\'e9", "é")
    tText = Replace(tText, "\'c9", "É")
    tText = Replace(tText, "\'e0", "à")
    tText = Replace(tText, "\'c0", "À")
    tText = Replace(tText, "\par ", " ")
     
     
     
    Rtf2Txt = tText
     
    End Function
     
    Function ReduceTxt(tText As String, xPos As Integer) As String
        ReduceTxt = Right(tText, Len(tText) - (xPos - 1))
    End Function
     
     
     
    O resultado foi:
    Observações OBSERVAÇÕES
     
     
    Espero que seja util.

Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas comunidades sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

Mais

×
×
  • Criar novo...

Ebook grátis: Aprenda a ler resistores e capacitores!

EBOOK GRÁTIS!

CLIQUE AQUI E BAIXE AGORA MESMO!