Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
import XMLs
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/sh...85& 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.AutoFitE nd 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
import XML data...Is there a size limit on the import? | Excel Discussion (Misc queries) | |||
How to Start Excel in Text Import Wizard for data import | Setting up and Configuration of Excel | |||
import XMLs | Excel Programming | |||
XMLs | Excel Programming | |||
I can import Access Tables. But, I can't import Access queries | Excel Programming |