XMLs

[randyzapata]

Does any have code for importing xmls into word so each tag is pulled
out. I found this on UtterAccess.com, but it is only good for a few
levels of tags and was made for weather.


http://www.utteraccess.com/forums/s...e=y&olderval=&oldertype=#Post293885&bodyprev=


Public Sub CallXML() ImportXML ("cc") ImportXML ("forecast")
ImportXMLEnd SubPublic Sub ImportXML(Optional ReportType As String)Dim
Ie As ObjectDim I As Integer, J As Integer, K As Integer, IEq As
IntegerDim OutCol As Integer, OutRow As Integer, OutSpot As Integer,
EqCount As IntegerDim InputArr As VariantDim OutputArr() As StringDim
LevelArr(0 To 8) As String, Level As IntegerDim TempStr As StringDim
TempArr() As String, EqTemparr() As String, CountArr() As StringDim
Flag As IntegerDim sWebXML As StringDim MyOutDoc As StringReportType =
UCase(ReportType)Select Case ReportType Case "CC", "CURRENT",
"CURRENTCONDITIONS" sWebXML =
"http://xoap.weather.com/weather/local/USPA0980?cc=*&prod=xoap&par=Number
from weather.com&key=Number from weather.com" MyOutDoc =
"Current" Case "FC", "FORECAST" sWebXML =
"http://xoap.weather.com/weather/local/USPA0980?dayf=5&prod=xoap&par=Number
from weather.com&key=Number from weather.com" MyOutDoc =
"Forecast" Case Else sWebXML =
"http://xoap.weather.com/weather/local/USPA0980?cc=*&dayf=5&prod=xoap&par=Number
from weather.com&key=Number from weather.com" MyOutDoc =
"Both"End Select Const sFilePath =
"\\ServerName\MCPScr\"Worksheets(MyOutDoc).Range("a:z").Delete Set
Ie = CreateObject("InternetExplorer.Application") Ie.Navigate
sWebXML Do Until Ie.Busy = False DoEvents Loop Do Until
Ie.Busy = False DoEvents Loop InputArr =
Split(Ie.document.documentelement.outertext, vbLf)CountArr =
Split(Ie.document.documentelement.outertext, "=", ,
vbTextCompare)EqCount = UBound(CountArr)Ie.Quit: Set Ie = NothingErase
CountArrReDim OutputArr(1 To UBound(InputArr) + EqCount + 1, -2 To
7)OutputArr(1, -1) = 0OutputArr(2, -1) = 0OutRow = 3Level = 0 For I
= OutRow To UBound(InputArr) OutputArr(OutRow, -1) = 0
TempStr = Replace(Replace(InputArr(I), ">", "<", , , vbTextCompare) _
, Chr(13), "", , , vbTextCompare)
TempArr = Split(TempStr, "<", , vbTextCompare) If
Trim(TempArr(0)) = "-" Then TempStr = Left(TempArr(1),
InStr(1, TempArr(1), " ", vbTextCompare)) If TempStr = ""
Then TempStr = TempArr(1) End If
TempArr(0) = TempStr End If For J = 0 To
UBound(TempArr) If InStr(1, TempArr(J), Chr(34),
vbTextCompare) Then TempArr(J) =
Find_ReplaceInQuotes(TempArr(J), " ", "-") End If
If J = 1 And Left(TempArr(J), 1) = "/" Then
OutputArr(OutRow, 4) = TempArr(J) + "End" ElseIf InStr(1,
TempArr(J), "=", vbTextCompare) Then Flag = 1
EqTemparr = Split(TempArr(J), " ", , vbTextCompare)
For IEq = 1 To UBound(EqTemparr) TempStr =
EqTemparr(0) + " " + EqTemparr(IEq)
OutputArr(OutRow, J + 1) = Left(TempStr, InStr(1, TempStr, "=",
vbTextCompare) - 1) OutputArr(OutRow, J + 2) =
Mid(TempStr, InStr(1, TempStr, "=", vbTextCompare) + 1)
OutputArr(OutRow, J + 3) = "/" + OutputArr(OutRow, J + 1)
If IEq = 1 Then Level = Level + 1
LevelArr(Level) = Left(OutputArr(OutRow, J + 1),
InStr(1, OutputArr(OutRow, J + 1), " ", vbTextCompare) - 1)
End If If
Left(OutputArr(OutRow, 4), 1) = "/" Then
LevelArr(Level) = "" Level = Level - 1
End If If
OutputArr(OutRow, 2) <> "" Then Level = Level + 1
LevelArr(Level) = OutputArr(OutRow, 2)
ElseIf Left(OutputArr(OutRow, 4), 1) = "/" Then
LevelArr(Level) = OutputArr(OutRow, 4) End If
OutputArr(OutRow, 0) = ""
For K = 1 To Level If
LevelArr(K) <> "" And K = 1 Then
OutputArr(OutRow, 0) = LevelArr(K) ElseIf
LevelArr(K) <> "" And K > 1 Then
OutputArr(OutRow, 0) = OutputArr(OutRow, 0) + "/" + LevelArr(K)
End If Next K
OutputArr(OutRow, -1) = OutRow
OutputArr(OutRow, -2) = Level For K = 1 To OutRow - 1
If OutputArr(OutRow, 0) = OutputArr(K, 0) Then
OutputArr(OutRow, -1) = K
Exit For ' K End If Next K
If IEq < UBound(EqTemparr) Then
OutRow = OutRow + 1 Next IEq Else
If OutputArr(OutRow, J + 1) = "" Then OutputArr(OutRow, J + 1) =
TempArr(J) End If Next J If
OutputArr(OutRow, 2) <> "" Then Level = Level + 1
LevelArr(Level) = OutputArr(OutRow, 2) ElseIf
Left(OutputArr(OutRow, 4), 1) = "/" Then LevelArr(Level) =
OutputArr(OutRow, 4) End If OutputArr(OutRow, 0)
= "" For K = 1 To Level If LevelArr(K) <> "" And K =
1 Then OutputArr(OutRow, 0) = LevelArr(K)
ElseIf LevelArr(K) <> "" And K > 1 Then
OutputArr(OutRow, 0) = OutputArr(OutRow, 0) + "/" + LevelArr(K)
End If Next K If Left(OutputArr(OutRow, 4), 1)
= "/" Then LevelArr(Level) = "" Level = Level - 1
End If OutputArr(OutRow, -2) = Level
OutputArr(OutRow, -1) = OutRow For K = 1 To OutRow - 1
If OutputArr(OutRow, 0) = OutputArr(K, 0) Then
OutputArr(OutRow, -1) = K Exit For ' K End
If Next K 'Debug.Print OutputArr(OutRow, 0),
OutputArr(OutRow, -1) OutRow = OutRow + 1
Next I OutCol = 0' OutRow = 1 OutSpot = 1 Flag = 0 For I
= 3 To OutRow - 1 If I = OutputArr(I, -1) Then
For J = 1 To 3 Worksheets(MyOutDoc).Cells(I, J + 1)
= OutputArr(I, J) Next J'
Worksheets(MyOutDoc).Cells(I, J + 1) = OutputArr(I, -2) + " " +
OutputArr(I, -1) Else If OutputArr(I, -1) <
OutputArr(I - 1, -1) Then OutCol = OutCol + 1
Worksheets(MyOutDoc).Cells(OutputArr(I, -1), 3 + OutCol) = OutputArr(I,
3) End If OutRow = OutRow + 1'
Else ' flag = 1 stuff' End If' Flag = 0
Next I' Debug.Print EqCount
Worksheets(MyOutDoc).Range("A:Z").Columns.AutoFitEnd SubPublic Function
Find_ReplaceInQuotes(strText As String, strFind As String, _
strReplace As String) As StringDim Flag As IntegerDim K As Integer
Flag = 0 For K = 1 To Len(strText) If Mid(strText, K, 1) =
Chr(34) Then Flag = (Flag + 1) Mod 2 If Flag = 1 And
Mid(strText, K, 1) = strFind Then strText = Left(strText, K
- 1) + strReplace + Mid(strText, K + 1) End If Next K
Find_ReplaceInQuotes = strText End Function