FoxPro Functions
Search:

These utility functions are just designed to do a little task correctly. They really don't need to be functions, but since I use them all of the time, I thought that they would be better off in a file that I can use with "set procedure to ... additive".

  • Files
    • Delete a file
    • Delete a table
    • Quickly alter a Visual FoxPro table into a Fox2x (dBase III) table
  • Status Display
    • Say a message
    • Have a "progress meter"
    • Conditional "SET TALK OFF" and "SET TALK ON"
  • Strings
    • Random string
    • Split a string into an array
    • Convert date string into date
  • SQL Server
    • Upload table to SQL Server from FoxPro
  • Tables
    • Close a table
    • Open a table
    • Build a cursor
    • See if a tag exists
    • List all tags
    • Shrink fields to minimum required length

Files

Here are two functions that delete files. The first deletes a file if it exists. That's nice, since I no longer have to care if a temporary index file exists or not; I just try to delete it and away I go. The second will delete a table, the index file, and the memo file if they exist.

* Delete a file if it exists.  Returns 1 if file deleted, 0 if not found
function DeleteFile
lparameter m.fn
    if file(m.fn) then
        delete file (m.fn)
	return 1
    endif
    return 0
endfunc

* Deletes a table, index, and memo files if they exist
* Pass in the BASENAME only, do not pass in ".dbf" on the file name
function DeleteTable
lparameter m.fn
    DeleteFile(m.fn + ".dbf")
    DeleteFile(m.fn + ".cdx")
    DeleteFile(m.fn + ".fpt")
endfunc

If you work in a mixed environment, where some of your tools read and write Visual FoxPro tables and others only read and write the older style (fox2x / dBase III), this function will work wonderfully for you. Just don't use it on a database that has a memo field.

The function does its job by changing the first byte in the file to 0x03, which designates that the file is a dbase III table. Use of this function on Access databases, text files, or anything else will likely corrupt the data a bit.

* Converts a file from Visual FoxPro to a fox2x / dBase III table
* Do not use it if the table has a memo field!
* Returns .T. on success, .F. on error
function fox2x
lparam m.filename
    local m.hndl, m.bbyte
       
    m.hndl = fopen(m.filename, 2)
    if m.hndl <= 0
        wait "ERROR:  Could not open file " + allt(m.filename)
        return .F.
    endif
    =fseek(m.hndl, 0, 0)
    m.bbyte = fread(m.hndl, 1)
    if m.bbyte != chr(3)
        =fseek(m.hndl, 0, 0)
        =fwrite(m.hndl, chr(3))
    endif
    =fclose(m.hndl)
    return .T.
endfunc

Status

When I write long programs, I like to know what they are doing and how soon I can expect when they finish. This first function, Say(), will write a message to the console and potentially append a line to the specified logfile. That way, you can keep track of where you were even if your computer locks up.

The next three functions are for when you are iterating through a table. Before your scan or do while loop, call ProgressStart(). Then, with every iteration through your records, call ProgressMeter(). When you are done, ProgressStop(). The ProgressMeter() function will only update once a second, making sure your program doesn't slow down. It also estimates the amount of time left, so you are always "in the know."

function Say
lparameters m.Message, m.LogFile
    local m.writeStr, m.logFp
    
    m.writeStr = '[' + transform(datetime()) + ']  ' + m.Message
    
    if type('m.LogFile') == 'C'
        m.logFp = fopen(m.LogFile, 12) && Try to open the file
	if m.logFp == -1
	    m.logFp = FCreate(m.LogFile) && Try to create it
	else
	    fseek(m.logFp, 0, 2) && Go to the end of the file
	endif
	if m.logFp >= 0 && If no error, write to file
	    =fputs(m.logFp, m.writeStr)
	endif
	=fclose(m.logFp)
    endif
    
    ? m.writeStr
endfunc


function ProgressStart
    public m.ProgressLastUpdate
    public m.ProgressFirstTime
    m.ProgressLastUpdate = int(seconds())
    m.ProgressFirstTime = seconds()
    wait "Working:  " + allt(str(recno())) + "/" + allt(str(reccount())) + "  " + ;
        allt(str(100 * recno() / reccount(), 10, 1)) + "%" window nowait
endfunc


function ProgressMeter
lparam m.recno
	public m.ProgressLastUpdate
	public m.ProgressFirstTime
	local m.mesg, m.timediff
	if m.ProgressLastUpdate == int(seconds())
		return
	endif
	m.ProgressLastUpdate = int(seconds())
	m.timediff = int(((seconds() - ProgressFirstTime) / recno()) * (reccount() - recno()))
	m.mesg = ':' + padl(allt(str(mod(m.timediff, 60))), 2, '0')
	m.timediff = int(m.timediff / 60)
	if (m.timediff >= 60) then
		m.mesg = ':' + padl(allt(str(mod(m.timediff, 60))), 2, '0') + m.mesg
		m.timediff = int(m.timediff / 60)
	endif
	m.mesg = allt(str(m.timediff)) + m.mesg
	if type('m.recno') != 'N'
		m.recno = recno()
	endif
	m.mesg = "Working:  " + allt(str(m.recno)) + "/" + allt(str(reccount())) + "  " + ;
        allt(str(100 * m.recno / reccount(), 10, 1)) + "%  ETA: " + m.mesg
        
    wait m.mesg window nowait
endfunc


function ProgressStop
	wait clear
endfunc

I find it annoying to have to "SET TALK ON", "SET TALK OFF", "SET TALK ON", etc. I also find it irritating that I need to sometimes check the status of TALK, then possibly turn it off and process and turn it back on. These two functions will help you out. Do not call Hush() again until after you call UnHush() – the functions won't work well that way.

* Equivalent to a "SET TALK OFF"
function Hush
    public m.UnHushTalkOn
	
    if sys(103) = "ON"
        set talk off
        m.UnHushTalkOn = .T.
    endif
endfunc


* Checks if TALK used to be ON.  If so, turns it back on
function UnHush
    public m.UnHushTalkOn

    if type('m.UnHushTalkOn') = 'L'
        if m.UnHushTalkOn == .T.
            m.UnHushTalkOn = .F.
            set talk on
        endif
        release m.UnHushTalkOn
    endif
endfunc

Strings

Ever need to generate a random ID? Try this code out.

* Initialize the random number generator
rand(-1)

* Print a random string.
? RandomString(10)  && 10 letters long, 0-9 and A-Z
? RandomString(32, '0123456789ABCDEF')  && 32 long, hexadecimal characters
? RandomString(8, '01') && Looks like a byte in binary

function RandomString
parameters m.n, m.letters
	m.q = ""
	if type('m.letters') != 'C' or len(m.letters) == 0
		m.letters = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
	endif
	do while len(m.q) < m.n
		m.q = m.q + substr(m.letters, int(rand() * len(m.letters)) + 1, 1)
	enddo
	return m.q
endfunc

I felt saddened that FoxPro didn't have a built-in split() or explode() function to turn a string into an array. Since I wrote this function, I am sad no longer!

* First, declare an array
dimension m.arr(1)

* Now split a string on spaces
split(' ', 'Break this up into individual words.', @m.arr)

function Split
lparam m.delim, m.str, m.arr
    local m.i, m.c, m.pos

    * Count the delimeters in the string to make the array the right size
    m.c = 1
    do while at(m.delim, m.str, m.c) != 0
        m.c = m.c + 1
    enddo

    dimension m.arr(m.c)

    for m.i = 1 to m.c
        m.pos = at(m.delim, m.str)
        if m.pos == 0
            m.pos = len(m.str) + 1
        endif
        m.arr(m.i) = substr(m.str, 1, m.pos - 1)
        m.str = substr(m.str, m.pos + len(m.delim), len(m.str))
    next
	
    return m.arr
endfunc

If you looked at dtos(), you will realize that there is no opposite! There is no stod() and from what I can tell, there is no easy transform() to convert it back into a date. The function below is the opposite of dtos().

* The opposite of dtos(m.date) or dtoc(m.date, 1)
function stod
lparam m.c
    local m.d, m.m, m.y

    m.c = allt(m.c)
    if type('m.c') != 'C' or len(m.c) != 8
        return {//}
    endif

    m.d = val(right(m.c, 2))
    m.m = val(substr(m.c, 5, 2))
    m.y = val(left(m.c, 4))
    if m.d < 1 or m.m < 1 or m.y < 100
        return {//}
    endif

    return date(m.y, m.m, m.d)
endfunc

SQL Server

Upload Fox to SQL Server - Creates a table and copies the data to SQL Server via an ODBC connection. It is slightly slower than BCP, but it massages the data better, especially if your table is giving you problems.

upload_fox_to_sql.prg

Tables

Sometimes, I write code that could close a table in one instance and will keep it open in another. I wrote a function to close a table by name if it is open. At other times, I will want to open a table with a specific name when I already have one open. In this instance, let's close the old one and open the new one.

* Closes a table if it is open
function CloseTable
lparameter m.Name
    if used(m.Name) then
       use in (m.Name)
    endif
endfunc

* Opens a table (potentially closing one with the same name)
* Opens exclusively if you like
function OpenTable
lparameters m.fn, m.name, m.ex
    CloseTable(m.name)
    if (m.ex) then
        use (m.fn) in 0 alias (m.name) excl
    else
        use (m.fn) in 0 alias (m.name) shar
    endif
endfunc

One thing you can do if your data set is really large is to break it into sections. Then, you just run your "select * from TABLE into cursor NAME" repeatedly and append the results into a writeable cursor. This is also great if you need to change the default read-only cursor into a read-write cursor.

scan for ...
    * The "NOFILTER" is mandatory for build_cursor()
    select * from TABLE where ... into cursor temp nofilter
    build_cursor('everything', 'temp')
    use in temp
endscan
* Now you have all of the records in the cursor "everything"

* Turn a read-only cursor into a read-write cursor
select * from TABLE into cursor ReadOnly nofilter
build_cursor('ReadWrite', 'ReadOnly')

* Create a writeable cursor or append to a cursor
function build_cursor
lparameters m.dest, m.src
	local m.orig_alias, m.build_tmp
	
	m.build_tmp = sys(2015)
	m.orig_alias = alias()
	
	if ! used(m.dest)
		select * from alias(m.src) where .F. into cursor (m.build_tmp) nofilter
		use dbf(m.build_tmp) again in 0 alias (m.dest) excl
		use in (m.build_tmp)
	endif
	
	select (m.dest)
	append from dbf(m.src)
	
	if ! empty(m.orig_alias)
		select (m.orig_alias)
	endif
endfunc

Can't remember if you added that tag to the table? Need to reindex table "B" with the same indexes as table "A"?

use SOME_TABLE
if ! TagExists('itemNo')
    index on itemno tag itemno
endif

* Copy "index on ..." statements to clipboard
use THE_TABLE
ListIndexes()

* Returns .T. if the named tag exists in the currently open table
function TagExists
lparam m.nam
    local m.i, m.tnam
    
    m.nam = allt(upper(m.nam))
    m.i = 1
    m.tnam = tag(m.i)
    do while len(m.tnam) > 0
        if (m.nam == m.tnam and m.tnam == m.nam)
            return .T.
        endif
        m.i = m.i + 1
        m.tnam = tag(m.i)
    enddo
    return .F.
endfunc

* Displays a list of "index on ..." statements that were used
* to build all of the indexes on the current table.  Also copies
* them to the clipboard so you can paste them into whatever you like.
function ListIndexes
    m.taglist = ""
    for i = 1 to tagcount()
        m.singletag = "index on " + sys(14, i) + " tag " + tag(i)
        m.taglist = m.taglist + m.singletag + chr(13) + chr(10)
    next
    ? m.taglist
    _CLIPTEXT = m.taglist
    ? "Index dump done - copied to clipboard"
endfunc

If you have a table with character fields that is taking up a lot of space, you can shrink the character fields to be just the size of the longest field with shrink_fields.prg. It only works with character fields, but can easily be extended to work with other types, such as numeric fields.

The chemical formula for nicotine is C10H14N2. Tyler Akins <>
Contact Me - Legal Info