PackMeta.prg

****************************************************************************
*
* PROGRAM NAME: PackMeta.prg
*
* AUTHOR: Richard A. Schummer, August 1996
*
* COPYRIGHT © 1996 All Rights Reserved.
* Richard A. Schummer
* 42759 Flis Dr.
* Sterling Heights, MI 48314-2850
* RSchummer@CompuServe.com
*
* Free for the use by all FoxPro developers around the world!
*
* SYSTEM: Common Utilities
*
* PROGRAM DESCRIPTION:
* This program packs all the Visual Class Libraries and Forms
* that are contained in a selected project file. This PACK
* removes all the "memo bloat" that naturally occurs during
* a development cycle.
*
* Error not handled includes File in Use (usually caused by
* a Form running or instantiation of a Visual Class).
*
* CALLED BY:
* DO PackMeta.prg
*
* SAMPLE CALL:
* DO PackMeta.prg
*
* INPUT PARAMETERS:
* None
*
* OUTPUT PARAMETERS:
* None
*
* DATABASES ACCESSED:
* None
*
* GLOBAL VARIABLES REQUIRED:
* None
*
* GLOBAL PROCEDURES REQUIRED:
* None
*
* DEVELOPMENT STANDARDS:
* Version 3.0 compliant
*
* TEST INFORMATION:
* None
*
* SPECIAL REQUIREMENTS/DEVICES:
* None
*
* FUTURE ENHANCEMENTS:
* 1) Possibly include Reports and Menus as well. These are not as big
* a problem for the developer so they were not included in this
* version
*
* LANGUAGE/VERSION:
* Visual FoxPro 3.0b or higher
*
****************************************************************************
*
* C H A N G E L O G
*
* Date SE Version Description
* ---------- ---------------------- ------- -----------------------------
* 08/11/1996 Richard A. Schummer 1.0 Created program
* --------------------------------------------------------------------------
* 12/08/1996 Richard A. Schummer 1.0 Added documentation to meet
* development standards
* --------------------------------------------------------------------------
* 03/08/1997 Richard A. Schummer 1.1 Handle error of File Open,
* Count of skipped files, chged
* some var names to conform to
* development standards.
* --------------------------------------------------------------------------
*
****************************************************************************


****************************************************************************
*--- [mustapha] added here my personal trick
*--- close all tables,project and libraries before packing
Close All
Clear All
Set Classlib To
****************************************************************************

#INCLUDE FoxPro.h && constants for messagebox

#Define ccMESSAGE_CAPTION "Pack Metadata Process Message"
#Define ccTOOL_VERSION "1.1.0"

Private plFileOpened As Boolean && Indicates metadata open, changed to .F. in error routine
Local lnRecordsProcessed As Integer && Number of metadata files PACKed
Local lnRecordsSkipped As Integer && Number of metadata files not PACKed
Local lcSelectedCursor As String && Previously selected cursor
Local lcProjectFile As String && Project file selected by user
Local lcOldError As String && Save error routine

Local lnMsgRet As Integer, lnSubDir As Integer, lnIndex As Integer, ;
lcHomeDir As String, lcParentDir As String, lcMetaData As String

m.lcOldError = On("ERROR")

* ON ERROR for this program
On Error Do ErrorHandlerPR With Error(), Message(), Message(1), Program(), Lineno(), m.lcMetaData

m.lcSelectedCursor = Select()
m.lcProjectFile = Getfile( 'PJX', 'Select a Project File', 'Select')

If !Empty( m.lcProjectFile)
If Used( "ProjFile")
Use In ProjFile && So no "Alias in use" msg
Endif

Use (m.lcProjectFile) In Select(1) Again Noupdate Alias ProjFile Shared

If Type( "projfile.user") = "U"
=Messagebox("Project file selected is from prior version of FoxPro." + Chr(13) + ;
"Please select Visual FoxPro project.", MB_ICONEXCLAMATION + MB_OK, ccMESSAGE_CAPTION))

Use In ProjFile
Return
Endif
Else
Return
Endif

m.lnMsgRet = Messagebox("Are you sure you want to pack all the metadata files selected for the project?", ;
MB_ICONQUESTION + MB_YESNO + MB_DEFBUTTON1, ccMESSAGE_CAPTION)

If m.lnMsgRet = IDNO
Use In ProjFile
Return
Endif

Store 0 To m.lnRecordsProcessed, m.lnRecordsSkipped

Wait Window Padc("Processing project file...",78) Nowait

Select * From ProjFile Where Upper(Type) = "H" Into Cursor Query

* Initialize home directory variable and get project file name
If !Eof()
m.lcHomeDir = Alltrim( HomeDir) + Iif(Rat("\", HomeDir) != Len(Alltrim(HomeDir)), "\","")
m.lcHomeDir = Upper(Strtran( m.lcHomeDir, Chr(0), ""))
Else
m.lcHomeDir = ""
Endif

Use In Query


****************************************************************************
*--- [mustapha] Again added here my personal trick
*--- packing the Visual Class Libraries,Forms, Reports and Menus
*--- "V" :forms .scx; "K" :classlib .vcx; "R" :report .frx; "M" :menu .mnx
Select * From ProjFile Where Type In ("V", "K", "R", "M") Into Cursor ProjTemp

* Only packing the Visual Class Libraries and Forms at this time.
* select * from projfile where type in ("V", "K") into cursor projtemp
****************************************************************************

If _Tally < 1
Wait Window "No object type(s) in project that you specified, press any key..."
Else
Scan
Scatter Memvar Memo

* Count subdirectories so actual directory name can be printed

m.lnSubDir = 0
m.lnIndex = 1

Do While .T.
Do Case
Case Substr(Name, m.lnIndex, 4) = "..\\"
lnSubDir = m.lnSubDir + 1
lnIndex = m.lnIndex + 4
Case Substr(Name, m.lnIndex, 3) = "..\"
lnSubDir = m.lnSubDir + 1
lnIndex = m.lnIndex + 3
Otherwise
Exit
Endcase
Enddo

* Process "calculated" fields, remember mNotes is based on parameter

Do Case
Case m.lnSubDir = 0 And Substr(Name,1,1) = "\" && Absolute directories
m.lcParentDir = Substr( m.lcHomeDir, 1, 2)
Case m.lnSubDir = 0 And Substr(Name,2,1) = ":" && Complete path
m.lcParentDir = ""
Case m.lnSubDir = 0 And Substr(Name,1,1) != "\" && Relative directories
m.lcParentDir = m.lcHomeDir
Otherwise && One or more parental directories
m.lcParentDir = Upper(Substr( m.lcHomeDir, 1, Rat("\", m.lcHomeDir, m.lnSubDir +1)))
Endcase

* m.mDirName was created during SCATTER (why it is not std name)
m.mDirName = m.lcParentDir + Upper(Substr(Name, m.lnIndex , Rat("\",Name) - m.lnIndex +1))
m.lcMetaData = m.mDirName + ShortNamePR( Name)
m.plFileOpened = .T.

Use (m.lcMetaData) In Select(1) Alias MetaData Exclusive

If m.plFileOpened
Select MetaData
Wait Window Padc("Packing: " + m.lcMetaData, 80) Nowait
Pack
Use
m.lnRecordsProcessed = m.lnRecordsProcessed + 1
Else
m.lnRecordsSkipped = m.lnRecordsSkipped + 1
Endif

Select ProjTemp

Endscan
Endif

Wait Clear

=Messagebox("Number of metadata tables packed was " + Alltrim(Str(lnRecordsProcessed)) + Chr(13) + ;
"Number of metadata tables skipped was " + Alltrim(Str(lnRecordsSkipped)), ;
MB_OK + MB_ICONINFORMATION, ccMESSAGE_CAPTION)

Use In ProjFile
Use In ProjTemp

Select (lcSelectedCursor)

On Error &lcOldError

Return


****************************************************************************
*
* PROCEDURE NAME: ShortNamePR
*
* PROCEDURE DESCRIPTION:
* This routine is called to truncate the directory information from the
* NAME field in the project file.
*
* INPUT PARAMETERS:
* tcFileName = The NAME field passed in as a parameter with possible
* directory information
*
* OUTPUT PARAMETERS:
* lcRetString = The filename with no directory or possilble NULL character
*
****************************************************************************
Procedure ShortNamePR
Lparameter tcFileName As String

Local lcRetString As String &&--- Value returned by the function

m.lcRetString = Upper(Substr( m.tcFileName, Rat("\", m.tcFileName) +1))

* Eliminate all Null characters from field passed to procedure.
* This removes the "box" character displayed in field during the report print preview.
Return Strtran( m.lcRetString, Chr(0), "")


****************************************************************************
*
* ErrorHandlerPR
*
* PROCEDURE DESCRIPTION:
* Custom error handler for the program.
* Main reason for this procedure is to capture the error of FoxUser.dbf in use
* by another session of FoxPro.
* All other errors get a messagebox which allows the user to cancel or continue the program.
*
* INPUT PARAMETERS (All Required):
* tnError = Error number from the FoxPro generated error
* tcMsg = Actual error message string related to the error
* tcMsg1 = FoxPro code that caused the error
* tcProg = Program name where the error occured
* tnLineno = Line number of the program where error occured
* tcMetadata = Name of metadata file being opened when error occurs
*
* OUTPUT PARAMETERS:
* None
*
****************************************************************************
Procedure ErrorHandlerPR
Lparameter tnError As Integer, tcMsg As String, tcMsg1 As String, tcProg As String, ;
tnLineno As Integer, tcMetadata As String

Local lcOldOnError As String, lnRetVal As Integer

m.lcOldOnError = On("ERROR")

On Error

Do Case
Case m.tnError = 3
m.plFileOpened = .F.
m.lnRetVal = Messagebox( "Metadata file (" + Lower( m.tcMetadata) + ;
") already in use, will not be packed during this run.", ;
MB_OK + MB_ICONEXCLAMATION, ccMESSAGE_CAPTION)
Otherwise
m.lnRetVal = Messagebox( m.tcMsg + "(VFP "+ Alltrim( Str( m.tnError)) + ")" + Chr(13) + ;
"in " + m.tcProg + " on line " + Alltrim( Str( m.tnLineno)) + Chr(13) + Chr(13) + ;
"Do you want to continue?", ;
MB_YESNO + MB_ICONEXCLAMATION, ccMESSAGE_CAPTION)

If m.lnRetVal = IDNO
Cancel
Endif
Endcase

On Error &lcOldOnError

Endproc
*--------------------------------------------------------------------