*=========================================================================== * Procedure......: DbfFormArray * Purpose........: Creates DBF from an (data) array * Parameters.....: @ArrayName, with optional @FieldNames, DbfName to create, * Append data from array, close table before exiting * Return Type....: Character, Created table path and name * Author.........: Arto Toikka *=========================================================================== PROCEDURE DbfFromArray LPARAMETERS taArray, taFieldNames, tcDbfName, tlNoAppend, tlCloseTable *!* This function creates free table from given array *!* and appends array content to that table *!* DbfFormArray is used as: *!* DbfFormArray(@ArrayName [,@taFieldNames] [,tlNoAppend] [,tlCloseTable]) *!* when ArrayName is actual array OR *!* DbfFormArray(ArrayName [,@taFieldNames] [,tlNoAppend] [,tlCloseTable]) *!* when ArrayName is variable containing name of the array. *!* f.ex. *!* *!* APRINTER(aTest) *!* DbfFromArray(@aTest) *!* *!* OR *!* *!* APRINTER(aTest) *!* cTest = "aTest" *!* DbfFromArray(cTest) *!* *!* Creates a free table with two field *!* Appends aTest (APRINTER()) info to table *!* and Returns created table's path and name *!* *!* taFieldNames Field names to use instead of Field1, 2, 3... *!* tcDbfName Table path and name to create, otherwise table name is *!* created with the function sys(2015) *!* tlNoAppend .T. Array content is not appended to the created table *!* (Default .F.) *!* tlCloseTable .T. table is closed before returning it's name *!* (Default .F.) *!* *!* Tips: *!* 1) Sort Array before calling DbfFormArray *!* or create indexes after DbfFromArray *!* 2) If temporary table, remember to erase created table after usage! EXTERNAL ARRAY taFieldNames EXTERNAL ARRAY taArray LOCAL ; lnFstParamType, ; lnFields, ; laStructure[1,16], ; lni, ; lnj, ; lnSelect, ; lcExclusive, ; lcMyTEMPDir, ; lcTmpDbf, ; lcRetVal IF TYPE('taArray[1]') = 'U' IF TYPE('&taArray[1]') = 'U' IF UPPER(LEFT(taArray,5)) = "THIS." OR ; UPPER(LEFT(taArray,9)) = "THISFORM." MESSAGEBOX('Reference to This. or Thisform. not allowed with an array',16,'Error',3000) RETURN '' ELSE MESSAGEBOX('Not an Array',16,'Error',3000) RETURN '' ENDIF ELSE m.lnFstParamType = 0 && Variable containing arrays name ENDIF ELSE m.lnFstParamType = 1 && Array ENDIF m.lnSelect = SELECT() m.lcExclusive = SET("EXCLUSIVE") IF m.lnFstParamType = 1 && Array m.lnRows = ALEN(m.taArray,1) m.lnCols = ALEN(m.taArray,2) ELSE m.lnRows = ALEN(&taArray,1) m.lnCols = ALEN(&taArray,2) ENdif IF m.lnCols = 0 m.lnCols = 1 Endif *--------------------- *!* Structure of fields FOR m.lni = 1 TO m.lnCols && Fields DIMENSION laStructure[m.lni,16] m.laStructure[m.lni,1] = ; IIF(TYPE('m.taFieldNames[m.lni]') = 'C',; LEFT(ALLTRIM(m.taFieldNames[m.lni]),10),'Field'+TRANSFORM(m.lni)) IF m.lnFstParamType=1 m.laStructure[m.lni,2] = TYPE('taArray[1,m.lni]') ELSE m.laStructure[m.lni,2] = TYPE('&taArray[1,m.lni]') ENDIF *** IIF works if & inside **** m.laStructure[m.lni,2] = IIF(m.lnFstParamType=1, ; **** TYPE('taArray[m.lni,1]'),TYPE('&taArray[m.lni,1]')) m.laStructure[m.lni,3] = 0 m.laStructure[m.lni,4] = 0 m.laStructure[m.lni,5] = .F. m.laStructure[m.lni,6] = .F. m.laStructure[m.lni,7] = '' m.laStructure[m.lni,8] = '' m.laStructure[m.lni,9] = '' m.laStructure[m.lni,10] = '' m.laStructure[m.lni,11] = '' m.laStructure[m.lni,12] = '' m.laStructure[m.lni,13] = '' m.laStructure[m.lni,14] = '' m.laStructure[m.lni,15] = '' m.laStructure[m.lni,16] = '' *--------------------- *!* Length of fields DO CASE CASE m.laStructure[m.lni,2] == 'Y' m.laStructure[m.lni,3] = 8 CASE m.laStructure[m.lni,2] == 'D' OR m.laStructure[m.lni,2] == 'T' m.laStructure[m.lni,3] = 8 CASE m.laStructure[m.lni,2] == 'L' m.laStructure[m.lni,3] = 1 CASE m.laStructure[m.lni,2] == 'C' FOR m.lnj = 1 TO m.lnRows *** IIF desn't work if & inside AND m.lnFstParamType = 1 because &taArray is checked too and it isn't an array ****m.laStructure[m.lni,3] = ; **** MAX(m.laStructure[m.lni,3],LEN(IIF(m.lnFstParamType=1, ; **** m.taArray[m.lnj,m.lni],&taArray[m.lnj,m.lni]))) IF m.lnFstParamType=1 m.laStructure[m.lni,3] = MAX(m.laStructure[m.lni,3],LEN(TRANSFORM(m.taArray[m.lnj,m.lni]))) ELSE m.laStructure[m.lni,3] = MAX(m.laStructure[m.lni,3],LEN(TRANSFORM(&taArray[m.lnj,m.lni]))) ENDIF NEXT m.laStructure[m.lni,3] = ; IIF(m.laStructure[m.lni,3]>254,254,m.laStructure[m.lni,3]) CASE m.laStructure[m.lni,2] == 'N' FOR m.lnj = 1 TO m.lnRows *** IIF desn't work if & inside AND m.lnFstParamType = 1 because &taArray is checked too and it isn't an array ****m.laStructure[m.lni,3] = ; **** MAX(m.laStructure[m.lni,3],; **** LEN(TRANSFORM(INT(IIF(m.lnFstParamType=1, ; **** m.taArray[m.lnj,m.lni],&taArray[m.lnj,m.lni]))))) IF m.lnFstParamType=1 m.laStructure[m.lni,3] = MAX(m.laStructure[m.lni,3],LEN(TRANSFORM(INT(m.taArray[m.lnj,m.lni])))) ELSE m.laStructure[m.lni,3] = MAX(m.laStructure[m.lni,3],LEN(TRANSFORM(INT(&taArray[m.lnj,m.lni])))) ENDIF *** IIF desn't work if & inside AND m.lnFstParamType = 1 because &taArray is checked too and it isn't an array ****m.laStructure[m.lni,4] = ; **** MAX(m.laStructure[m.lni,4],; **** IIF((AT(SET('POINT'),TRANSFORM(IIF(m.lnFstParamType=1, ; **** m.taArray[m.lnj,m.lni],&taArray[m.lnj,m.lni]))))=0,0,; **** LEN(TRANSFORM((IIF(m.lnFstParamType=1, ; **** m.taArray[m.lnj,m.lni],&taArray[m.lnj,m.lni])-; **** INT(IIF(m.lnFstParamType=1, ; **** m.taArray[m.lnj,m.lni],&taArray[m.lnj,m.lni])))))-2)) IF m.lnFstParamType=1 m.laStructure[m.lni,4] = MAX(m.laStructure[m.lni,4],; IIF(AT(SET('POINT'),TRANSFORM(m.taArray[m.lnj,m.lni]))=0,0,; LEN(TRANSFORM(m.taArray[m.lnj,m.lni])-INT(m.taArray[m.lnj,m.lni]))-2)) ELSE m.laStructure[m.lni,4] = MAX(m.laStructure[m.lni,4],; IIF(AT(SET('POINT'),TRANSFORM(&taArray[m.lnj,m.lni]))=0,0,; LEN(TRANSFORM(&taArray[m.lnj,m.lni])-INT(&taArray[m.lnj,m.lni]))-2)) ENDIF NEXT ENDCASE *--------------------- NEXT *--------------------- *-------------------- *!* Create temporary table name if needed IF TYPE('m.tcDbfName') # 'C' OR ; EMPTY(m.tcDbfName) m.lcMyTEMPDir = ; IIF(Len(Getenv('TEMP'))=0,Sys(5)+Curdir()+; IIF(!Right(Curdir(),1)=='\','\',''),; Getenv('TEMP')+Iif(!Right(Getenv('TEMP'),1)=='\','\','')) m.tcDbfName = m.lcMyTEMPDir + Sys(2015) Do While File(m.tcDbfName+'.DBF') && Or File(m.lcTmpDbf+".FPT") m.tcDbfName = m.lcMyTEMPDir + Sys(2015) ENDDO Endif *--------------------- *--------------------- *!* Create Table SELECT 0 * IF !m.tlCloseTable SET EXCLUSIVE ON && Faster to use Exclusive ON * ENDIF CREATE TABLE (m.tcDbfName) FREE FROM ARRAY m.laStructure m.lcRetVal = DBF() *!* If create table doesn'tt success *!* next takes care that no other *!* dbf is used because that dbf is later on *!* erased IF AT(UPPER(m.tcDbfName),UPPER(m.lcRetVal)) > 0 *--------------------- *--------------------- *!* Append Data IF !m.tlNoAppend IF m.lnFstParamType = 1 && Array APPEND FROM ARRAY m.taArray ELSE APPEND FROM ARRAY &taArray Endif ENDIF *--------------------- *--------------------- *!* Close table IF m.tlCloseTable USE SELECT (m.lnSelect) ENDIF ELse SELECT (m.lnSelect) m.lcRetVal = "" ENdif * ELSE SET EXCLUSIVE &lcExclusive * ENDIF *--------------------- RETURN m.lcRetVal && m.lcTmpDbf + '.DBF' *=========================================================================== * End: DbfFromArray *===========================================================================Hope this helps you