gentabmenu.prg

vfp巅峰制作(仿office2007),精典源码作品,不容错过

**************************************************************************************
*$PROGRAM$ GenTabMenu
*$CREATED$ 15/02/2007
**************************************************************************************
LPARAMETERS vcProjDBF, vnRecno

LOCAL llReturn

STORE .f. TO llReturn

IF PARAMETERS() = 2
  *-- We have the information we need to proceed.
  IF spSetUp(m.vcProjDBF, m.vnRecno)
    llReturn = spGenerate(m.vcProjDBF, m.vnRecno)
  ENDIF
  DO spCleanUp WITH m.llReturn
ELSE
  *-- Display the error message
  MESSAGEBOX("You have not passed the correct number of parameters.", 16, "Tab Menu Generator")
ENDIF

RETURN IIF(m.llReturn, 0, 1)

**************************************************************************************
*$FUNCTION$ spSetUp()
*$CREATED$ 15/02/2007
**************************************************************************************
FUNCTION spSetUp(vcProjDBF, vnRecno)
  LOCAL llReturn, lcOutFile, lnSelect, lcTmpFile
  
  llReturn  = .t.
  lnSelect  = 0
  lcOutFile = ""
  lcTmpFile = ""

  CLEAR PROGRAM
  CLEAR GETS
  
  *-- Open the project table again 
  SELECT 0
  USE (m.vcProjDBF) AGAIN
  lnSelect = SELECT()
  
  IF RECCOUNT() >= m.vnRecno
    GO m.vnRecno
    lcOutFile  = ALLTRIM(outfile)
  ELSE
    llReturn = .f.
  ENDIF
  
  *-- Close the project table opened here
  USE IN (m.lnSelect)
  
  *-- Create the cursor to hold the system menu data
  lcTmpFile = ADDBS(SYS(2023)) + SYS(2015)
  STRTOFILE(LOWER(STRTRAN(SYS(2013)," ",CHR(13))), lcTmpFile,0)
  
  SELECT 0
  CREATE CURSOR w_menudata (sysmenuname C(40))
  APPEND FROM (lcTmpFile) TYPE DELIMITED

  ERASE (lcTmpFile)

  IF m.llReturn
    SET TEXTMERGE TO (lcOutFile) NOSHOW
    SET TEXTMERGE ON
  ENDIF
  
  RETURN m.llReturn
ENDFUNC

**************************************************************************************
*$FUNCTION$ spCleanUp()
*$CREATED$ 15/02/2007
**************************************************************************************
FUNCTION spCleanUp(vlReturn)
  LOCAL llReturn, lcOutFile
  llReturn = .t.
  lcOutFile = SET("TEXTMERGE",2)
  
  IF USED("w_menudata")
    USE IN w_menudata
  ENDIF
    
  SET TEXTMERGE TO 
  SET TEXTMERGE OFF
  
  IF vlReturn = .f.
    *-- this means that something went wrong
    * so we should delete the output file
    ERASE (lcOutFile)
  ENDIF

  RETURN m.llReturn
ENDFUNC

**************************************************************************************
*$FUNCTION$ spGenerate()
*$CREATED$ 15/02/2007
**************************************************************************************
FUNCTION spGenerate(vcProjDBF, vnRecno)
  PRIVATE poMenuDefault
  
  LOCAL llReturn, lnSelect, lcMenuFile

  llReturn = .t.
  lnSelect = 0
  
  *-- Open the project table again 
  SELECT 0
  USE (m.vcProjDBF) AGAIN
  lnSelect = SELECT()
  
  IF RECCOUNT() >= m.vnRecno
    GO m.vnRecno
    lcMenuFile = ALLTRIM(name)
  ENDIF
  
  *-- Close the project table opened here
  USE IN (m.lnSelect)
  
  IF FILE(lcMenuFile)
    *-- Open the menu table
    SELECT 0
    USE (m.lcMenuFile) AGAIN
    lnSelect = SELECT()
    
    LOCATE FOR objtype = 1 AND ObjCode = 22
    IF FOUND()
      SCATTER MEMO NAME poMenuDefault
      
      *-- Add some additional properties to the default row
      ADDPROPERTY(poMenuDefault, "ExecuteEventCode", "")
      ADDPROPERTY(poMenuDefault, "DefEvent", "MenuDefault")
      ADDPROPERTY(poMenuDefault, "DefEventCode", "")
    ENDIF
    
    LOCATE FOR objtype = 2 AND objcode = 1
    IF FOUND()
      *-- Store any code attached to the system menu bar to the default event
      poMenuDefault.DefEventCode = ALLTRIM(procedure)
      
      *-- We are in a valid menu table so we should write out the header block
      llReturn = llReturn AND spProcessHeader()
      
      IF NOT EMPTY(poMenuDefault.SetUp) 
        *-- We need to create a setup code snippet
        llReturn = llReturn AND spProcessSetup()
      ENDIF
      
      *-- Begin the work of processing the menu data
      llReturn = llReturn AND spProcessMenu(m.lcMenuFile, 0, LevelName)

      IF NOT EMPTY(poMenuDefault.CleanUp) 
        *-- We need to create a cleanup code snippet
        llReturn = llReturn AND spProcessCleanup()
      ENDIF

      *-- Generate the footer
      llReturn = llReturn AND spProcessFooter()
    ENDIF
    
    *-- Close the menu table opened here
    USE IN (lnSelect)
  ENDIF
  
  *-- release the private variables used
  RELEASE poMenuDefault
  
  RETURN m.llReturn
ENDFUNC

**************************************************************************************
*$FUNCTION$ spProcessMenu()
*$CREATED$ 15/02/2007
**************************************************************************************
FUNCTION spProcessMenu(vcMenuFile, vnLevel, vcLevelName, vcItemKey, vnTabNumber)
  LOCAL llReturn, lcCursor, lnSelect, loMenuData, lnMenuFile, lnTabNumber, ;
        llDefPopup
  
  lnSelect    = SELECT()
  lcCursor    = "r" + SYS(2015)
  lnMenuFile  = 0
  vcItemKey   = IIF(EMPTY(vcItemKey),"",vcItemKey)
  lnTabNumber = IIF(EMPTY(vnTabNumber), 0, vnTabNumber)
  llReturn    = .t.
  llDefPopup  = .f.
  
  *-- Determine the top level menu data
  SELECT *, RECNO() AS itemrecno FROM (m.vcMenuFile) WHERE (LevelName = vcLevelName) AND (VAL(ItemNum) > 0) AND (ALLTRIM(prompt) <> "\-") INTO CURSOR (lcCursor)
  
  SCAN FOR NOT DELETED()
    SCATTER MEMO NAME loMenuData
    
    *-- Add the properties needed to the data
    ADDPROPERTY(loMenuData, "Submenu", .f.)
    ADDPROPERTY(loMenuData, "MarkExp", "")
    
    IF "\+" $ loMenuData.Prompt
      *-- The prompt indicates that the menu option has a submenu
      loMenuData.Submenu = .t.
    ENDIF
    
    IF "*:MARKEXP" $ UPPER(loMenuData.Comment)
      *-- The menu bar has additional directives in the comment
      * which need to be parsed and included in the menu data object
      loMenuData.MarkExp = spGetDirective("*:MARKEXP", loMenuData.Comment)
    ENDIF
    
    *-- Format the text
    loMenuData.Prompt = STRTRAN(loMenuData.Prompt, "\-", "")
    loMenuData.Prompt = STRTRAN(loMenuData.Prompt, "\+", "")
    loMenuData.Prompt = CHRTRAN(loMenuData.Prompt, "\<", "")
    
    IF EMPTY(loMenuData.Prompt)
      *-- No data here so skip it
      LOOP
    ENDIF

    loMenuData.KeyLabel = STRTRAN(UPPER(loMenuData.KeyLabel), "CTRL+", "")
    loMenuData.KeyLabel = STRTRAN(UPPER(loMenuData.KeyLabel), "ALT+", "")
    
    IF vnLevel = 0
      *-- Increment the tab number if we are on the top most level
      lnTabNumber = lnTabNumber + 1
    ENDIF
    *-- Build up the item key as a string based on the structure of the menu
    lcItemKey = vcItemKey + IIF(EMPTY(vcItemKey),"",".") + UPPER(CHRTRAN(loMenuData.Prompt," .",""))

    IF loMenuData.objtype = 3 AND loMenuData.objCode = 77
      *-- The way to determine this seems to be to position on the relevant menu record 
      * and then find the next popup record in the data
      SELECT 0
      USE (m.vcMenuFile) AGAIN
      lnMenuFile = SELECT()
      
      GO loMenuData.ItemRecno
      LOCATE REST FOR objtype = 2 AND objcode = 0
      IF FOUND() AND (numItems > 0 OR loMenuData.Submenu)
        IF loMenuData.Submenu AND vnLevel > 0
          *-- The submenu type is treated differently if the items has been marked to 
          * display a popup submenu so in this case the submenu needs to be processed 
          * slightly differently.  They are not allowed at the top level because it
          * does not make sense to have these kinds of controls as the page tabs
          IF vnLevel = 1 
            *-- We are in the level below the menu so we need to know if the
            * default popup has been created because commands or procedures at 
            * this level need to be added to that.
            IF NOT llDefPopup
              \*-- Add the <<ALLTRIM(vcLevelName)>> default popup
              \<<"loDefPopup = _SCREEN.oTabMenu.AddPopup(''," + ALLTRIM(STR(lnTabNumber,3,0)) + ")">>
              \<<"loDefPopup.nColumns = " + STR(INT(RECCOUNT(lcCursor)/3)+IIF(MOD(RECCOUNT(lcCursor),3) = 0,0,1),3,0)>>
              \<<"loDefPopup.Width = loDefPopup.nColumns * _SCREEN.oTabMenuHandler.nDefaultItemWidth">>
              \<<"loDefPopup.Alignment = _SCREEN.oTabMenuHandler.nDefaultAlignment">>
              llDefPopup = .t.
            ENDIF
            \<<"loPopup = loDefPopup">>
          ENDIF
          \
          \<<"loItem = loPopup.AddPopupItem('" + loMenuData.Prompt + "','NORM','" + loMenuData.keylabel + "')">>
          IF NOT EMPTY(loMenuData.ResName) AND loMenuData.SysRes <> 1
            \<<"loItem.cPicture = '" + loMenuData.ResName + "'">>
          ENDIF
          IF NOT EMPTY(loMenuData.SkipFor)
            \<<"loItem.cSkipForExp = [" + loMenuData.SkipFor + "]">>
          ENDIF
          IF NOT EMPTY(loMenuData.Message)
            \<<"loItem.ToolTipText = [" + loMenuData.Message + "]">>
          ENDIF
          IF NOT EMPTY(lcItemKey)
            \<<"loItem.cItemKey = '" + lcItemKey + "'">>
          ENDIF
          IF loMenuData.SubMenu
            \<<"loItem.nShowSubmenu = 1">>
          ENDIF    
          
          lcBindEvent = "u" + SYS(2015)
          
          *-- Call the function to create the submenu popup
          llReturn = llReturn AND spProcessSubMenu(m.vcMenuFile, loMenuData.ItemRecno, LEFT(ALLTRIM(Name) + SPACE(LEN(LevelName)), LEN(LevelName)), lcItemKey, lcBindEvent)
          
          \BINDEVENT(loItem, "Execute", _SCREEN.oTabMenuHandler, "<<lcBindEvent>>")        
                
        ELSE
          *-- This is a submenu so there are items below this one.  
          IF vnLevel = 0
            *-- These are the menu tabs
            \
            \*-- Add the <<loMenuData.Prompt>> Menu Tab
            \<<"loMenuTab = _SCREEN.oTabMenu.AddMenuItem('" + loMenuData.Prompt + "','" + loMenuData.keylabel + "')">>
          ELSE
            *-- These are the popups within the menu tabs
            \