Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations Rhinorhino on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Export (groups of) DBFs to Excel Workbook QUICKLY

COM and Automation

Export (groups of) DBFs to Excel Workbook QUICKLY

by  baltman  Posted    (Edited  )
&&&&&&&
&& Invoke this procedure by saving as a PRG file called "WBEXPORT"
&& In the command window type "SET PROCEDURE TO WBEXPORT"
&& And invoke the function by typing "tables2htm('TblName.dbf')"
&& or "tables2htm('Tbl*.dbf')" to export all DBFs starting with 'Tbl'
&&
&& This procedure scans the directory in which it resides for
&& the passsed value e.g. 'Tbl*.dbf' and exports all tables
&& meeting the criteria together into one HTM Excel workbook
&&
&& Works only with Excel 2000 and higher installed.
&&
&& Exports MEMO FIELDS AT THE SAME TIME AS OTHER FIELDS.
&&
&& Coded by Brian Altman
&&
&& Freeware with reservation to Copyrights
&& Last modified 1/26/2003
&&&&&&

[white]FoxPro programming rocks![/white]

Procedure tables2htm
Lparameters targetskeleton
Set Talk Off

cdir=Sys(5)+Curdir()+"tables2htm_files\"

If Directory(cdir)=.F.
Mkdir &cdir
Endif

&&224 stops too many sheets from being created
For workbookcount= 1 To Min(224,Adir(temparray1,targetskeleton))

targettable=temparray1(workbookcount,1)
outputfile=Left(temparray1(workbookcount,1),Len(temparray1(workbookcount,1))-4)+".htm"

HTMLFile=Fcreate(cdir+outputfile)
= Fput(HTMLFile, "<HTML>")
= Fput(HTMLFile, "<HEAD>")
= Fput(HTMLFile, "<META HTTP-EQUIV='Content-Type' CONTENT='text/html; charset=windows-1252'>")
= Fput(HTMLFile, "<META NAME='Generator' CONTENT='VFP'>")
= Fput(HTMLFile, "<TITLE>a</TITLE>")
= Fput(HTMLFile, "</HEAD>")
= Fput(HTMLFile, "<BODY>")
= Fput(HTMLFile, "<TABLE CELLSPACING=0 BORDER=0 CELLPADDING=3 WIDTH=264>")
= Fput(HTMLFile, "<TR><TD WIDTH='100%' VALIGN='TOP'>")
Use &targettable

For x = 1 To Afields(temparray2)
= Fput(HTMLFile,"<P>"+temparray2(x,1)+"</TD>")
= Fput(HTMLFile, "<TD>")
Endfor
= Fput(HTMLFile, "</TR>")
= Fput(HTMLFile, "<TR><TD>")

Scan
For x = 1 To Afields(temparray2)
cfield=temparray2(x,1)

Do Case
Case Type(cfield) $ "CM" && character,Memo fields
= Fput(HTMLFile,"<P>"+Iif(Alltrim(&cfield)="0","'","")+Alltrim(&cfield)+"</TD>")

Case Type(cfield) $ "YN" && numeric,currency fields
= Fput(HTMLFile,"<P>"+Alltrim(Str(&cfield,20,18))+"</TD>")

Case Type(cfield)="D" && date field
= Fput(HTMLFile,"<P>"+Substr(Dtos(&cfield),5,2)+"/"+Right(Dtos(&cfield),2)+"/"+Left(Dtos(&cfield),4)+"</TD>")

Case Type(cfield)="T"&& datetime fields
= Fput(HTMLFile,"<P>"+Ttoc(&cfield)+"</TD>")

Case Type(cfield)="L"&& logical fields
= Fput(HTMLFile,"<P>"+Iif(&cfield=.T.,"T","F")+"</TD>")

Otherwise && General fields
= Fput(HTMLFile,IIF(RECNO()=1,"<P>GENERAL FIELD</TD>",""))

Endcase
= Fput(HTMLFile, "<TD>")

Endfor
= Fput(HTMLFile, "</TR>")
= Fput(HTMLFile, "<TR><TD>")
Endscan

= Fput(HTMLFile, "</TABLE>")
= Fput(HTMLFile, "</BODY>")
= Fput(HTMLFile, "</HTML>")

=Fclose(HTMLFile)
Endfor
&&&&&&&END OF DBF TO HTML

&&&&&&& Create "filelist.xml"
XMLFile=Fcreate(cdir+"filelist.xml")
= Fput(XMLFile, "<xml xmlns:o='urn:schemas-microsoft-com:office:office'>")
= Fput(XMLFile, "<o:MainFile HRef='../tables2htm.htm'/>")

For workbookcount= 1 To Adir(temparray,targetskeleton)
inputfile=temparray(workbookcount,1)
outputfile=Left(temparray(workbookcount,1),Len(temparray(workbookcount,1))-4)+".htm"
= Fput(XMLFile, "<o:File HRef='"+outputfile+"'/>")
Endfor

= Fput(XMLFile, "<o:File HRef='filelist.xml'/>")
= Fput(XMLFile, "</xml>")
=Fclose(XMLFile)

&&&&&&& Create "tables2htm.htm" for Excel to open
tables2htmFile=Fcreate(Sys(5)+Curdir()+"tables2htm.htm")
= Fput(tables2htmFile, "<html xmlns:o="+Chr(34)+"urn:schemas-microsoft-com:office:office"+Chr(34))
= Fput(tables2htmFile, "xmlns:x="+Chr(34)+"urn:schemas-microsoft-com:office:excel"+Chr(34))
= Fput(tables2htmFile, "<head>")
= Fput(tables2htmFile, "<meta name="+Chr(34)+"Excel Workbook Frameset"+Chr(34)+">")
= Fput(tables2htmFile, "<meta http-equiv=Content-Type content="+Chr(34)+"text/html; charset=windows-1252"+Chr(34)+">")
= Fput(tables2htmFile, "<meta name=ProgId content=Excel.Sheet>")
= Fput(tables2htmFile, "<link rel=File-List href="+Chr(34)+"./tables2htm_files/filelist.xml"+Chr(34)+">")
= Fput(tables2htmFile, "<![endif]><!--[if gte mso 9]><xml>")
= Fput(tables2htmFile, "<x:ExcelWorkbook>")
= Fput(tables2htmFile, "<x:ExcelWorksheets>")

For workbookcount= 1 To Adir(temparray,targetskeleton)
tabname=Left(temparray(workbookcount,1),Len(temparray(workbookcount,1))-4)
= Fput(tables2htmFile, "<x:ExcelWorksheet>")
= Fput(tables2htmFile, "<x:Name>"+tabname+"</x:Name>")
= Fput(tables2htmFile, "<x:WorksheetSource HRef="+Chr(34)+"./tables2htm_files/"+tabname+".htm"+Chr(34)+"/>")
= Fput(tables2htmFile, "</x:ExcelWorksheet>")
Endfor

= Fput(tables2htmFile, "</x:ExcelWorkbook>")
= Fput(tables2htmFile, "</xml><![endif]-->")
= Fput(tables2htmFile, "</head>")
= Fput(tables2htmFile, "<noframes>")
= Fput(tables2htmFile, "<body>")
= Fput(tables2htmFile, "<p>This Export Requires Excel 2000 or higher.</p>")
= Fput(tables2htmFile, "</body>")
= Fput(tables2htmFile, "</noframes>")
= Fput(tables2htmFile, "</frameset>")
= Fput(tables2htmFile, "</html>")
=Fclose(tables2htmFile)

&&open with excel
Wait Window Nowait "Exporting Tables to Excel..."

lcOldError = On("ERROR")
On Error loExcel = .Null.
loExcel = Getobject(,"Excel.Application")
On Error &lcOldError

If Isnull(loExcel)
loExcel = Createobject("Excel.Application")
Endif
On Error

With loExcel
.WorkBooks.Open(Sys(5)+Curdir()+"tables2htm.htm")
For workbookcount= 1 To Min(224,Adir(temparray1,targetskeleton))
.Sheets(Left(temparray1(workbookcount,1),Len(temparray1(workbookcount,1))-4)).select
.ActiveWindow.DisplayGridlines = .t.
.ActiveWindow.Zoom = 75
Endfor
.Sheets(Left(temparray1(1,1),Len(temparray1(1,1))-4)).select
.Visible=.T.
Endwith
Set Talk On
Endproc
Register to rate this FAQ  : BAD 1 2 3 4 5 6 7 8 9 10 GOOD
Please Note: 1 is Bad, 10 is Good :-)

Part and Inventory Search

Back
Top