Menú dinámico

Hola a Todos, esto se me ocurrió hace tiempo y recién lo he podido implementar, mi idea era generar un menú que se encuentre definido en una tabla dbf y luego llamarlo desde un formulario de nivel superior, para que no se necesite compilar nuestra aplicación si queremos cambiar algo en el menú, ojalá les sirva de utilidad.

****************************************
* MODO DE USO :
* COPIAR EL TEXTO EN UN PRG EN
* CUALQUIER CARPETA EJ: MENU.PRG
* DO MENU.PRG
****************************************
* INDICACIONES :
* EL CODIGO SE ENCARGA DE CREAR UN FORM DE NIVEL SUPERIOR, GENERA EL
* MENU Y HACE LA LLAMADA AL MISMO LA PRIMERA VEZ QUE SE EJECUTA EL
* CODIGO, VERIFICA SI EXISTE LA TABLA DE MENU, EN LA CUAL SE DEFINEN LOS
* NIVELES DE PROFUNDIDAD DE CADA OPCION DEL MENU, LO CUAL LO PUEDES
* MANEJAR SEGUN REQUERIMIENTO LAS OPCIONES DE LOS MENUS NO VAN A
* FUNCIONAR AL NO EXISTIR LOS FORMULARIOS EN LA RUTA, ESO LO DEBES
* CAMBIAR SEGUN REQUERIMIENTO.

IF !FILE("MENU.DBF")
  CREATE TABLE MENU (MODULO C(2),;
    CODIGO C(14),;
    DESCRIPC C(50),;
    COMMAND C(50))
  SELECT MENU
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","01000000000000","Tablas","")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","01010000000000","Clientes","DO FORM CLIENTES.SCX")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","01020000000000","Proveedores","DO FORM PROVEEDORES.SCX")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","01030000000000","Maestras","ACTIVATE POPUP P010301")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","01030100000000","Trabajadores","ACTIVATE POPUP P01030101")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","01030101000000","Empleados","DO FORM EMPLEADOS.SCX")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","01030102000000","Obreros","ACTIVATE POPUP P0103010201")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","01030102010000","Obreros Clasificados","DO FORM CLASIFICA.SCX")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","02000000000000","Procesos","")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","02010000000000","Calcular Encuesta","DO FORM CALCULAR.SCX")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","02020000000000","Tipos De Empleados","ACTIVATE POPUP P020201")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","02020100000000","Obreros","DO FORM OBREROS.SCX")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","02020100000000","Empleados","DO FORM EMPLEADOS.SCX")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","02020100000000","Contratistas","ACTIVATE POPUP P02020101")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","02020101000000","Luz Del Sur","ACTIVATE POPUP P0202010101")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","02020101010000","Electricistas","ACTIVATE POPUP P020201010101")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","02020101010100","Juan Perez","DO FORM JUAN.SCX")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("01","02020101010200","Jose Chavez","DO FORM JOSE.SCX")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("02","03000000000000","Ayuda","")
  INSERT INTO MENU(MODULO,CODIGO,DESCRIPC,COMMAND) VALUES ("02","03010000000000","Acerca De","do form acercade.scx")
  INDEX ON modulo+codigo TAG ORDEN
  CLOSE ALL
ENDIF
IF USED('TABMENU')
  USE IN TABMENU
ENDIF

oForm = CREATEOBJECT('MyFormSample')
oForm.SHOW
READ EVENTS

DEFINE CLASS MyFormSample AS FORM
  NAME = 'FrmPrincipal'
  CAPTION = 'Formulario Principal'
  SHOWWINDOW = 2
  WINDOWSTATE = 2
  cNameMenuMP = ""
  PROCEDURE LOAD
    =MESSAGEBOX("ejecutando load")
    THISFORM.Previo()
      \LPARAMETER oFormRef,getMenuName
      \
      \LOCAL cMenuName
      \IF TYPE("m.oFormRef") # "O" OR LOWER(m.oFormRef.BaseClass) # 'form' OR m.oFormRef.ShowWindow # 2
      \   RETURN
      \ENDIF
      \m.cMenuName = IIF(TYPE("m.getMenuName")="C",m.getMenuName,SYS(2015))
      \IF TYPE("m.getMenuName")="L" AND m.getMenuName
      \   m.oFormRef.Name = m.cMenuName
      \ENDIF
      \DEFINE MENU (m.cMenuName) IN (m.oFormRef.Name) BAR
      \*
    SELECT TABMENU
    nNumberMenuPrin = 0
    SELECT TABMENU
    SCAN FOR INT(VAL(SUBSTR(CODIGO,3)))=0
      nNumberMenuPrin = nNumberMenuPrin + 1
      cDescripcion = ALLTRIM(TABMENU.descripc)
      =MESSAGEBOX("Creando Menú " + cDescripcion)
      cNamePad = "PAD" + PADL(ALLTRIM(STR(nNumberMenuPrin)),3,'0')
      \DEFINE PAD <<cNamePad>> OF (m.cMenuName) PROMPT "<<cDescripcion>>" COLOR SCHEME 4 KEY ALT+T, ""
    ENDSCAN
    SELECT LEFT(CODIGO,2) AS GRUPO FROM TABMENU GROUP BY 1 ORDER BY 1 INTO CURSOR _CrsOpciones
    nMenuTotal = RECCOUNT("_CrsOpciones")
    IF USED('_CrsOpciones')
      USE IN _CrsOpciones
    ENDIF
    nNumberMenuPrin = 0
    SELECT TABMENU
    SCAN FOR INT(VAL(SUBSTR(CODIGO,3)))=0
      nNumberMenuPrin = nNumberMenuPrin + 1
      cDescripcion = ALLTRIM(TABMENU.descripc)
      cNamePad   = "PAD" + PADL(ALLTRIM(STR(nNumberMenuPrin)),3,'0')
      cNamePopup = "P" + LEFT(TABMENU.CODIGO,2) &&& + PADL(ALLTRIM(STR(nNumberMenuPrin)),2,'0')
      \ON PAD <<cNamePad>> OF (m.cMenuName) ACTIVATE POPUP <<cNamePopup>>
    ENDSCAN

    * DEFINIENDO POPUS POR NIVELES
    nBarNivel = 0
    SELECT TABMENU
    GO TOP
    FOR nNiveles = 2 TO 6
      nSubStrCero = ((nNiveles+1)+nNiveles)
      nLeft = nSubStrCero-1
      nLeftNivelFactor = IIF(nNiveles=2,2,nNiveles*2)
      FOR nMenuPrin = 1 TO nMenuTotal
        SELECT * FROM TABMENU WHERE LEFT(TABMENU.CODIGO,2) = PADL(ALLTRIM(STR(nMenuPrin)),2,'0') AND ;
          INT(VAL(SUBSTR(TABMENU.CODIGO,nSubstrCero))) = 0 AND ;
          RIGHT(LEFT(TABMENU.CODIGO,nLeft),2) <> '00';
          INTO CURSOR _CrsConsultaSQL
        IF RECCOUNT('_CrsConsultaSQL')>0
          IF USED('_CrsConsultaSQL')
            USE IN _CrsConsultaSQL
          ENDIF
          nBarNivel = 0
          lEsPrimero = .T.
          SELECT TABMENU
          SCAN FOR LEFT(TABMENU.CODIGO,2)=PADL(ALLTRIM(STR(nMenuPrin)),2,'0') AND ;
              INT(VAL(SUBSTR(TABMENU.CODIGO,nSubstrCero))) = 0 AND ;
              RIGHT(LEFT(TABMENU.CODIGO,nLeft),2) <> '00'
            cTagNivelNamePad = LEFT(TABMENU.codigo,nLeftNivelFactor) &&& SUBSTR(TABMENU.codigo,3,2)
            IF lEsPrimero
              cPadNameNivel = "P" + cTagNivelNamePad
              \
              \DEFINE POPUP <<cPadNameNivel>> MARGIN RELATIVE SHADOW COLOR SCHEME 4
              lEsPrimero = .F.
            ENDIF
            cTagBar = ALLTRIM(TABMENU.DESCRIPC)
            nBarNivel = nBarNivel + 1
            \DEFINE BAR <<nBarNivel>> OF <<cPadNameNivel>> PROMPT "<<cTagBar>>"
          ENDSCAN
        ELSE
          IF USED('_CrsConsultaSQL')
            USE IN _CrsConsultaSQL
          ENDIF
        ENDIF
        nBarNivel = 0
        SELECT TABMENU
        SCAN FOR LEFT(TABMENU.CODIGO,2)=PADL(ALLTRIM(STR(nMenuPrin)),2,'0') AND ;
            INT(VAL(SUBSTR(TABMENU.CODIGO,nSubstrCero)))=0 AND ;
            RIGHT(LEFT(TABMENU.CODIGO,nLeft),2)<>'00'
          cTagBar = ALLTRIM(TABMENU.DESCRIPC)
          cTagCom = ALLTRIM(TABMENU.COMMAND)
          nBarNivel = nBarNivel + 1
          IF "ACTIVATE POPUP"$cTagCom
            \ON BAR <<nBarNivel>> OF <<cPadNameNivel>> <<cTagCom>>
          ELSE
            \ON SELECTION BAR <<nBarNivel>> OF <<cPadNameNivel>> <<cTagCom>>
          ENDIF
        ENDSCAN
      NEXT
    NEXT
    \ACTIVATE MENU (m.cMenuName) NOWAIT
    SET TEXTMERGE TO
    SET TEXTMERGE OFF
    COMPILE (THISFORM.cNameMenuMP+".MPR")
  ENDPROC
  PROCEDURE Previo
    SET TEXTMERGE ON
    cFileMenu = CURDIR() + "MENU.DBF"
    IF !FILE(cFileMenu)
      =MESSAGEBOX("No existe el archivo de Menú ...!"+CHR(13)+cFileMenu,16,"Error al cargar Form")
      RETURN .F.
    ENDIF
    USE (cFileMenu) IN 0 SHARED ALIAS TABMENU ORDER ORDEN
    THISFORM.cNameMenuMP = GETENV("TEMP")+"\"+"_" + RIGHT(SUBSTR(SYS(2015), 3),3) + RIGHT(SUBSTR(SYS(2015), 3),3) + RIGHT(SUBSTR(SYS(2015), 3),1)
    SET TEXTMERGE TO (THISFORM.cNameMenuMP+".MPR") NOSHOW
  ENDPROC
  PROCEDURE INIT
    DO (THISFORM.cNameMenuMP+".MPX") WITH THISFORM,.F.
    THISFORM.RESIZE()
  ENDPROC
  ADD OBJECT CmdSalir AS MyButtonQuit  WITH ;
    CAPTION = "\<Salir"
ENDDEFINE


DEFINE CLASS MyButtonQuit AS COMMANDBUTTON
  HEIGHT = 30
  WIDTH = 130
  TOP = 50
  LEFT = 100
  NAME = 'CmdSalir'
  CAPTION = '\<Salir'

  PROCEDURE CLICK
    IF MESSAGEBOX("¿Está seguro que desea Salir?",36,THISFORM.CAPTION) = 6
      CLEAR EVENTS
      THISFORM.RELEASE
    ENDIF
  ENDPROC
ENDDEFINE

PD: Se reciben sugerencias y comentarios. Muchas Gracias.

Jesús Rojas Cárdenas (Lima - Perú)