Wiki Home

Show Pem


Namespace: VFP

28-jul-2005 new version of Show Pem function was
uploaded to Wiki FTPDirectories as Showpem.zip

30-jul-2005 Put to \Files

Thanks

Sample for the Doug Hennig `s library sfctrls.vcx

* a class "sfform"

PROCEDURE ShortcutMenu
lparameters toMenu, tcObject

#IF Debug_Mode
with toMenu
  IF _Vfp.StartMode = 0
    .AddMenuBar(ccSHT_MENU_SUSPEND, 'SUSPEND')
  ENDIF
  .AddMenuBar(ccSHT_MENU_QUIT, 'QUIT')
  .AddMenuBar(ccSHT_MENU_PROPERTIES , 'ShowPem(' + tcObject + ', 1)')
  .AddMenuBar(ccSHT_MENU_P_BUILT_IN , 'ShowPem(' + tcObject + ', 1.1)')
  .AddMenuBar(ccSHT_MENU_P_USER_DEF , 'ShowPem(' + tcObject + ', 1.2)')
  .AddMenuBar(ccSHT_MENU_P_CHANGED  , 'ShowPem(' + tcObject + ', 1.3)')
  .AddMenuBar(ccSHT_MENU_P_READOMLY , 'ShowPem(' + tcObject + ', 1.4)')
  .AddMenuBar(ccSHT_MENU_P_ARRAYS   , 'ShowPem(' + tcObject + ', 1.21)')

  .AddMenuBar(ccSHT_MENU_P_CONTROLS , 'ShowPem(' + tcObject + ', 1.12)')
  .AddMenuBar(ccSHT_MENU_P_OBJECTS  , 'ShowPem(' + tcObject + ', 1.13)')
  .AddMenuBar(ccSHT_MENU_P_DATAENV  , 'ShowPem(' + tcObject + ', 1.15)')
  .AddMenuBar(ccSHT_MENU_EVENTS     , 'ShowPem(' + tcObject + ', 2)')
  .AddMenuBar(ccSHT_MENU_METHODS    , 'ShowPem(' + tcObject + ', 3)')
  .AddMenuBar(ccSHT_MENU_M_BUILT_IN , 'ShowPem(' + tcObject + ', 3.1)')
  .AddMenuBar(ccSHT_MENU_M_USER_DEF , 'ShowPem(' + tcObject + ', 3.2)')
  .AddMenuBar(ccSHT_MENU_OBJECTS    , 'ShowPem(' + tcObject + ', 4)')
  .AddMenuBar(ccSHT_MENU_P_XREF     , 'ShowPem(' + tcObject + ', 5)')
  .AddMenuBar(ccSHT_MENU_P_XREF_B_IN, 'ShowPem(' + tcObject + ', 5.1)')
  .AddMenuBar(ccSHT_MENU_P_XREF_UDP , 'ShowPem(' + tcObject + ', 5.2)')
  .AddMenuBar(ccSHT_MENU_M_XREF     , 'ShowPem(' + tcObject + ', 6)')
  .AddMenuBar(ccSHT_MENU_M_XREF_B_IN, 'ShowPem(' + tcObject + ', 6.1)')
  .AddMenuBar(ccSHT_MENU_M_XREF_UDF , 'ShowPem(' + tcObject + ', 6.2)')
endwith
#ENDIF
ENDPROC


* ShowPEM ( toObject, tnPEM, tcFilter, tlNoShow, tlNoRecursion )
* Shows object`s properties, events, methods.
* Parameters:
* toObject -  An object
* tnPEM    -  Default = 1
*             1 - all properties with values
*             1.1 - built-in properties
*             1.2 - user-defined properties
*             1.3 - changed properties
*             1.4 - read-only properties
*             1.5 - user-defined arrays
*             2 - an object`s events
*             3 - an object`s methods
*             3.1 - built-in methods
*             3.2 - user-defined methods
*             4 - added objects
*             5 - Cross-Reference of Properties
*             5.1 - Cross-Reference of Built-In Properties
*             5.2 - Cross-Reference of User-Defined Properties
*             6 - Cross-Reference of Procedures
*             6.1 - Cross-Reference of Built-In Procedures
*             6.2 - Cross-Reference of User-Defined Procedures
* tcFilter -  A filter.  Default = '' (All)
* tlNoShow -  if .T. don`t use MessageBox().  Default = .F.
* tlNoRecursion - .T. don`t use recursively.  Default = .F.
* Returns:  _ClipText
*
* Samples:
* DO ShowPem with _Screen
* DO ShowPem with _oBrowser,1.2
*
* PROCEDURE ShowPEM   && a superclass
* LPARAMETERS tnPEM, tcFilter, tlNoShow
* #IF ShowPem_Mode
*   IF FILE('ShowPEM.PRG') OR FILE('ShowPEM.FXP')
*     RETURN ShowPEM(This, tnPEM, tcFilter, tlNoShow)
*   ENDIF
*   RETURN ''
* #ENDIF
* ENDPROC
*
* Notes:
* VFP`s version - 6.0 and more
* "Udp" - "User-defined property".
*
* Vladimir Tokarev, Russia.
* Written:  11-mar-2002
* Last revision:  27-apr-2005
*
* Thanks to:
* Kelly G. Conway - vfptools.zip
* Menachem Bazian - Special Edition Using Visual FoxPro 6


#INCLUDE  'FOXPRO.H'

* Messages
#DEFINE ccM_WHERE_IS_LOC        'Where is'
#DEFINE ccEMPTY_PROPERTY_VALUE  '[None]'

#DEFINE cnMESSAGEBOX_LINES      28

* ASCII codes
#DEFINE ccTAB                   CHR( 9)
#DEFINE ccLF                    CHR(10)
#DEFINE ccCR                    CHR(13)
#DEFINE ccCRLF                  CHR(13)+CHR(10)



LPARAMETERs toObject, tnPEM, tcFilter, tlNoShow, tlNoRecursion
IF PARAMETERs() < 1 .or. TYPE('toObject') # 'O'
  RETURN .F.
ENDIF
IF PARAMETERs() < 2 .or. TYPE('tnPEM') # 'N'
  tnPEM = 1
ENDIF
IF PARAMETERs() < 3 .or. TYPE('tcFilter') # 'C'
  tcFilter = ''
ENDIF
IF TYPE('tlNoShow') # 'L'
  tlNoShow = .F.
ENDIF
IF TYPE('tlNoRecursion') # 'L'
  tlNoRecursion = .F.
ENDIF

LOCAL ;
  lcSaveExact, ;
  lnSaveSelect, ;
  lcSaveClipText, ;
  lcFilter, ;
  lnPEM, ;
  laTemp[1], ;
  lcMsg, ;
  lnI, ;
  lnJ, ;
  lnK, ;
  lnX, ;
  lcTitle, ;
  lcPem, ;
  lcStr, ;
  lcStr2, ;
  llUndefined, ;
  llChanged, ;
  llReadOnly, ;
  llProtected, ;
  llBuiltIn, ;
  llArray, ;
  loButton, ;
  loColumn, ;
  loForm, ;
  loObject, ;
  loPage, ;
  lnR, ;             && red
  lnG, ;             && green
  lnB, ;             && blue
  luValue, ;
  lcBaseClass, ;
  lcClass, ;
  lcClassLibrary, ;
  lcLibrary, ;
  lcVcx, ;
  lcAlias, ;
  laLibraries[1], ;
  lnAlenCount, ;
  llVcxMode, ;
  llScxMode, ;
  llPrgMode, ;
  llVcxScxMode, ;
  lcExt, ;
  lcField, ;
  lcForClause, ;
  lcWindow, ;
  loWindow, ;
  loName, ;
  lcCaption, ;       && Form`s header
  lcVfpCaption, ;
  lcComment, ;       && Comment`s symbols.
  lcTmp, ;
  lnRows, ;
  lnCols, ;
  lnRow, ;
  lnCol

lcSaveExact = SET('exact')
SET EXACT OFF
lnSaveSelect = SELECT()
lcSaveClipText = _ClipText
lcFilter = UPPER( ALLTRIM( tcFilter ))
lnPEM = MAX(1, MIN(6.2, tnPEM))

lcComment = '*-- '
lcStr2 = SPACE(5)
STORE '' TO ;
  lcTitle, ;
  lcPem, ;
  lcMsg, ;
  lcStr, ;
  lcCaption, ;
  _cliptext

do case
  case lnPEM = 1
       lcTitle = 'Properties of the "'
  case lnPEM = 1.1
       lcTitle = 'Built-in properties of the "'
  case lnPEM = 1.2
       lcTitle = 'User-defined properties of the "'
  case lnPEM = 1.3
       lcTitle = 'Changed properties of the "'
  case lnPEM = 1.4
       lcTitle = 'Read-only properties of the "'
  case lnPEM = 1.5
       lcTitle = 'Arrays of the "'
  case lnPEM = 2
       lcTitle = 'Events of the "'
       lcPem   = 'Event'
  case lnPEM = 3
       lcTitle = 'Methods of the "'
       lcPem   = 'Method'
  case lnPEM = 3.1
       lcTitle = 'Built-in methods of the "'
       lcPem   = 'Method'
  case lnPEM = 3.2
       lcTitle = 'User-defined methods of the "'
       lcPem   = 'Method'
  case lnPEM = 4
       lcTitle = 'Objects of the "'
       lcPem   = 'Object'
  case lnPEM = 5
       lcTitle = 'Cross-Reference of Properties'
  case lnPEM = 5.1
       lcTitle = 'Cross-Reference of Built-In Properties'
  case lnPEM = 5.2
       lcTitle = 'Cross-Reference of User-Defined Properties'
  case lnPEM = 6
       lcTitle = 'Cross-Reference of Procedures'
  case lnPEM = 6.1
       lcTitle = 'Cross-Reference of Built-In Procedures'
  case lnPEM = 6.2
       lcTitle = 'Cross-Reference of User-Defined Procedures'
endcase


lnK = 1
lcClass = LOWER(toObject.Class)
lcBaseClass = LOWER(toObject.BaseClass)
lcClassLibrary = toObject.ClassLibrary
lcLibrary = lcClassLibrary
llVcxMode = UPPER(RIGHT(lcClassLibrary, 4)) == '.VCX'
llPrgMode = UPPER(RIGHT(lcClassLibrary, 4)) == '.FXP'
lcAlias = SYS(2015)
lcForClause = ''

AMEMBERS(laTemp, toObject, 2)
SET EXACT ON
llScxMode = ASCAN(laTemp, 'DATAENVIRONMENT') > 0
SET EXACT OFF
llVcxScxMode = llVcxMode OR llScxMode

IF llScxMode
  lcClass = LOWER(toObject.Name)
  IF EMPTY(toObject.ClassLibrary) AND LOWER(toObject.Class) == 'form' ;
    AND RIGHT(lcClass,1) $ '1234567890'

    DO WHILE RIGHT(lcClass,1) $ '1234567890'
      lcClass = LEFT(lcClass, LEN(lcClass)-1)
    ENDDO
  ENDIF
  lcLibrary = SYS(1271, toObject.DATAENVIRONMENT)
  lcClassLibrary = lcLibrary
ENDIF

IF llVcxScxMode AND INLIST(INT(lnPEM), 5, 6)
  lcVcx = SYS(2015)
  lnAlenCount = 0
  DO WHILE .T.
    * IF EMPTY(lcLibrary)   && llVcxScxMode = .F.
    *   EXIT
    * ENDIF
    IF NOT FILE(lcLibrary)
      lcExt = RIGHT(lcLibrary, 3)
      lcLibrary = ;
        LOWER(GETFILE(lcExt, ccM_WHERE_IS_LOC + ' ?', '', 0, ;
        ccM_WHERE_IS_LOC + ' ' + lcLibrary + ' ?'))
      IF EMPTY(lcLibrary)
        EXIT
      ENDIF
    ENDIF

    IF USED(lcVcx)
      USE IN (lcVcx)
    ENDIF
    SELECT 0
    USE (lcLibrary) AGAIN SHARED NOUPDATE ALIAS (lcVcx)
    * .Scx - 'File is in use'
    * USE (lcLibrary) AGAIN SHARED ALIAS (lcVcx)
    IF NOT USED()
      WAIT WINDOW 'THE TABLE ' + UPPER(lcLibrary) + ccCR + ;
        'WAS NOT OPENED.'
      EXIT
    ENDIF

    IF llScxMode
      LOCATE FOR LOWER(ALLTRIM(Objname)) == lcClass AND ;
        LOWER(ALLTRIM(Baseclass)) == lcBaseClass AND ;
        EMPTY(Parent) AND ;
        Platform == "WINDOWS " AND ;
        NOT DELETED()
    ELSE
      LOCATE FOR LOWER(ALLTRIM(Objname)) == lcClass AND ;
        LOWER(ALLTRIM(Baseclass)) == lcBaseClass AND ;
        EMPTY(Parent) AND ;
        Reserved1 = "Class" AND ;
        Platform == "WINDOWS " AND ;
        NOT DELETED()
    ENDIF

    IF EOF()
      WAIT WINDOW 'NO RECORD IN ' + lcLibrary + ccCR + ;
        'FOR Lower(AllTrim(Objname)) == ' + lcClass
      EXIT
    ENDIF

    lnAlenCount = lnAlenCount + 1
    DIMENSION laLibraries[lnAlenCount, 9]
    * laLibraries[x, 1] - Name of the class.
    * laLibraries[x, 2] - Name of the file containing the parent class.
    * laLibraries[x, 3] - Name of the parent class.
    * laLibraries[x, 4] - Name of the file containing the class.
    * laLibraries[x, 5] - Procedures`s code of the class.
    * laLibraries[x, 6] - Properties`s value of the class.
    * laLibraries[x, 7] - Reserved3 field
    * laLibraries[x, 8] - User field
    * laLibraries[x, 9] - VCX record number.
    laLibraries[lnAlenCount, 1] = EVALUATE(lcVcx + '.OBJNAME')
    laLibraries[lnAlenCount, 2] = EVALUATE(lcVcx + '.CLASSLOC')
    laLibraries[lnAlenCount, 3] = EVALUATE(lcVcx + '.CLASS')
    laLibraries[lnAlenCount, 4] = lcLibrary
    laLibraries[lnAlenCount, 5] = EVALUATE(lcVcx + '.METHODS')
    laLibraries[lnAlenCount, 6] = EVALUATE(lcVcx + '.PROPERTIES')
    laLibraries[lnAlenCount, 7] = EVALUATE(lcVcx + '.RESERVED3')
    laLibraries[lnAlenCount, 8] = EVALUATE(lcVcx + '.USER')
    laLibraries[lnAlenCount, 9] = RECNO(lcVcx)

    lcClass = ALLTRIM(laLibraries[lnAlenCount, 3])
    IF EMPTY(lcClass)
      WAIT WINDOW 'EMPTY FIELD "Class" IN ' + lcLibrary
      EXIT
    ENDIF
    IF EMPTY(laLibraries[lnAlenCount, 2])   && first level
      EXIT
    ELSE
      lcLibrary = FULLPATH(ALLTRIM(laLibraries[lnAlenCount, 2]), lcLibrary)
    ENDIF
  ENDDO   && WHILE NOT EMPTY(lcLibrary)

  IF USED(lcVcx)
    USE IN (lcVcx)
  ENDIF
  SELECT (lnSaveSelect)
ENDIF   && llVcxScxMode AND INLIST(INT(lnPEM), 5, 6)


AMEMBERS(laTemp, toObject, 1)

FOR lnI = 1 to ALEN( laTemp, 1 )

  llUndefined = TYPE('toObject.'+laTemp[lnI,1]) = 'U'
  llChanged   = pemstatus(toObject, laTemp[lnI,1], 0)
  llReadOnly  = pemstatus(toObject, laTemp[lnI,1], 1)
  llProtected = pemstatus(toObject, laTemp[lnI,1], 2)
  llBuiltIn   = NOT pemstatus(toObject, laTemp[lnI,1], 4)
  IF (laTemp[lnI,1] == 'FORMS' OR laTemp[lnI,1] == 'FORMCOUNT') ;
    AND toObject.Name == 'Screen'
    llBuiltIn = .T.
  ENDIF
  llArray = .F.
  IF NOT llBuiltIn AND TYPE('toObject.'+laTemp[lnI,1]+'[1]') <> 'U'
    llArray = .T.
    lnRows = ALEN(toObject.&laTemp[lnI,1], 1)
    lnCols = ALEN(toObject.&laTemp[lnI,1], 2)
  ENDIF

  do case

    case laTemp[lnI,2] == 'Property' AND ;
         lcFilter = Left(laTemp[lnI,1], Len(lcFilter)) AND ;
         INT(lnPEM) = 1
      SET EXACT ON

      do case
        case lnPEM = 1.1 AND NOT llBuiltIn
          lnK = lnK - 1
        case lnPEM = 1.2 AND llBuiltIn
          lnK = lnK - 1
        case lnPEM = 1.3 AND NOT llChanged
          lnK = lnK - 1
        case lnPEM = 1.4 AND NOT llReadonly
          lnK = lnK - 1
        case lnPEM = 1.5 AND NOT llArray
          lnK = lnK - 1

* Debugger - "Collection"

        case INLIST(laTemp[lnI,1], 'FORMS','OBJECTS', 'CONTROLS',;
          'PAGES','BUTTONS','PROJECTS','FILES','COLUMNS')
          lcMsg = lcMsg + laTemp[lnI,1] + ' -- ' + 'COLLECTION' + ccCR

        case laTemp[lnI,1] == 'LIST' AND ;
          INLIST(lcBaseClass, 'combobox','listbox')
          lcMsg = lcMsg + laTemp[lnI,1] + ' -- ' + 'Array of items' + ccCR

* Built-in properties:
* activecolumn, activecontrol, activedoc, activeform,

* activepage, activeproject, activerow,  parent
* Debugger - "Expression could not be evaluated"

        case llBuiltIn AND llUndefined
*           lcMsg = lcMsg + laTemp[lnI,1] + ' = .UNDEFINED.' + ccCR
          lcMsg = lcMsg + laTemp[lnI,1] + ;
            ' = Expression could not be evaluated' + ccCR

* .VCX`s case
* .PRG`s in otherwise

        case llUndefined
          IF ISNULL(toObject.&laTemp[lnI,1])
            lcMsg = lcMsg + laTemp[lnI,1] + ' = .NULL.'
          ELSE
*             lcMsg = lcMsg + laTemp[lnI,1] + ' = .UNDEFINED.'
            lcMsg = lcMsg + laTemp[lnI,1] + ;
              ' = Expression could not be evaluated'
          ENDIF
          lcStr = lcStr + IIF(INLIST(lnPEM, 1, 1.3), 'Udp', '')
          IF llReadOnly AND NOT lnPEM = 1.4
            lcStr = lcStr + ' Read-only'
          ENDIF
          IF llProtected
            lcStr = lcStr + ' Protected'
          ENDIF
          IF llChanged AND NOT lnPEM = 1.3
            lcStr = lcStr + ' Changed'
          ENDIF
          lcStr = STRTRAN( lcStr, ' ', ',  ')
          lcStr = IIF(EMPTY(lcStr), lcStr, lcStr2 + '( ' + lcStr + ' )')
          lcMsg = lcMsg + lcStr + ccCR

* activecolumn, activecontrol, activedoc, activeform,
* activepage, activeproject, activerow,  parent.
* And user-defined objects.
* Debugger - "Object"

        case TYPE('toObject.'+laTemp[lnI,1]) = 'O'
          IF ISNULL(toObject.&laTemp[lnI,1])
            lcMsg = lcMsg + laTemp[lnI,1] + ' = .NULL.'
            lcStr = lcStr + 'Type = "O"'
          ELSE
            lcMsg = lcMsg + laTemp[lnI,1] + ' = ' + ;
              toObject.&laTemp[lnI,1]..name
            lcStr = lcStr + 'Object'
          ENDIF
          IF NOT llBuiltIn  && user-defined prop.
            lcStr = lcStr + IIF(INLIST(lnPEM, 1, 1.3), ' Udp', '')
          ENDIF
          IF llReadOnly AND NOT lnPEM = 1.4
            lcStr = lcStr + ' Read-only'
          ENDIF
          IF llProtected
            lcStr = lcStr + ' Protected'
          ENDIF
          IF llChanged AND NOT lnPEM = 1.3
            lcStr = lcStr + ' Changed'
          ENDIF
          lcStr = STRTRAN( lcStr, ' ', ',  ')
          lcStr = IIF(EMPTY(lcStr), lcStr, lcStr2 + '( ' + lcStr + ' )')
          lcMsg = lcMsg + lcStr + ccCR

* It may be for ComboBox.SelText

        case EMPTY(TYPE('toObject.'+laTemp[lnI,1]))
          lcMsg = lcMsg + laTemp[lnI,1] + ' = .UNKNOWN.' + ccCR

        otherwise

          IF NOT llBuiltIn  && user-defined prop.
            lcStr = lcStr + IIF(INLIST(lnPEM, 1, 1.3), 'Udp', '')
          ENDIF
          IF llReadOnly AND NOT lnPEM = 1.4
            lcStr = lcStr + ' Read-only'
          ENDIF
          IF llProtected
            lcStr = lcStr + ' Protected'
          ENDIF
          IF llChanged AND NOT lnPEM = 1.3
            lcStr = lcStr + ' Changed'
          ENDIF
* Allways TYPE() <> 'U' for built-ins
* Debugger - "Array"
          IF llArray AND NOT lnPEM = 1.5
            lcStr = lcStr + ' Array [' + TRANSFORM(lnRows) + ;
              IIF(lnCols=0, '', ',' + TRANSFORM(lnCols)) + ']'
          ENDIF

          luValue = toObject.&laTemp[lnI,1]
          IF RIGHT(laTemp[lnI,1], 5) == 'COLOR' AND llBuiltIn AND ;
            TYPE('luValue') = 'N' AND luValue > 0
            lnR = BITAND(luValue, 255)
            lnG = BITRSHIFT(BITAND(luValue, BITLSHIFT(255, 8)), 8)
            lnB = BITRSHIFT(BITAND(luValue, BITLSHIFT(255, 16)), 16)
            lcStr = lcStr + ' ' + 'Rgb(' +;
              transform(lnR) + ',' + ;
              transform(lnG) + ',' + ;
              transform(lnB) + ')'
          ENDIF

          lcStr = STRTRAN( LTRIM(lcStr), ' ', ',  ')
          lcStr = IIF(EMPTY(lcStr), lcStr, lcStr2 + '( ' + lcStr + ' )')
          *
          DO CASE
            CASE llArray AND lnPEM = 1.5
              lnX = 1
              DO WHILE TYPE('toObject.' + laTemp[lnI,1] + '[' + ;
                transform(lnX) + ']') <> 'U'
                luValue = EVALUATE('toObject.' + laTemp[lnI,1] + '[' + ;
                  TRANSFORM(lnX) + ']')
*                 IF TYPE('toObject.'+laTemp[lnI,1]+'['+ ;
*                   TRANSFORM(lnX) + ']') = 'C'
*                   lcMsg = lcMsg + laTemp[lnI,1] + ' [' + ;
*                     TRANSFORM(lnX) + '] = "' + ;
*                     transform(luValue) + '"' + lcStr + ccCR
*                 ELSE
*                   lcMsg = lcMsg + laTemp[lnI,1] + ' [' + ;
*                     TRANSFORM(lnX) + '] = ' + ;
*                     transform(luValue) + lcStr + ccCR
*                 ENDIF
                lnRow = ASUBSCRIPT(toObject.&laTemp[lnI,1], lnX, 1)
                lnCol = IIF(lnCols=0, 0, ;
                  ASUBSCRIPT(toObject.&laTemp[lnI,1], lnX, 2))
                lcTmp = TRANSFORM(lnRow) + ;
                  IIF(lnCol=0, '', ' ,' + TRANSFORM(lnCol))
                IF TYPE('toObject.'+laTemp[lnI,1]+'['+ ;
                  TRANSFORM(lnX) + ']') = 'C'
                  lcMsg = lcMsg + laTemp[lnI,1] + ' [' + lcTmp + '] = "' +;
                    transform(luValue) + '"' + lcStr + ccCR
                ELSE
                  lcMsg = lcMsg + laTemp[lnI,1] + ' [' + lcTmp + '] = ' +;
                    transform(luValue) + lcStr + ccCR
                ENDIF

                If lnK = cnMESSAGEBOX_LINES
                  If not tlNoShow
                    If MessageBox( lcMsg, MB_OKCANCEL, lcTitle + ;
                      IIf(Type('toObject.Parent') = 'O', toObject.Parent.Name + '.', ;
                      '') + toObject.Name + '"' ) = IDCANCEL
                      _cliptext = _cliptext + lcMsg
                      lcMsg = ''
                      lnK = 0
                      EXIT
                    EndiF
                  EndiF
                  _cliptext = _cliptext + lcMsg
                  lcMsg = ''
                  lnK = 0
                EndIF
                lnK = lnK + 1
                lnX = lnX + 1
              ENDDO

            CASE llArray
              luValue = EVALUATE('toObject.' + laTemp[lnI,1] + '[1]')
              IF TYPE('toObject.'+laTemp[lnI,1]+'[1]') = 'C'
                lcMsg = lcMsg + laTemp[lnI,1] + ' [1] = "' + ;
                        transform(luValue) + '"' + lcStr + ccCR
              ELSE
                lcMsg = lcMsg + laTemp[lnI,1] + ' [1] = ' + ;
                        transform(luValue) + lcStr + ccCR
              ENDIF
            CASE TYPE('toObject.'+laTemp[lnI,1]) = 'C'
              lcMsg = lcMsg + laTemp[lnI,1] + ' = "' + ;
                      transform(luValue) + '"' + lcStr + ccCR
            OTHERWISE
              lcMsg = lcMsg + laTemp[lnI,1] + ' = ' + ;
                      transform(luValue) + lcStr + ccCR
          ENDCASE

      endcase

      *
      If lnK = cnMESSAGEBOX_LINES
        If not tlNoShow
          If MessageBox( lcMsg, MB_OKCANCEL, lcTitle + ;
            IIf(Type('toObject.Parent') = 'O', toObject.Parent.Name + '.', ;
            '') + toObject.Name + '"' ) = IDCANCEL
            _cliptext = _cliptext + lcMsg
            lcMsg = ''
            EXIT
          EndiF
        EndiF
        _cliptext = _cliptext + lcMsg
        lcMsg = ''
        lnK = 0
      EndIF
      lnK = lnK + 1
      SET EXACT OFF



    case laTemp[lnI,2] == lcPem AND ;
         lcFilter = Left(laTemp[lnI,1], Len(lcFilter))

      do case
        case lnPEM = 3.1 AND NOT llBuiltIn
          lnK = lnK - 1
        case lnPEM = 3.2 AND llBuiltIn
          lnK = lnK - 1

        otherwise

          IF lnPEM = 3 AND llBuiltIn
            lcStr = lcStr + ' Built-In'
          ENDIF
          IF INLIST(lnPEM, 3, 3.1, 3.2) AND llProtected
            lcStr = lcStr + ' Protected'
          ENDIF

          lcStr = STRTRAN( LTRIM(lcStr), ' ', ',  ')
          lcStr = IIF(EMPTY(lcStr), lcStr, lcStr2 + '( ' + lcStr + ' )')
          *
          lcMsg = lcMsg + laTemp[lnI,1] + lcStr + ccCR

      endcase

      *
      If lnK = cnMESSAGEBOX_LINES
        If not tlNoShow
          If MessageBox( lcMsg, MB_OKCANCEL, lcTitle + ;
            IIf(Type('toObject.Parent') = 'O', toObject.Parent.Name + '.', ;
            '') + toObject.Name + '"' ) = IDCANCEL
            _cliptext = _cliptext + lcMsg
            lcMsg = ''
            EXIT
          EndiF
        EndiF
        _cliptext = _cliptext + lcMsg
        lcMsg = ''
        lnK = 0
      EndIF
      lnK = lnK + 1


    case lnPEM = 4 AND ;
      ASCAN(laTemp, 'ADDOBJECT') = 0 AND ;
      ASCAN(laTemp, 'REMOVEOBJECT') = 0
      lcMsg = 'It is not a container !'


    case (INT(lnPEM) = 5 OR INT(lnPEM) = 6) AND NOT llVcxScxMode
      WAIT WINDOW ;
        'NO CLASS LIBRARY' + ;
        ccCR + ;
        'OR SOMETHING ELSE ...'
      EXIT


    case INT(lnPEM) = 5 AND laTemp[lnI,2] == 'Property' ;
      AND lcFilter = Left(laTemp[lnI,1], Len(lcFilter))
      IF TYPE('laLibraries[1]') ='C'
        IF NOT USED(lcAlias)
          SELECT 0
          CREATE CURSOR (lcAlias) (Properties C(50))
        ELSE
          SELECT (lcAlias)
        ENDIF
        FOR lnJ = 1 TO lnAlenCount
          * lcField = GetValidFieldName(laLibraries[lnJ, 1])
          lcField = LEFT(laLibraries[lnJ, 1], 10)
          IF TYPE(lcField) <> 'M' AND NOT EMPTY(laLibraries[lnJ, 6])
            ALTER TABLE (lcAlias) ADD COLUMN (lcField) M
            lcCaption = lcCaption + '  ' + UPPER(laLibraries[lnJ, 1]) + ;
              IIF(UPPER(RIGHT(laLibraries[lnJ, 4], 4)) == '.SCX','.SCX','')
            IF EMPTY(lcForClause)
              lcForClause = 'NOT EMPTY(' + lcField + ')'
            ELSE
              lcForClause = lcForClause + ' OR NOT EMPTY(' + lcField + ')'
            ENDIF
          ENDIF
          IF NOT EMPTY(laLibraries[lnJ, 6])
            LOCATE FOR TRIM(Properties) == laTemp[lnI,1]
            IF FOUND()
              REPLACE (lcField) WITH ;
                GetPropertyValue(laTemp[lnI,1], laLibraries[lnJ, 6], ;
                  laLibraries[lnJ, 7], laLibraries[lnJ, 8], llBuiltIn)
            ELSE
              IF lnPEM = 5 OR ;
                (lnPEM = 5.1 AND llBuiltIn) OR ;
                (lnPEM = 5.2 AND NOT llBuiltIn)
                INSERT INTO (lcAlias) ;
                            (Properties, ;
                            (lcField)) ;
                  VALUES (laTemp[lnI,1], ;
                    GetPropertyValue(laTemp[lnI,1], laLibraries[lnJ, 6], ;
                      laLibraries[lnJ, 7], laLibraries[lnJ, 8], llBuiltIn))
              ENDIF
            ENDIF   && IF FOUND()
          ENDIF   && NOT EMPTY(laLibraries[lnJ, 6])
        ENDFOR
      ENDIF   && TYPE('laLibraries[1]') ='C'


    case INT(lnPEM) = 6 AND INLIST(laTemp[lnI,2], 'Event', 'Method') ;
      AND lcFilter = Left(laTemp[lnI,1], Len(lcFilter))
      IF TYPE('laLibraries[1]') ='C'
        IF NOT USED(lcAlias)
          SELECT 0
          CREATE CURSOR (lcAlias) (Procedures C(50))
        ELSE
          SELECT (lcAlias)
        ENDIF
        FOR lnJ = 1 TO lnAlenCount
          * lcField = GetValidFieldName(laLibraries[lnJ, 1])
          lcField = LEFT(laLibraries[lnJ, 1], 10)
          IF TYPE(lcField) <> 'M' AND NOT EMPTY(laLibraries[lnJ, 5])
            ALTER TABLE (lcAlias) ADD COLUMN (lcField) M
            lcCaption = lcCaption + '  ' + UPPER(laLibraries[lnJ, 1]) + ;
              IIF(UPPER(RIGHT(laLibraries[lnJ, 4], 4)) == '.SCX','.SCX','')
            IF EMPTY(lcForClause)
              lcForClause = 'NOT EMPTY(' + lcField + ')'
            ELSE
              lcForClause = lcForClause + ' OR NOT EMPTY(' + lcField + ')'
            ENDIF
          ENDIF
          IF NOT EMPTY(laLibraries[lnJ, 5])
            LOCATE FOR TRIM(Procedures) == laTemp[lnI,1]
            IF FOUND()
              REPLACE (lcField) WITH ;
                GetProcedureCode(laTemp[lnI,1], laLibraries[lnJ, 5], ;
                  laLibraries[lnJ, 7], laLibraries[lnJ, 8], llBuiltIn, ;
                  lcComment)
            ELSE
              IF lnPEM = 6 OR ;
                (lnPEM = 6.1 AND llBuiltIn) OR ;
                (lnPEM = 6.2 AND NOT llBuiltIn)
                INSERT INTO (lcAlias) ;
                            (Procedures, ;
                            (lcField)) ;
                  VALUES (laTemp[lnI,1], ;
                    GetProcedureCode(laTemp[lnI,1], laLibraries[lnJ, 5], ;
                      laLibraries[lnJ, 7], laLibraries[lnJ, 8], llBuiltIn, ;
                      lcComment))
              ENDIF
            ENDIF   && IF FOUND()
*             laLibraries[lnJ, 5] = ''  -  ???
          ENDIF   && NOT EMPTY(laLibraries[lnJ, 5])
        ENDFOR
      ENDIF   && TYPE('laLibraries[1]') ='C'


  endcase

  lcStr = ''
ENDFOR   && lnI = 1 to ALEN( laTemp, 1 )


IF (INT(lnPEM) = 5 OR INT(lnPEM) = 6) AND llVcxScxMode
  IF USED(lcAlias) AND NOT tlNoShow
    SELECT (lcAlias)
    LOCATE
    lcWindow = SYS(2015)
    loWindow = SYS(2015)
    LOCAL &loWindow
    &loWindow. = CREATEOBJECT('form')
    &loWindow..Name = lcWindow
    &loWindow..WindowState = 2
    &loWindow..Caption = lcCaption
    &loWindow..MDIForm = .T.

    lcVfpCaption = _VFP.Caption
    _VFP.Caption = ''

*     loName = SYS(2015)
*     DEFINE WINDOW (lcWindow) FROM 0,0 TO 1,1 ;
*       NAME (loName) ;
*       CLOSE ;
*       FLOAT ;
*       MINIMIZE ;
*       ZOOM ;
*       MDI ;
*       FONT 'arial cyr', 9 ;
*       TITLE lcTitle
*     &loName..WindowState = 2

* 1   ?  &  SAY field
* 2   GET field and PROMPT
* 3   Border
* 4   Title, active
* 5   Title, idle
* 6   Selected item
* 7   Clock          (/x - Browse`s active row border)
* 8   Shadow
* 9   Enabled ctrl.  (Browse`s forecolor & backcolor)
* 10  Dsabl'd ctrl.

    SET COLOR OF SCHEME 24 to;
      W+/N,W+/N,GR+/N,GR+/N,R+/N,W+/N,GR+/N,N+/N,W/N+*,R+/N,+
    ACTIVATE WINDOW (lcWindow)
*     BROWSE NODELETE
*     BROWSE NODELETE COLOR SCHEME 24 FOR &lcForClause.
    BROWSE NODELETE FOR &lcForClause.
    RELEASE WINDOW (lcWindow)

    _VFP.Caption = lcVfpCaption
    USE IN (lcAlias)
  ENDIF   && USED(lcAlias) AND NOT tlNoShow
ENDIF   && (INT(lnPEM) = 5 OR INT(lnPEM) = 6) AND llVcxScxMode

IF (INT(lnPEM) = 5 OR INT(lnPEM) = 6)
  _ClipText = lcSaveClipText
  SELECT (lnSaveSelect)
  set exact &lcSaveExact
  RETURN ''
ENDIF


if not Empty( lcMsg )
  If not tlNoShow
    MessageBox( lcMsg, MB_OK, lcTitle + ;
      IIf(Type('toObject.Parent') = 'O', toObject.Parent.Name + '.', '') + ;
      toObject.Name + '"' )
  EndiF
  _cliptext = _cliptext + lcMsg
endif


do case
  case lcBaseClass == 'commandgroup' or lcBaseClass == 'optiongroup'
    if MessageBox('', MB_YESNO + MB_DEFBUTTON2, ;
      lcTitle + toObject.name + '.Buttons" ?' ) = IDYES
      for each loButton in toObject.Buttons
        ShowPEM(loButton, tnPEM, tcFilter, tlNoShow)
      endfor
    endif

  case lcBaseClass == 'grid' and not tlNoRecursion
    if MessageBox('', MB_YESNO + MB_DEFBUTTON2, ;
      lcTitle + toObject.name + '.Columns" ?' ) = IDYES
      for each loColumn in toObject.Columns
        ShowPEM(loColumn, tnPEM, tcFilter, tlNoShow)
      endfor
    endif
    if INT(lnPEM) <> 4 AND MessageBox('', MB_YESNO + MB_DEFBUTTON2, ;
      lcTitle + toObject.name + '.Columns.Header" ?' ) = IDYES
      for each loColumn in toObject.Columns
        for each loObject in loColumn.Controls
          if Lower(loObject.BaseClass) == 'header'
            ShowPEM(loObject, tnPEM, tcFilter, tlNoShow)
          endif
        endfor
      endfor
    endif
    if INT(lnPEM) <> 4 AND MessageBox('', MB_YESNO + MB_DEFBUTTON2, ;
      lcTitle + toObject.name + '.Columns.TextBox" ?' ) = IDYES
      for each loColumn in toObject.Columns
        for each loObject in loColumn.Controls
          if Lower(loObject.BaseClass) == 'textbox'
            ShowPEM(loObject, tnPEM, tcFilter, tlNoShow, .T.)
          endif
        endfor
      endfor
    endif

  case lcBaseClass == 'textbox' and ;
    TYPE('toObject.Parent.Parent') = 'O' and ;
    LOWER(toObject.Parent.Parent.BaseClass) == 'grid' and not tlNoRecursion
    if MessageBox('', MB_YESNO + MB_DEFBUTTON2, ;
      lcTitle + toObject.Parent.Parent.name + ' ?' ) = IDYES
      ShowPEM(toObject.Parent.Parent, tnPEM, tcFilter, tlNoShow, .T.)
    endif

  case lcBaseClass == 'pageframe'
    if MessageBox('', MB_YESNO + MB_DEFBUTTON2, ;
      lcTitle + toObject.name + '.Pages" ?' ) = IDYES
      for each loPage in toObject.Pages
        ShowPEM(loPage, tnPEM, tcFilter, tlNoShow)
      endfor
    endif
    if Type('toObject.Parent') = 'O' and ;
      Lower(toObject.Parent.BaseClass) == 'form'
      if MessageBox('', MB_YESNO + MB_DEFBUTTON2, ;
        lcTitle + toObject.Parent.name + '" ?' ) = IDYES
        ShowPEM(toObject.Parent, tnPEM, tcFilter, tlNoShow)
      endif
    endif

  case lcBaseClass == 'formset'
    if MessageBox('', MB_YESNO + MB_DEFBUTTON2, ;
      lcTitle + toObject.name + '.Forms" ?' ) = IDYES
      for each loForm in toObject.Forms
        ShowPEM(loForm, tnPEM, tcFilter, tlNoShow)
      endfor
    endif
endcase

SELECT (lnSaveSelect)
set exact &lcSaveExact
RETURN (_cliptext)



**************************************************************************
FUNCTION GetProcedureCode
LPARAMETERS tcName, tcMethods, tcReserved3, tcUser, tlBuiltIn, tcComment
LOCAL ;
  lnStartPos, ;
  lnEndPos, ;
  lcMethod, ;
  lcComment

lnStartPos=ATC(ccCRLF + "PROCEDURE " + tcName + ccCRLF, ccCRLF + tcMethods)
IF lnStartPos > 0
  lnEndPos = ATC(ccCRLF + "ENDPROC" , SUBSTR(tcMethods, lnStartPos))
  IF lnEndPos = 0   && last proc
    lnEndPos = LEN(tcMethods) - lnStartPos
  ELSE
    lnEndPos = lnEndPos - 1   && chr(13)
  ENDIF
  lcMethod = SUBSTR(tcMethods, lnStartPos, lnEndPos)
  DO WHILE INLIST(RIGHT(lcMethod, 1), ccTAB, ccLF, ccCR, ' ')
    lcMethod = LEFT(lcMethod, LEN(lcMethod) - 1)
  ENDDO
  lcComment = GetProcedureComment(tcName, tcReserved3, tcUser, tlBuiltIn)
  IF EMPTY(lcComment)
    RETURN lcMethod + ccCRLF + "ENDPROC" + ccCRLF
  ELSE
    RETURN tcComment + lcComment + ccCRLF + ccCRLF + ;
           lcMethod + ccCRLF + "ENDPROC" + ccCRLF
  ENDIF
ENDIF   && lnStartPos > 0
RETURN ''


*************************
FUNCTION GetPropertyValue
LPARAMETERS tcName, tcProperties, tcReserved3, tcUser, tlBuiltIn
LOCAL ;
  lnStartPos, ;
  lnEndPos, ;
  lcLine, ;
  lcStr, ;
  lnAtPos, ;
  lcData, ;
  lcComment

lnStartPos = ATC(ccCRLF + tcName + ' = ', ccCRLF + tcProperties)
IF lnStartPos > 0

  lnEndPos = AT(ccCRLF , SUBSTR(tcProperties, lnStartPos))
  IF lnEndPos = 0
    lnEndPos = LEN(tcProperties) - lnStartPos
  ELSE
    lnEndPos = lnEndPos - 1   && chr(13)
  ENDIF
  lcLine = SUBSTR(tcProperties, lnStartPos, lnEndPos)
  lcStr = "= "
  lnAtPos = AT(lcStr, lcLine)
  lcData = ALLTRIM(SUBSTR(lcLine, lnAtPos + LEN(lcStr)))
  lcData = IIF(EMPTY(lcData), ccEMPTY_PROPERTY_VALUE, lcData)
  lcComment = GetPropertyComment(tcName, tcReserved3, tcUser, tlBuiltIn)
  RETURN IIF(EMPTY(lcComment), lcData, lcComment + ccCRLF+ccCRLF + lcData)
ENDIF   && lnStartPos > 0

lnStartPos = ATC(ccCRLF + '^' + tcName +'[', ccCRLF + tcReserved3)
IF lnStartPos > 0
  lnEndPos = AT(ccCRLF , SUBSTR(tcReserved3, lnStartPos))
  IF lnEndPos = 0
    lnEndPos = LEN(tcReserved3) - lnStartPos
  ELSE
    lnEndPos = lnEndPos - 1   && chr(13)
  ENDIF
  lcLine = SUBSTR(tcReserved3, lnStartPos, lnEndPos)
  lnAtPos = AT('[', lcLine)
  lcData = SUBSTR(lcLine, lnAtPos, AT(']', lcLine) - lnAtPos + 1)
  lcData = lcData + ccCRLF + '.F.'
  lcComment = GetPropertyComment(tcName, tcReserved3, tcUser, tlBuiltIn)
  RETURN IIF(EMPTY(lcComment), lcData, lcComment + ccCRLF+ccCRLF + lcData)
ENDIF   && lnStartPos > 0
RETURN ''


**************************
* FUNCTION GetValidFieldName
* lparameters tcName
* local lcName
* lcName = tcName
* DO WHILE LEFT(lcName, 1) $ '_1234567890'
*   lcName = SUBSTR(lcName, 2)
* ENDDO
* RETURN LEFT(lcName, 10)


****************************
FUNCTION GetProcedureComment
LPARAMETERS tcName, tcReserved3, tcUser, tlBuiltIn
LOCAL ;
  lcMemo, ;
  lnStartPos, ;
  lnEndPos, ;
  lcLine, ;
  lcStr, ;
  lnAtPos, ;
  lcData

lcMemo = IIF(tlBuiltIn, tcUser, tcReserved3)
lnStartPos = ATC(ccCRLF + '*' + tcName + ' ', ccCRLF + lcMemo)
IF lnStartPos > 0
  lnEndPos = AT(ccCRLF , SUBSTR(lcMemo, lnStartPos))
  IF lnEndPos = 0
    lnEndPos = LEN(lcMemo) - lnStartPos
  ELSE
    lnEndPos = lnEndPos - 1   && chr(13)
  ENDIF
  lcLine = SUBSTR(lcMemo, lnStartPos, lnEndPos)
  lcStr = " "
  lnAtPos = AT(lcStr, lcLine)
  lcData = ALLTRIM(SUBSTR(lcLine, lnAtPos + LEN(lcStr)))
  IF lnAtPos > 0
    RETURN lcData
  ENDIF
ENDIF   && lnStartPos > 0
RETURN ''


***************************
FUNCTION GetPropertyComment
LPARAMETERS tcName, tcReserved3, tcUser, tlBuiltIn
LOCAL ;
  lcMemo, ;
  lnStartPos, ;
  lnEndPos, ;
  lcLine, ;
  lcStr, ;
  lnAtPos, ;
  lcData

lcMemo = IIF(tlBuiltIn, tcUser, tcReserved3)
lnStartPos = ATC(ccCRLF + tcName + ' ', ccCRLF + lcMemo)
IF lnStartPos > 0
  lnEndPos = AT(ccCRLF , SUBSTR(lcMemo, lnStartPos))
  IF lnEndPos = 0
    lnEndPos = LEN(lcMemo) - lnStartPos
  ELSE
    lnEndPos = lnEndPos - 1   && chr(13)
  ENDIF
  lcLine = SUBSTR(lcMemo, lnStartPos, lnEndPos)
  lcStr = " "
  lnAtPos = AT(lcStr, lcLine)
  lcData = ALLTRIM(SUBSTR(lcLine, lnAtPos + LEN(lcStr)))
  IF lnAtPos > 0
    RETURN lcData
  ENDIF
ENDIF   && lnStartPos > 0

lnStartPos = ATC(ccCRLF + '^' + tcName + '[', ccCRLF + lcMemo)
IF lnStartPos > 0
  lnEndPos = AT(ccCRLF , SUBSTR(lcMemo, lnStartPos))
  IF lnEndPos = 0
    lnEndPos = LEN(lcMemo) - lnStartPos
  ELSE
    lnEndPos = lnEndPos - 1   && chr(13)
  ENDIF
  lcLine = SUBSTR(lcMemo, lnStartPos, lnEndPos)
  IF ' ' $ lcLine
    lcStr = "] "
    lnAtPos = AT(lcStr, lcLine)
    lcData = ALLTRIM(SUBSTR(lcLine, lnAtPos + LEN(lcStr)))
    IF lnAtPos > 0
      RETURN lcData
    ENDIF
  ENDIF
ENDIF   && lnStartPos > 0
RETURN ''


Category Development Tools Category Developer Productivity Category Code Samples
( Topic last updated: 2005.07.30 06:40:54 AM )