Boa tarde, problema resolvido. Segue abaixo código completo. Obrigado mais uma vez ao Mestre Quintas.
Feliz ano novo.
Marcelo A. L. Carli
Código: Selecionar todos
/*****************************************************************************
* SISTEMA : ROTINA EVENTUAL *
* PROGRAMA : XML.PRG *
* OBJETIVO : Ler xml´s *
* AUTOR : Marcelo Antonio Lázzaro Carli *
* DATA : 17.06.2013 *
* ULT. ALT.: 28.12.2021 *
*****************************************************************************/
#include <minigui.ch>
Function Main()
cSistema:= [teste]
REQUEST HB_LANG_PT
HB_LangSelect([PT])
REQUEST HB_CODEPAGE_PTISO
REQUEST HB_CODEPAGE_PT850 &&& PARA INDEXAR CAMPOS ACENTUADOS
HB_SETCODEPAGE([PT850]) &&& PARA INDEXAR CAMPOS ACENTUADOS
Set wrap on
Set talk off
Set date briti &&& data no formato dd/mm/aaaa
Set dele on &&& ignora registros marcados por deleção
Set score off
Set exact on
Set ToolTip on
Setcancel(.F.) &&& evitar cancelar sistema c/ ALT + C
Set cent on &&& ano com 4 dígitos
Set epoch to 2000 &&& ano a partir de 2000
Set excl off &&& abre arquivos em modo compartilhado
Set navigation extended &&& enter no lugar do tab
Set language to portuguese &&& mensagens em português
Set multiple off warning &&& abrir 1 cópia somente
Set browsesync on &&& para o comando browse funcionar ok
Set tooltipstyle balloon &&& para mensagem dos campos em forma de balão
Set menustyle extended &&& padrão é standard, extended estilo office 2007
Set programmaticchange off &&& introduzida na build 1.9.94
DEFINE WINDOW main AT 0,0 WIDTH 640 HEIGHT 480 TITLE [Menú Principal] ICON [Demo.ico] NOTIFYICON [Demo.ico] MAIN NOSIZE NOMAXIMIZE
DEFINE STATUSBAR FONT [Arial] SIZE 9
STATUSITEM [Malc Informática] ICON [demo.ICO] DEFAULT ACTION {|| MsgInfo([Cliquei no ícone])}
STATUSITEM [Computador: ] + AllTrim(NetName(.F.)) WIDTH 150
STATUSITEM [] WIDTH 100
KEYBOARD
CLOCK
DATE
END STATUSBAR
DEFINE MAIN MENU
POPUP [&Manutenção]
Item [&Ler Xml] ACTION {|| fTelaXml()} IMAGE [NEW.BMP]
SEPARATOR
Item [&Sair] ACTION {|| main.Release} IMAGE [DOOR.BMP]
END POPUP
END MENU
on key escape action {|| thiswindow.release}
END WINDOW
main.center
main.maximize
main.activate
Return (Nil)
Procedure fTelaXml()
Set Font to "MS Sans Serif", 8
Define WINDOW fRetif AT 0, 0 WIDTH 700 HEIGHT 630 TITLE [Retificação de Arquivos Xml's] ICON [Demo.ico] MODAL NOSIZE
DEFINE FRAME Frame_1
ROW 0
COL 5
WIDTH 685
HEIGHT 55
FONTBOLD .T.
CAPTION [Arquivo Xml]
END FRAME
DEFINE FRAME Frame_2
ROW 500
COL 5
WIDTH 685
HEIGHT 55
CAPTION 'Número do Protocolo'
FONTBOLD .T.
END FRAME
DEFINE LABEL Label_3
ROW 520
COL 20
WIDTH 70
HEIGHT 16
VALUE "Protocolo"
FONTBOLD .T.
END LABEL
BTN_TEXTBOX (20, 15, Txt_Xml, 660, {|| fLerXml()})
DEFINE TREE Tree_1 ;
AT 65, 5 ;
WIDTH 685 ;
HEIGHT 430
END TREE
DEFINE TEXTBOX Text_Protoc
ROW 520
COL 110
WIDTH 235
HEIGHT 20
TOOLTIP "Protocolo de Envio"
UPPERCASE .T.
MAXLENGTH 30
VALUE []
END TEXTBOX
@ 570,100 BUTTON oBt_Ok CAPTION [&Apagar Ítem] WIDTH 100 TOOLTIP [Apagar Ítem Atual] ACTION {|| fApagarItem()} BOLD
@ 570,300 BUTTON oBt_Grava CAPTION [&Gravar Xml] WIDTH 100 TOOLTIP [Gravar Xml] ACTION {|| fGravaXml(GetProperty([fRetif], [Txt_Xml], [Value]))} BOLD
on key escape action {|| thiswindow.release}
End WINDOW
fRetif.center
fRetif.activate
Return (Nil)
Static Procedure fApagarItem()
Local cFile:= GetProperty([fRetif], [Txt_Xml], [Value]), cArq
If !Empty(GetProperty([fRetif], [Tree_1], [Value]))
cArq:= hb_MemoRead(cFile)
cArq:= StrTran(cArq, XmlNode(cArq, [evento Id="] + fRetif.Tree_1.Item(fRetif.Tree_1.Value) + ["]), Nil)
cArq:= StrTran(cArq, [<evento Id="] + fRetif.Tree_1.Item(fRetif.Tree_1.Value) + ["></evento>] + hb_OsNewLine(), [])
hb_MemoWrit(cFile, cArq)
DoMethod([fRetif], [Tree_1], [DeleteItem], GetProperty([fRetif], [Tree_1], [Value]))
Endif
fGravaXml(cArq)
Return (Nil)
Static Procedure fLerXml()
Local cBlocoItem, cBlocoItens, cBlocoOcor, cBlocoItemO, cXmlNode, cId, cFile, cTexto, nItemID:= 1
cFile:= Getfile({{[Todos os Arquivos], [*.xml]}}, [Selecione o Arquivo], GetCurrentFolder() + [\], .F. , .T.)
If Empty(cFile)
Return (.F.)
Endif
cTexto:= Hb_MemoRead(cFile)
_SetValue([Txt_Xml], [fRetif], cFile)
fRetif.Tree_1.DeleteAllItems()
HB_SETCODEPAGE([PTISO])
cBlocoItens:= XmlNode(cTexto, [eventos])
If !Empty(cBlocoItens)
For EACH cBlocoItem IN MultipleNodeToArray(cBlocoItens, [evento], .T.)
cXmlNode:= XmlNode(cBlocoItem, [evtMonit], .T.)
cId := Substr(cXmlNode, At([Id=], cXmlNode) + 4) // pular aspas
cId := Substr(cId, 1, At(["], cId) - 1)
NODE cId ID nItemID++
NODE [Vínculo] ID nItemID++
TREEITEM [Cpf: ] + XmlNode(cBlocoItem, [cpfTrab]) ID nItemID++
TREEITEM [Matrícula: ] + XmlNode(cBlocoItem, [matricula]) ID nItemID++
END NODE
NODE [Aso] ID nItemID++
TREEITEM [Tipo Aso: ] + XmlNode(cBlocoItem, [tpExameOcup]) ID nItemID++
TREEITEM [Data Aso: ] + XmlNode(cBlocoItem, [dtAso]) ID nItemID++
TREEITEM [Conclusão Aso: ] + XmlNode(cBlocoItem, [resAso]) ID nItemID++
END NODE
NODE [Exames] ID nItemID++
cBlocoOcor:= XmlNode(cBlocoItem, [evtMonit], .T.)
For EACH cBlocoItemO IN MultipleNodeToArray(cBlocoOcor, [exame], .T.)
TREEITEM [Código do Exame: ] + XmlNode(cBlocoItemO, [procRealizado]) ID nItemID++
TREEITEM [Data do Exame: ] + XmlNode(cBlocoItemO, [dtExm]) ID nItemID++
TREEITEM [Resultado: ] + XmlNode(cBlocoItemO, [indResult]) ID nItemID++
Next
NODE [Examinador] ID nItemID++
TREEITEM [Nome: ] + XmlNode(cBlocoItem, [nmMed]) ID nItemID++
TREEITEM [Crm: ] + XmlNode(cBlocoItem, [nrCRM]) ID nItemID++
TREEITEM [Uf: ] + XmlNode(cBlocoItem, [ufCRM]) ID nItemID++
END NODE
END NODE
NODE [Coordenador] ID nItemID++
TREEITEM [Nome: ] + XmlNode(cBlocoItem, [nmResp]) ID nItemID++
TREEITEM [Crm: ] + XmlNode(XmlNode(cBlocoItem, [respMonit]), [nrCRM]) ID nItemID++
TREEITEM [Uf: ] + XmlNode(XmlNode(cBlocoItem, [respMonit]), [ufCRM]) ID nItemID++
END NODE
END NODE
DOEVENTS()
Next
Else
Msginfo([Arquivo Inválido.], cSistema)
Return (Nil)
Endif
HB_SETCODEPAGE([PT850])
Return (.T.)
Static Procedure fGravaXml(cFile)
Local cArq:= []
If Empty(cFile)
MsgExclamation([Arquivo não Encontrado.], cSistema)
Return (Nil)
Endif
If Empty(GetProperty([fRetif], [Text_Protoc], [Value])) .or. Len(Alltrim(GetProperty([fRetif], [Text_Protoc], [Value]))) < 30
MsgExclamation([Número do Protocolo em Branco ou] + hb_OsNewLine() + [Menor que 30 caracteres.], cSistema)
Return (Nil)
Endif
cArq:= hb_MemoRead(cFile)
cArq:= StrTran(cArq, [<indRetif>1</indRetif>], [<indRetif>2</indRetif>] + hb_OsNewLine() + ;
[ <nrRecibo>] + Alltrim(GetProperty([fRetif], [Text_Protoc], [Value])) + [</nrRecibo>] + hb_OsNewLine())
hb_MemoWrit(cFile, cArq)
Return (Nil)
FUNCTION XmlTransform( cXml ) // SOMENTE PARA FUNCIONAR - ESTÁ EM ZE_XMLFUNC.PRG
LOCAL nCont, cRemoveTag, cLetra, nPos, lTroca, nAscii
cRemoveTag := { ;
[<?xml version="1.0" encoding="utf-8"?>], ; // Petrobras inventou de usar assim
[<?xml version="1.0" encoding="ISO-8859-1"?>], ; // Petrobras agora assim
[<?xml version="1.0" encoding="UTF-8"?>], ; // o mais correto
[<?xml version="1.0" encoding="UTF-8" standalone="yes"?>], ;
[<?xml version="1.00"?>], ;
[<?xml version="1.0"?>] }
cXml := AllTrim( cXml )
FOR nCont = 1 TO Len( cRemoveTag )
cXml := StrTran( cXml, cRemoveTag[ nCont ], "" )
NEXT
IF ! ["] $ cXml // Pode ser usado aspas simples
cXml := StrTran( cXml, ['], ["] )
ENDIF
IF Chr(195) $ cXml
nPos := At( Chr(195), cXml )
IF Asc( Substr( cXml, nPos + 1 ) ) > 122
cXml := hb_Utf8ToStr( cXml )
ENDIF
ENDIF
FOR nCont = 1 TO 2
cXml := StrTran( cXml, Chr(26), "" )
cXml := StrTran( cXml, Chr(13), "" )
cXml := StrTran( cXml, Chr(10), "" )
IF Substr( cXml, 1, 1 ) $ Chr(239) + Chr(187) + Chr(191)
cXml := Substr( cXml, 2 )
ENDIF
cXml := StrTran( cXml, " />", "/>" )
cXml := StrTran( cXml, Chr(195) + Chr(173), "i" )
cXml := StrTran( cXml, Chr(195) + Chr(135), "C" )
cXml := StrTran( cXml, Chr(195) + Chr(141), "I" )
cXml := StrTran( cXml, Chr(195) + Chr(163), "a" )
cXml := StrTran( cXml, Chr(195) + Chr(167), "c" )
cXml := StrTran( cXml, Chr(195) + Chr(161), "a" )
cXml := StrTran( cXml, Chr(195) + Chr(131), "A" )
cXml := StrTran( cXml, Chr(194) + Chr(186), "o." )
cxml := StrTran( cxml, Chr(195) + Chr(162), "a" )
cxml := StrTran( cxml, Chr(195) + Chr(161), "a" )
cxml := StrTran( cxml, Chr(195) + Chr(163), "a" )
cxml := StrTran( cxml, Chr(195) + Chr(173), "i" )
cxml := StrTran( cxml, Chr(195) + Chr(179), "o" )
cxml := StrTran( cxml, Chr(195) + Chr(167), "c" )
cxml := StrTran( cxml, Chr(195) + Chr(169), "e" )
cxml := StrTran( cxml, Chr(195) + Chr(170), "e" )
cxml := StrTran( cxml, Chr(195) + Chr(181), "o" )
cxml := StrTran( cxml, Chr(195) + Chr(160), "o" )
cxml := StrTran( cxml, Chr(195) + Chr(181), "o" )
cxml := StrTran( cxml, Chr(195) + Chr(129), "A" )
cxml := StrTran( cxml, Chr(226) + Chr(128) + Chr(156), [*] ) // aspas de destaque "cames"
cxml := StrTran( cxml, Chr(226) + Chr(128) + Chr(157), [*] ) // aspas de destaque "cames"
cxml := StrTran( cxml, Chr(195) + Chr(180), "o" )
cxml := StrTran( cxml, Chr(195) + Chr(186), "u" )
cxml := StrTran( cxml, Chr(195) + Chr(147), "O" )
cxml := StrTran( cxml, Chr(226) + Chr(128) + Chr(153), [ ] ) // caixa d'agua
cxml := StrTran( cxml, Chr(226) + Chr(128) + Chr(147), [-] ) // - mesmo
cxml := StrTran( cxml, Chr(194) + Chr(179), [3] ) // m3
// so pra corrigir no SQL
cXml := StrTran( cXml, "+" + Chr(129), "A" )
cXml := StrTran( cXml, "+" + Chr(137), "E" )
cXml := StrTran( cXml, "+" + Chr(131), "A" )
cXml := StrTran( cXml, "+" + Chr(135), "C" )
cXml := StrTran( cXml, "?" + Chr(167), "c" )
cXml := StrTran( cXml, "?" + Chr(163), "a" )
cXml := StrTran( cXml, "?" + Chr(173), "i" )
cXml := StrTran( cXml, "?" + Chr(131), "A" )
cXml := StrTran( cXml, "?" + Chr(161), "a" )
cXml := StrTran( cXml, "?" + Chr(141), "I" )
cXml := StrTran( cXml, "?" + Chr(135), "C" )
cXml := StrTran( cXml, Chr(195) + Chr(156), "a" )
cXml := StrTran( cXml, Chr(195) + Chr(159), "A" )
cXml := StrTran( cXml, "?" + Chr(129), "A" )
cXml := StrTran( cXml, "?" + Chr(137), "E" )
cXml := StrTran( cXml, Chr(195) + "?", "C" )
cXml := StrTran( cXml, "?" + Chr(149), "O" )
cXml := StrTran( cXml, "?" + Chr(154), "U" )
cXml := StrTran( cXml, "+" + Chr(170), "o" )
cXml := StrTran( cXml, "?" + Chr(128), "A" )
cXml := StrTran( cXml, Chr(195) + Chr(166), "e" )
cXml := StrTran( cXml, Chr(135) + Chr(227), "ca" )
cXml := StrTran( cXml, "n" + Chr(227), "na" )
cXml := StrTran( cXml, Chr(162), "o" )
cXml := StrTran( cXml, " " + Chr(241) + " ", " " )
cXml := StrTran( cXml, Chr(176), "" ) // graus
cXml := StrTran( cXml, Chr(186), "o" ) // numero
cXml := StrTran( cXml, Chr(220), "U" ) // u com trema
cXml := StrTran( cXml, Chr(170), "" ) // desconhecido
NEXT
FOR nCont = 1 TO Len( cXml )
cLetra := Substr( cXml, nCont, 1 )
nAscii := Asc( cLetra )
lTroca := .T.
DO CASE
CASE cLetra $ "abcdefghijklmnopqrstuvwxyz"; lTroca := .F.
CASE cLetra $ "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; lTroca := .F.
CASE cLetra $ "01234567889"; lTroca := .F.
CASE cLetra $ ",.:/;%*$@?<>()+-#=:_" + Chr(34) + Chr(32); lTroca := .F.
CASE nAscii == 231; cLetra := "c"
CASE nAscii == 199; cLetra := "C"
CASE hb_AScan( { 193, 194, 195, 192 }, nAscii ) != 0 ; cLetra := "A"
CASE hb_AScan( { 224, 225, 226, 227, 228, 229 }, nAscii ) != 0 ; cLetra := "a"
CASE hb_AScan( { 242, 243, 244, 245, 246 }, nAscii ) != 0 ; cLetra := "o"
CASE hb_AScan( { 210, 211, 212, 213, 214 }, nAscii ) != 0 ; cLetra := "O"
CASE hb_AScan( { 200, 201, 202, 203 }, nAscii ) != 0 ; cLetra := "E"
CASE hb_AScan( { 232, 233, 234, 235 }, nAscii ) != 0 ; cLetra := "e"
CASE hb_AScan( { 236, 237, 238, 239 }, nAscii ) != 0 ; cLetra := "i"
CASE hb_AScan( { 204, 205, 206, 207 }, nAscii ) != 0 ; cLetra := "I"
CASE hb_AScan( { 249, 250, 251, 252 }, nAscii ) != 0 ; cLetra := "u"
CASE hb_AScan( { 217, 218, 219 }, nAscii ) != 0 ; cLetra := "U"
CASE nAscii == 128 ; cLetra := "C" // experimental
CASE nAscii == 144 ; cLetra := "E" // experimental
CASE nAscii == 248 ; cLetra := "" // experimental
CASE nAscii == 167 ; cLetra := "o" // experimental
ENDCASE
IF lTroca
cXml := Substr( cXml, 1, nCont - 1 ) + cLetra + Substr( cXml, nCont + 1 )
ENDIF
NEXT
RETURN cXml
FUNCTION XmlNode( cXml, cNode, lComTag ) // SOMENTE PARA FUNCIONAR - ESTÁ EM ZE_XMLFUNC.PRG
LOCAL nInicio, nFim, cResultado := ""
hb_Default( @lComTag, .F. )
nInicio := At( "<" + cNode, cXml )
// a linha abaixo é depois de pegar o início, senão falha
IF " " $ cNode
cNode := Substr( cNode, 1, At( " ", cNode ) - 1 )
ENDIF
IF nInicio != 0
IF ! lComTag
nInicio := nInicio + Len( cNode ) + 2
IF nInicio != 1 .AND. Substr( cXml, nInicio - 1, 1 ) != ">" // Quando tem elementos no bloco
nInicio := hb_At( ">", cXml, nInicio ) + 1
ENDIF
ENDIF
nFim := hb_At( "</" + cNode + ">", cXml, nInicio )
IF nFim != 0
nFim -=1
IF lComTag
nFim := nFim + Len( cNode ) + 3
ENDIF
cResultado := Substr( cXml, nInicio, nFim - nInicio + 1 )
ENDIF
ENDIF
RETURN cResultado
FUNCTION MultipleNodeToArray( cXml, cNode, lComTag ) // SOMENTE PARA FUNCIONAR - ESTÁ EM ZE_XMLFUNC.PRG
LOCAL aNodes := {}
DO WHILE "<" + cNode + " " $ cXml .OR. "<" + cNode + ">" $ cXml
AAdd( aNodes , XmlNode( cXml, cNode, lComTag ) )
IF ! "</" + cNode $ cXml
cXml := ""
ELSE
cXml := Substr( cXml, At( "</" + cNode + ">", cXml ) + Len( "</" + cNode + ">" ) )
ENDIF
ENDDO
RETURN aNodes
Static Procedure fTag_Xml(cXml, cNomeTag, cValor, nEspaco, lFecha) // SOMENTE PARA FUNCIONAR - ESTÁ EM ZE_XMLFUNC.PRG
Local cRetorno:= []
hb_Default(@lFecha, .T.)
hb_Default(@nEspaco, 5)
hb_Default(@cValor, [])
If Empty(cXml)
Return (Nil)
Endif
cValor:= Rtrim(cValor)
If !Empty(cValor) .or. lFecha
cRetorno:= (spac(nEspaco) + [<] + cNomeTag + [>] + cValor + [</] + cNomeTag + [>])
Endif
If !Empty(cRetorno )
Fwrite(cXml, cRetorno + hb_OsNewLine())
Endif
Return (Nil)