XML Recordset and Excel Named Ranges

The attached script will accept an Excel Workbook as input and create an XML recordset with the defined names and ranges in every worksheet.

Beyond the specific task, there are comments and code concerning 'fabricated recordsets' you can adapt to other scripts.

Fabricated recordsets are the closest WB can get to emulating C-Structures, and I prefer them to large arrays or lists. They are 'semi-recursive', i.e. a Recordset can be contained in a Recordset... and they are typed. I included a UDF which illustrates how to make a FR updateable to an existing database Table with the same field layout.

There is 2004B+ stuff [error handling, use of dirscript(), ForEach ] which you can re-code for earlier versions as the XML and Excel portions should work.

stan

; Winbatch 2004E -
; Gather and Persist Named Ranges in a Workbook to XML
; Creates 'fabricated' xml with optional method to make it updateable
; to an existing Table
;
; Stan Littlefield - August 14, 2004
;///////////////////////////////////////////////////////////////////
gosub udfs
IntControl(73,1,0,0,0)
path = dirscript()
types="Excel Files|*.xls|"
cXLS=AskFileName("SelectFile", path, types, "", 1)
If ! FileExist(cXLS) Then Exit
BoxOpen(cXLS,"Please Wait...Gathering Range Names")

;////////////////////////////////////////////////////////////////
; Brute Force creation of XML recordset schema
; if you are not partial to XML Recordsets
; then put in your own code to place the Range information into
; an array, a list, a LAFF DB... whatever
cXML = StrCat(path,FileRoot(cXLS),"_Names.xml")
If FileExist(cXML) Then FileDelete(cXML)
List = "Name|RefersTo"
Sizes = "50|120"
Types = "200|200"  ; NOTE: try 129 instead of 200 to see the difference
                   ; between an adChar and an adVarChar, both of which represent
                   ; as 'string' in XML
Base = "Ranges"
nFields = ItemCount( List, "|" )
RS = CreateObject("ADODB.Recordset")
;NOTE: The fields collection is not 0-based
For i = 1 To nFields
   fname = ItemExtract( i, List, "|" )
   fsize = Int(ItemExtract( i, Sizes, "|" ))
   ftype = Int(ItemExtract( i, Types, "|" ))
   If StrIndex("|129|200|202|203|",StrCat("|",ftype,"|"),0,@FWDSCAN)
      RS.Fields.append(:: Name="%fname%",Type=ftype,DefinedSize=fsize)
   Else
      RS.Fields.append(:: Name="%fname%",Type=ftype)
   Endif
   ;NOTE: the append() method also allows field characteristics such as
   ;      whether the field can accept NULLS, is required etc....
Next
RS.Open()

;optional step - make XML 'batchupdateable' to Database Table
;Table would be called Ranges
;uncomment to execute, compare the XNL schema section with a version
;that did not use the UDF
;mupd()

RS.Fields("Name").Properties("OPTIMIZE").Value=@TRUE
;/////////////////////////////////////////////////////////////////

:loadfile
oXL = CreateObject("Excel.Application")
oXL.Visible          = @FALSE  ; change this to @TRUE while testing
oXL.ScreenUpdating   = @TRUE  ; if running hidden, change this to @FALSE 
oXL.UserControl      = @TRUE
oXL.DisplayAlerts    = @FALSE
oXL.WorkBooks.Open(cXLS)

ForEach n In oXL.ActiveWorkbook.Names
   cVar = n.Name
   cVar1 = n.RefersTo
   If RS.eof  ; although only executed once, this piece of code
              ; avoids the error of RS.MoveFirst() on an Empty Recordset
      anew()
      Continue
   Endif
   x = StrCat("Name='",cVar,"'")
   RS.MoveFirst()
   RS.Find(x)
   If ! RS.eof() Then anew() 
Next
	
RS.Save(cXML,1)
RS.Close()
RS=0

:end
oWS= 0
oXL.Quit()
oXL=0
BoxText( StrCat( cXML," Created..") )
TimeDelay(2)
BoxShut()
Exit

:WBERRORHANDLER
IntControl(73,1,0,0,0)
If ( VarType(oXL) &1536)==1536
   If oXL.WorkBooks.Count > 0  Then oXL.Quit()
   oXL=0
Endif
RS=0
;put extra code here
ErrorProcessing(1,1,1)
Exit

:udfs

#DefineSubroutine mupd()
IntControl(73,1,0,0,0)

; making a fabricated Recordset updateable (quickly)
; 1. Recordset is immediately persisted - which saves schema only
; 2. Each 'field' name is given additional attributes so that the
;    recordset can be opened as 'keyset', 'batchupdateable' [1,4]
; 3. Modified schema is written back and file is re-opened as Recordset
;
; In this example a table called 'Ranges' was used. This means that if
; you had an existing Access, SQL Server, or any ADO/OLEDB table of the 
; same name and same structure that supported UpdateBatch() then any rows
; collected in this XML file could be inserted/updated to the master table
; with a single command, rather than a loop with Inserts
;
; the subroutine uses FileGet()/FilePut() as the data is Ascii
; for more complicated parsing use the MsXML components and the XMLDom. 

RS.Save(cXML,1)
RS.Close()
cFile = FileGet(cXML) ; at this point you have a schema
                      ; I normally encode important XML schemas into
                      ; a 'master' XML recordset as memo fields with
                      ; several text and numeric descriptor fields
                      ; this way I can easily mix and match
                      ; fieldnames, fieldtypes and defined sizes
For i = 1 To nFields
   fname = ItemExtract( i, List, "|" )
   srch = "name='%fname%'"
   repl = StrCat(srch," rs:basetable='%Base%' rs:basecolumn='%fname%' ")
   cFile = StrReplace(cFile,srch,repl)
Next
FilePut(cXML,cFile)
RS.Open(cXML,"Provider=MSPersist;",1,4,256)
Return(1)

:WBERRORHANDLER
RS=0
IntControl(73,1,0,0,0)
ErrorProcessing(1,1,1)
Exit
#EndSubroutine

#DefineSubroutine anew()  
RS.Addnew()
RS.Fields("Name").Value = cVar
RS.Fields("RefersTo").Value = cVar1
RS.Update()
Return(1)

:WBERRORHANDLER
IntControl(73,1,0,0,0)
ErrorProcessing(1,1,1)
Return(0)
#EndSubroutine

#DefineSubroutine ErrorProcessing(deleteIni,showerr,logfile)  
WbError = LastError()
WbTextcode = WbError
If WbError==1668||WbError==2669||WbError==3670
   ; 1668 ; "Minor user-defined error"
   ; 2669 ; "Moderate user-defined error"
   ; 3670 ; "Severe user-defined error"
   WbError = ItemExtract(1,IntControl(34,-1,0,0,0),":")
   WbTextcode = -1
EndIf
WbErrorString = IntControl(34,WbTextcode,0,0,0)
WbErrorDateTime = TimeYmdHms()
WbErrorFile = StrCat(DirWindows(0),"WWWBATCH.INI")
If deleteIni
   FileDelete(WbErrorFile)
   IniWritePvt(WbErrorDateTime,"CurrentScript",WbErrorHandlerFile      ,WbErrorFile)
   IniWritePvt(WbErrorDateTime,"ErrorValue"   ,WbError                 ,WbErrorFile)
   IniWritePvt(WbErrorDateTime,"ErrorString"  ,WbErrorString           ,WbErrorFile)
   IniWritePvt(WbErrorDateTime,"ScriptLine"   ,WbErrorHandlerLine      ,WbErrorFile)
   IniWritePvt(WbErrorDateTime,"ScriptOffset" ,WbErrorHandlerOffset    ,WbErrorFile)
   IniWritePvt(WbErrorDateTime,"VarAssignment",WbErrorHandlerAssignment,WbErrorFile)
   IniWritePvt(WbErrorDateTime,"VarInSegment" ,WbErrorInSegment,WbErrorFile)
   IniWritePvt("","","",WbErrorFile)
Endif  
WbErrorMsgText = StrCat(WbErrorDateTime,@CRLF)
WbErrorMsgText = StrCat(WbErrorMsgText,"Current Script: ",WbErrorHandlerFile,@CRLF)
WbErrorMsgText = StrCat(WbErrorMsgText,"Error# [",WbError,"]",@CRLF)
WbErrorMsgText = StrCat(WbErrorMsgText,"Error Text: ",wberrortextstring,@CRLF)
WbErrorMsgText = StrCat(WbErrorMsgText,"[Extended Information] ",wberroradditionalinfo,@CRLF,@CRLF)
WbErrorMsgText = StrCat(WbErrorMsgText,"On Line:",@CRLF,WbErrorHandlerLine,@CRLF)
WbErrorMsgText = StrCat(WbErrorMsgText,"Offset: ",WbErrorHandlerOffset,@CRLF)
If (WbErrorHandlerAssignment>"") Then %WbErrorHandlerAssignment% = "UNKNOWN"
WbErrorMsgText = StrCat(WbErrorMsgText,"Assignment/Variable: ",WbErrorHandlerAssignment,@CRLF)
If (WbErrorInSegment>"") Then WbErrorMsgText = StrCat(WbErrorMsgText,"In UDF/UDS: ",WbErrorInSegment,@CRLF)
If logfile
   cSep = StrCat(StrFill("=",50),@CRLF)
   cLogFile = StrCat(dirscript(),"log.err")
   If ! FileExist(cLogFile) Then FilePut(cLogFile,StrCat("Error Log",@CRLF,cSep))
   FilePut(cLogFile,StrCat(FileGet(cLogFile),WbErrorMsgText,cSep))
Endif
If showerr Then Message("wbErrorHandler",WbErrorMsgText)
Return(1)
#EndSubroutine

Return
;//////////////////////////////////////////////////////////////////////////////

Article ID:   W16649

File Created: 2005:02:18:12:21:46

Last Updated: 2005:02:18:12:21:46

Database Search

TechHome

XML Recordset and Excel Named Ranges