ibmi-brunch-learn

Announcement

Collapse
No announcement yet.

QUSLOBJ example in free-format?

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • #16
    Re: QUSLOBJ example in free-format?

    So filled with questions about all this stuff.

    Alright, so if I call either the code Jamief provided, or what Michael provided using *FILE, I end up with all of the *FILE objects.

    How would I see if they're a source file?

    Comment


    • #17
      Re: QUSLOBJ example in free-format?

      chain to file QADBXREF and look at field DBXTYP = 'S' is source
      All my answers were extracted from the "Big Dummy's Guide to the As400"
      and I take no responsibility for any of them.

      www.code400.com

      Comment


      • #18
        Re: QUSLOBJ example in free-format?

        @ Tom - no i mentioned you cause I actually do love you!

        @ Michael - dude you really can write some sweet looking code.... Nice

        @ everyone else - party at my house -- get your own ride....

        jamie
        All my answers were extracted from the "Big Dummy's Guide to the As400"
        and I take no responsibility for any of them.

        www.code400.com

        Comment


        • #19
          Re: QUSLOBJ example in free-format?

          D'oh. This is what I get for getting wrapped up in APIs - I forget the basics.

          Thanks for that reminder, jamie.

          Comment


          • #20
            Re: QUSLOBJ example in free-format?

            list members



            jamie
            All my answers were extracted from the "Big Dummy's Guide to the As400"
            and I take no responsibility for any of them.

            www.code400.com

            Comment


            • #21
              Re: QUSLOBJ example in free-format?

              Ok, I stayed up last night and wrote a service program with a call back to handle the QUSLOBJ api. Here's what the sample program now looks like. (I'll post the service program and related copy members in the next post.)

              edit: stand by - I hav formatting issues.
              Last edited by MichaelCatalani; July 30, 2010, 11:49 AM.
              Michael Catalani
              IS Director, eCommerce & Web Development
              Acceptance Insurance Corporation
              www.AcceptanceInsurance.com
              www.ProvatoSys.com

              Comment


              • #22
                Re: QUSLOBJ example in free-format?

                we knew you had issues lol
                I'm not anti-social, I just don't like people -Tommy Holden

                Comment


                • #23
                  Re: QUSLOBJ example in free-format?

                  Originally posted by tomholden View Post
                  we knew you had issues lol
                  lol, yea. I'm ready to put about 11" of boot up Bill Gate's @#%@#%@#%.
                  Michael Catalani
                  IS Director, eCommerce & Web Development
                  Acceptance Insurance Corporation
                  www.AcceptanceInsurance.com
                  www.ProvatoSys.com

                  Comment


                  • #24
                    Re: QUSLOBJ example in free-format?

                    Ok, here's the program. I'll post the servce program and copy members in the next post. The only thing you would have to change is the H spec for the name of the binding directory that you place the service program into.


                    Code:
                     
                    [SIZE=2]h Option(*SrcStmt: *NoDebugIO) DftActGRP(*No) BndDir( 'CF') 
                     
                    [SIZE=2]/copy *libl/qrpglesrc,ObjlFormat                           [/SIZE]
                    [SIZE=2]/copy *libl/qrpglesrc,Api_p                                [/SIZE]
                     
                    [SIZE=2]d CallBackPTR     s               *   ProcPtr               [/SIZE]
                     
                    [SIZE=2]d ProcessList     pr              n                         [/SIZE]
                    [SIZE=2]d   Data                              LikeDS( OBJL0300 )    [/SIZE]
                     
                    [SIZE=2]/free                                                      [/SIZE]
                     
                    [SIZE=2] API_RetrieveObjectList(  '*ALL'                           [/SIZE]
                    [SIZE=2]                        : 'QGPL'                           [/SIZE]
                    [SIZE=2]                        : '*FILE'                          [/SIZE]
                    [SIZE=2]                        : %paddr( ProcessList )            [/SIZE]
                    [SIZE=2]                          );                               [/SIZE]
                     
                    [SIZE=2]   *inlr = *on;              [/SIZE]
                     
                    [SIZE=2]/end-free                                                 [/SIZE]
                     
                    [SIZE=2]p ProcessList     b                                        [/SIZE]
                    [SIZE=2]d ProcessList     pi              n                        [/SIZE]
                    [SIZE=2]d   Data                              LikeDS( OBJL0300 )   [/SIZE]
                    [SIZE=2]/free                                                     [/SIZE]
                     
                    [SIZE=2]   dsply Data.ObjectNameUsed;                             [/SIZE]
                    [SIZE=2]   dsply Data.LibraryUsed;                                [/SIZE]
                    [SIZE=2]   dsply %char(Data.Asp);                                 [/SIZE]
                    [SIZE=2]   dsply ' ';                                             [/SIZE]
                    [SIZE=2]   return *on;                                            [/SIZE]
                     
                    [SIZE=2]/end-free                                                 [/SIZE]
                    [SIZE=2]p                 e                                        [/SIZE]
                    [/SIZE]
                    Michael Catalani
                    IS Director, eCommerce & Web Development
                    Acceptance Insurance Corporation
                    www.AcceptanceInsurance.com
                    www.ProvatoSys.com

                    Comment


                    • #25
                      Re: QUSLOBJ example in free-format?

                      The QUSLOBJ api has several formats associated with it I placed formats OBJL0100, 200, and 300 in a copy member called OBJLFORMAT. There might be a couple of more formats that should be added here for the QUSLOBJ api, but I just included these 3.

                      Code:
                       
                       /if defined(ObjlFormat)                                         
                       /eof                                                            
                       /endif                                                          
                       
                       /define ObjlFormat                                              
                       
                       
                      d OBJL0100        DS                           Qualified Inz     
                      d  ObjectNameUsed...                                             
                      d                               10a                              
                      d  LibraryUsed                  10a                              
                      d  TypeUsed                     10a                              
                       
                      d OBJL0200        DS                           Qualified Inz     
                      d  ObjectNameUsed...                                             
                      d                               10a                              
                      d  LibraryUsed                  10a                              
                      d  TypeUsed                     10a                              
                      d  InformationStatus...                                          
                      d                                1a                             
                      d  ExtendedObjectAttribute...                                   
                      d                               10a                             
                      d  TextDescription...                                           
                      d                               50a                             
                      d  UserDefinedAttribute...                                      
                      d                               10a                             
                      d  Reserved                      7a                             
                       
                       
                      d OBJL0300        DS                           Qualified Inz    
                      d  ObjectNameUsed...                                            
                      d                               10a                             
                      d  LibraryUsed                  10a                             
                      d  TypeUsed                     10a                             
                      d  InformationStatus...                                         
                      d                                1a                             
                      d  ExtendedObjectAttribute...                                   
                      d                               10a                             
                      d  TextDescription...                                           
                      d                               50a        
                      d  UserDefinedAttribute...                 
                      d                               10a        
                      d  Reserved                      7a        
                      d  Asp                          10i 0      
                      d  ObjectOwner                  10a        
                      d  ObjectDomain                 10a        
                      d  CreationDateTime...                     
                      d                                8a        
                      d  ChangeDateTime...                       
                      d                                8a        
                      d  Storage                      10a        
                      d  CompressStatus...                       
                      d                                1a        
                      d  AllowChange                   1a        
                      d  ChangedByProgram...                     
                      d                                1a        
                      d ObjectAudit                    1a        
                      d DigitallySigned...                       
                      d                                1a        
                      d DigitallySignedMultiple...              
                      d                                1a       
                      d Reserved2                      2a       
                      d LibraryAsp                    10i 0
                      The ApiError copy member contains an error data structure that is used with all of the api's:

                      Code:
                      /if defined(ApiError)                                          
                      /eof                                                           
                      /endif                                                         
                       
                      /define ApiError                                               
                       
                       ApiError        Ds                  Inz qualified             
                        Bytes                        10i 0 Inz( %Size( ApiError ))   
                        BytesAvailable...                                            
                                                     10i 0 Inz                       
                        ErrorID                       7a   Inz                       
                        Reserved                      1a   Inz( x'00' )              
                        MessageData                 128a   Inz
                      The LISTHEADER copy member contains a data structure that describes the list header returned in a user space for all of the list api's. The list header contains items such as the number of entries returned frmo the list, the length of each list entry, and the starting offset of the first list item.


                      Code:
                       /if defined(ListHeader)                               
                       /eof                                                  
                       /endif                                                
                       
                       /define ListHeader                                    
                       
                      d ListHeaderDS    DS                   qualified       
                      d  UserArea                     64a                    
                      d  GenericHeaderSize...                                
                      d                               10i 0                  
                      d  ReleaseLevel...                                     
                      d                                4a                    
                      d  FormatName                    8a                    
                      d  ApiName                      10a                    
                      d  DateTime                     13a                    
                      d  CompletionStatus...                                 
                      d                                1a                    
                      d  SpaceUsed                    10i 0                  
                      d  InputOffset...                                      
                      d                               10i 0         
                      d  InputSize                    10i 0         
                      d  HeaderOffset...                            
                      d                               10i 0         
                      d  HeaderSize                   10i 0         
                      d  ListOffset                   10i 0         
                      d  ListSize                     10i 0         
                      d  ListCount                    10i 0         
                      d  EntrySize                    10i 0         
                      d  CCSID                        10i 0         
                      d  CountryID                     2a           
                      d  LanguageID                    3a           
                      d  Subset                        1a           
                      d  Reserved                     42a
                      The USERSPACE copy member contains prototypes for the User Space api's. I originally wrote this a decade or so ago, and recently updated to include long field names.

                      Code:
                       
                      [COLOR=#008080][SIZE=2][COLOR=#008080][SIZE=2][COLOR=#008080]//* * * * * * * * * * * * * * * * * * * * * * * * * * * *      [/COLOR][/SIZE]
                      [SIZE=2][COLOR=#008080]//                                                             [/COLOR][/SIZE]
                      [SIZE=2][COLOR=#008080]//   User Space Prototypes & Service Program                   [/COLOR][/SIZE]
                      [SIZE=2][COLOR=#008080]//   ©copyright 1998 Michael Catalani                          [/COLOR][/SIZE]
                      [SIZE=2][COLOR=#008080]//                                                             [/COLOR][/SIZE]
                      [SIZE=2][COLOR=#008080]//                                                             [/COLOR][/SIZE]
                      [SIZE=2][COLOR=#008080]//   L i s t    O f   P r o t o t y p e s                      [/COLOR][/SIZE]
                      [SIZE=2][COLOR=#008080]//                                                             [/COLOR][/SIZE]
                      [SIZE=2][COLOR=#008080]//   Procedure                    Description                  [/COLOR][/SIZE]
                      [SIZE=2][COLOR=#008080]//   UserSpace_Create             Prototype for QUSCRTUS       [/COLOR][/SIZE]
                      [SIZE=2][COLOR=#008080]//   UserSpace_Delete             Prototype for QUSDLTUS       [/COLOR][/SIZE]
                      [SIZE=2][COLOR=#008080]//   UserSpace_Retrieve           Prototype for QUSRTVUS       [/COLOR][/SIZE]
                      [SIZE=2][COLOR=#008080]//   UserSpace_Pointer...         Prototype for QUSPTRUS       [/COLOR][/SIZE]
                      [SIZE=2][COLOR=#008080]//                                                             [/COLOR][/SIZE]
                      [SIZE=2][COLOR=#008080]//* * * * * * * * * * * * * * * * * * * * * * * * * * * *      [/COLOR][/SIZE]
                       
                      [SIZE=2][COLOR=#008080]/if defined(UserSpace)                                           [/COLOR][/SIZE]
                      [SIZE=2][COLOR=#008080]/eof                                                             [/COLOR][/SIZE][/COLOR]
                      [/SIZE][/COLOR]/endif                                                             
                       
                       /define UserSpace                                                  
                       
                       /copy *libl/qrpglesrc,ApiError                                     
                       
                       
                       * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *        
                       *                                                                  
                       *  UserSpace_Create - Calls the QUSCRTUS (create User Space API)   
                       *                     Creates a User Space                         
                       *                                                                  
                       * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *        
                      d UserSpace_Create...                                               
                      d                 pr                  ExtPgm( 'QUSCRTUS' )          
                      d  UserSpace                    20a   Const                         
                      d  ExternalAttribute...                                             
                      d                               10A   Const                         
                      d  InitialSize...                                                   
                      d                               10I 0 Const                         
                      d  InitialValue...                                                  
                      d                                1A   Const                         
                      d  PublicAuthority...                                               
                      d                               10A   Const                         
                      d  Text                         50A   Const                         
                      d  Replace                      10A   Const                         
                      d  Error                              Like( ApiError )              
                       
                       * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *        
                       *                                                                  
                       *  UserSpace_Delete - Calls the QUSDLTUS (delete User Space API)   
                       *                     Deletes a User Space                         
                       *                                                                  
                       * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *        
                      d UserSpace_Delete...                                               
                      d                 pr                  ExtPgm( 'QUSDLTUS' )          
                      d  UserSpace                    20a   Const                         
                      d  Error                              Like( ApiError )              
                       
                       * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
                       *                                                                   
                       *  UserSpace_Retrieve - Calls the QUSRTVUS (retrive User Space API) 
                       *                       Retrieves data from a User Space            
                       *                                                                   
                       * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
                      d UserSpace_Retrieve...                                              
                      d                 pr                  ExtPgm( 'QUSRTVUS' )           
                      d  UserSpace                    20a   Const                          
                      d  StartPosition...                                                  
                      d                               10i 0                                
                      d  LengthOfData...                                                   
                      d                               10i 0                                
                      d  Receiver                  32767a   Options( *VarSize )            
                      d  Error                              Like( ApiError )               
                       
                       
                       * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *         
                       *                                                                   
                       *  UserSpace_Pointer - Calls the QUSPTRUS (retrieve pointer api)    
                       *                      Retrieves the pointer for the user space       
                       *                                                                     
                       * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *           
                      d UserSpace_Pointer...                                                 
                      d                                                                      
                      d                 pr                  ExtPgm( 'QUSPTRUS' )             
                      d  UserSpace                    20a   Const                            
                      d  Pointer                        *
                      Here's the prototype for the service program, which also includes the prototype for the QUSLOBJ api. They are in a member called API_S:

                      EDIT: I added the QUSRLMBR api, and added a prototype for API_RetrieveMemberList subprocedure.

                      Code:
                       /copy *libl/qrpglesrc,ApiError                              
                       
                      d API_ListObjects...                                         
                      d                 pr                  ExtPgm( 'QUSLOBJ' )    
                      d  UserSpace                    20a   Const                  
                      d  Format                        8a   Const                  
                      d  ObjectNameLib                20a   Const                  
                      d  ObjectType                   10a   Const                  
                      d  ErrorCode                          LikeDS( ApiError )     
                       
                      d API_ListMembers...                                         
                      d                 pr                  ExtPgm( 'QUSLMBR' )    
                      d  UserSpace                    20a   Const                  
                      d  Format                        8a   Const                  
                      d  ObjectNameLib                20a   Const                  
                      d  Member                       10a   Const                  
                      d  Override                      1a   Const                  
                      d  ErrorCode                          LikeDS(ApiError)       
                      d API_RetrieveObjectList...                                
                      d                 pr                                       
                      d   ObjectName                  10a   Const                
                      d   LibraryName                 10a   Const                
                      d   ObjectType                  10a   Const                
                      d   CallBackPTR                   *   ProcPtr Const        
                       
                      d API_RetrieveMemberList...                                
                      d                 pr                                       
                      d   ObjectName                  10a   Const                
                      d   LibraryName                 10a   Const                
                      d   CallBackPTR                   *   ProcPtr Const
                      And here's Jamies program which has been converted into a service program with a call back procedure.
                      The service program is called called API_S, and containes the subprocedure API_RetrieveObjectList, which is called by our sample program.
                      I removed all references to binary fields

                      EDIT: Added the List Member subprocedure.

                      Code:
                       
                      h nomain                                                         
                       
                       /copy *libl/qrpglesrc,UserSpace                                 
                       /copy *libl/qrpglesrc,ApiError                                  
                       /copy *libl/qrpglesrc,ListHeader                                
                       /copy *libl/qrpglesrc,ObjlFormat                                
                       /copy *libl/qrpglesrc,MbrlFormat                                
                       /copy *libl/qrpglesrc,Api_p                                     
                       
                      d SpaceValue      s              1    inz( *blanks )             
                      d SpaceAuthority  s             10    inz( '*CHANGE' )           
                      d SpaceText       s             50    inz( *blanks )             
                      d SpaceReplace    s             10    inz( '*YES' )              
                      d SpaceAttribute  s             10    inz( *blanks )             
                       
                      p API_RetrieveObjectList...                                      
                      p                 b                   export                     
                      d API_RetrieveObjectList...                                      
                      d                 pi                                             
                      d   ObjectName                  10a   Const                             
                      d   LibraryName                 10a   Const                             
                      d   ObjectType                  10a   Const                             
                      d   CallBackPTR                   *   ProcPtr  Const                    
                       
                       
                       
                      D CallBack        pr              n   ExtProc( CallBackPTR )            
                      d   Data                              LikeDS( OBJL0300 )                
                       
                      d Count           s             10i 0                                   
                      d Format          s              8                                      
                       
                      d UserSpaceName   s             10a                                     
                      d UserSpaceLib    s             10a                                     
                      d StartPosition   s             10i 0                                   
                      d RetrieveLength  s             10i 0                                   
                       
                       /free                                                                  
                       
                         //                                                      
                        //  Create The User Space                               
                        //                                                      
                       
                        UserSpaceName = 'LISTOBJ';                              
                        UserSpaceLib  = 'QTEMP';                                
                       
                        UserSpace_Create(  UserSpaceName + UserSpaceLib         
                                         : SpaceAttribute                       
                                         : 4096                                 
                                         : SpaceValue                           
                                         : SpaceAuthority                       
                                         : SpaceText                            
                                         : SpaceReplace                         
                                         : ApiError );                          
                       
                          //                                                    
                          // Place object entries into the user space           
                          //                                                    
                                                                                
                          reset ApiError;                                       
                                                                                
                          API_ListObjects(  UserSpaceName + UserSpaceLib        
                                          : 'OBJL0300'                          
                                          : ObjectName + LibraryName            
                                          : ObjectType                          
                                          : ApiError                            
                                            );                                  
                                                                                
                         if ApiError.ErrorID <> *blanks;                        
                           return;                                              
                         endif;                                                 
                                                                                
                          //                                                                     
                          // Retrieve header entry to get the starting offset position of the    
                          // list entries, and the length of each entry                          
                          //                                                                     
                       
                          StartPosition  = 1;                                                    
                          RetrieveLength = %size( ListHeaderDS );                                
                       
                          UserSpace_Retrieve(  UserSpaceName + UserSpaceLib                      
                                             : StartPosition                                     
                                             : RetrieveLength                                    
                                             : ListHeaderDS                                      
                                             : ApiError                                          
                                               );                                  
                       
                          StartPosition  = ListHeaderDS.ListOffset + 1;            
                          RetrieveLength = %size( OBJL0300 );                      
                       
                          //                                                       
                          // Do for number of entries in the userspace             
                          //                                                       
                       
                          for count = 1 to ListHeaderDS.ListCount;                 
                            UserSpace_Retrieve(  UserSpaceName + UserSpaceLib      
                                               : StartPosition                     
                                               : RetrieveLength                    
                                               : OBJL0300                          
                                               : ApiError                          
                                                 );                                
                       
                            if NOT CallBack( OBJL0300 );                           
                              return;                                              
                            endif;                                                 
                       
                            StartPosition += ListHeaderDS.EntrySize;                   
                       
                          endfor;                                                      
                       
                          UserSpace_Delete(  UserSpaceName + UserSpaceLib              
                                           : ApiError                                  
                                             );                                        
                       
                          return;                                                      
                       
                       /end-free                                                       
                      p                 e                                              
                       
                      p API_RetrieveMemberList...                                      
                      p                 b                   export                     
                      d API_RetrieveMemberList...                                      
                      d                 pi                                             
                      d   ObjectName                  10a   Const                      
                      d   LibraryName                 10a   Const                      
                      d   CallBackPTR                   *   ProcPtr  Const             
                       
                       
                       
                      D CallBack        pr              n   ExtProc( CallBackPTR )     
                      d   Data                              LikeDS( MBRL0200 )         
                       
                      d Count           s             10i 0                            
                      d Format          s              8                               
                       
                      d UserSpaceName   s             10a                              
                      d UserSpaceLib    s             10a                              
                      d StartPosition   s             10i 0                            
                      d RetrieveLength  s             10i 0                            
                       
                       /free                                                           
                       
                        //                                                             
                        //  Create The User Space                                      
                        //                                                             
                       
                       UserSpaceName = 'LISTMEMBER';                             
                       UserSpaceLib  = 'QTEMP';                                  
                       
                       UserSpace_Create(  UserSpaceName + UserSpaceLib           
                                        : SpaceAttribute                         
                                        : 4096                                   
                                        : SpaceValue                             
                                        : SpaceAuthority                         
                                        : SpaceText                              
                                        : SpaceReplace                           
                                        : ApiError );                            
                       
                          //                                                         
                          // Place members into User Space                           
                          //                                                         
                                                                                     
                          reset ApiError;                                            
                                                                                     
                          API_ListMembers(  UserSpaceName + UserSpaceLib             
                                          : 'MBRL0200'                               
                                          : ObjectName + LibraryName                 
                                          : '*ALL'                                   
                                          : '0'                                      
                                          : ApiError                                 
                                            );                                       
                                                                                     
                         if ApiError.ErrorID <> *blanks;                             
                           return;                                                   
                         endif;                                                      
                                                                                     
                                                             
                       
                          //                                                                  
                          // Retrieve header entry to get the starting offset position of the 
                          // list entries, and the length of each entry                       
                          //                                                                  
                       
                          StartPosition  = 1;                                                 
                          RetrieveLength = %size( ListHeaderDS );                             
                       
                          UserSpace_Retrieve(  UserSpaceName + UserSpaceLib                   
                                             : StartPosition                                  
                                             : RetrieveLength                                 
                                             : ListHeaderDS                                   
                                             : ApiError                                       
                                               );                                             
                       
                          StartPosition  = ListHeaderDS.ListOffset + 1;               
                          RetrieveLength = %size( MBRL0200 );                         
                       
                          //                                                          
                          // Do for number of entries in the userspace                
                          //                                                          
                       
                          for count = 1 to ListHeaderDS.ListCount;                    
                            UserSpace_Retrieve(  UserSpaceName + UserSpaceLib         
                                               : StartPosition                        
                                               : RetrieveLength                       
                                               : MBRL0200                             
                                               : ApiError                             
                                                 );                                   
                       
                            if NOT CallBack( MBRL0200 );                              
                              return;                                                 
                            endif;                                                    
                       
                            StartPosition += ListHeaderDS.EntrySize;                  
                       
                       
                          endfor;                                            
                       
                          UserSpace_Delete(  UserSpaceName + UserSpaceLib    
                                           : ApiError                        
                                             );                              
                       
                          return;                                            
                       
                       /end-free                                             
                      p                 e
                      And finally the binder source, in a member called API_S, which should be in QSRVSRC source file.

                      Code:
                                   STRPGMEXP  SIGNATURE('API_S')                 
                                      EXPORT     SYMBOL(API_RetrieveObjectList)  
                                      EXPORT     SYMBOL(API_RetrieveMemberList)  
                                   ENDPGMEXP
                      Last edited by MichaelCatalani; July 30, 2010, 03:54 PM.
                      Michael Catalani
                      IS Director, eCommerce & Web Development
                      Acceptance Insurance Corporation
                      www.AcceptanceInsurance.com
                      www.ProvatoSys.com

                      Comment


                      • #26
                        Re: QUSLOBJ example in free-format?

                        Am I limited to only having one user space at a time in a program?

                        Trying to create a second one which is identical to the first, but with a different name, ends in an error.

                        EDIT: Never mind. Was a dumb code mistake in how my data structures were set up.

                        Comment


                        • #27
                          Re: QUSLOBJ example in free-format?

                          I cleaned up the service program and added the list member api to it. (I also added it to the prototype API_P and the binder source API_S)

                          The list member needed another copy member for it's formats. It's named MBRLFORMAT:

                          Code:
                           /if defined(MbrlFormat)                                            
                           /eof                                                               
                           /endif                                                             
                                                                                              
                           /define MbrlFormat                                                 
                                                                                              
                                                                                              
                          d MBRL0100        ds                           Qualified Inz        
                          d  MemberName                   10a                                 
                                                                                              
                          d MBRL0200        ds                           Qualified Inz        
                          d  MemberName                   10a                                 
                          d  SourceType                   10a                                 
                          d  CreationDateTime...                                              
                          d                               13a                                 
                          d  ChangeDateTime...                                                
                          d                               13a                                 
                          d  MemberDescription...
                          Here's the DDS code for a simple subfile that can allow entry of a file and library, that will then display the members contained within it.

                          Code:
                               A*%%TS  SD  20100730  160028  QPGMR       REL-V6R1M0  5761-WDS     
                               A*%%EC                                                             
                               A                                      DSPSIZ(27 132 *DS4)         
                               A                                      CF03(03)                    
                               A          R ASSUME                                                
                               A*%%TS  SD  20070908  212514  QSECOFR     REL-V5R4M0  5722-WDS     
                               A                                      ASSUME                      
                               A                                  1  4' '                         
                               A          R SFLA                      SFL                         
                               A*%%TS  SD  20100730  160028  QPGMR       REL-V6R1M0  5761-WDS     
                               A            MEMBER        10   O  5  2                            
                               A            TYPE          10A  O  5 14                            
                               A            DESC          40A  O  5 26                            
                               A          R SFLB                      SFLCTL(SFLA)                
                               A*%%TS  SD  20100730  152747  QPGMR       REL-V6R1M0  5761-WDS     
                               A                                      ROLLUP(80)                  
                               A  90                                  SFLDSP                      
                               A                                      SFLDSPCTL                   
                               A  91                                  SFLCLR                      
                               A  92                                  SFLEND(*MORE)                        
                               A                                      SFLSIZ(0011)                         
                               A                                      SFLPAG(0010)                         
                               A                                      WINDOW(5 10 16 75)                   
                               A                                      WDWBORDER((*COLOR BLU) (*DSPATR RI)- 
                               A                                       (*CHAR '        '))                 
                               A            PGRRN          4S 0H      SFLRCDNBR                            
                               A                                  1  2'File Name:'                         
                               A                                  2  2'Library..:'                         
                               A            FILENAME      10   B  1 14COLOR(WHT)                           
                               A            LIBRARY       10   B  2 14COLOR(WHT)                           
                               A                                  4  1'Member Name'                        
                               A                                      COLOR(PNK)                           
                               A                                      DSPATR(UL)                           
                               A                                  4 13'Source Type'                        
                               A                                      COLOR(PNK)                           
                               A                                      DSPATR(UL)                           
                               A                                  4 26'Description                       - 
                               A                                                      '                    
                               A                                      COLOR(PNK)                           
                               A                                      DSPATR(UL)
                          And here's a cheap subfile program to do the job:

                          Code:
                          h DftActGrp(*no) BndDir('CF')                                
                                                                                       
                                                                                       
                          fListMemD  cf   e             workstn                        
                          f                                     SFILE(SFLA:pgrrn)      
                                                                                       
                           /copy *libl/qrpglesrc,MbrlFormat                            
                           /copy *libl/qrpglesrc,API_P                                 
                                                                                       
                          d pgrrn           s              4s 0                        
                          d SaveLib         s                   Like( Library )        
                          d SaveFile        s                   Like( FileName )       
                                                                                       
                                                                                       
                          d CallBackPTR     s               *   ProcPtr                
                                                                                       
                          d LoadSubFile     pr              n                          
                          d   Data                              LikeDS( MBRL0200 )     
                           /free                                                       
                                                                                       
                                                                                      
                                                                                      
                           dow NOT *in03;                                             
                                                                                      
                             exfmt sflb;                                              
                             if *in03 = *on;                                          
                               leave;                                                 
                             endif;                                                   
                                                                                      
                             if Library <> SaveLib or FileName <> SaveFile;           
                               SaveLib = Library;                                     
                               SaveFile = FileName;                                   
                               exsr ClearSubFile;                                     
                                                                                      
                               API_RetrieveMemberList(  FileName                      
                                                      : Library                       
                                                      : %paddr( LoadSubFile )         
                                                        );                            
                               if pgrrn > 0;                                          
                                 *in90 = *on;      
                                else;                                                        
                                  *in90 = *off;                                              
                                endif;                                                       
                                *in92 = *on;                                                 
                                pgrrn = 1;                                                   
                              endif;                                                         
                            enddo;                                                           
                            *inlr = *on;                                                     
                                                                                             
                             //******************************************************        
                             //   @ C L E A R   S U B R O U T I N E                          
                             //******************************************************        
                                                                                             
                            begsr ClearSubfile;                                              
                              *in91 = *on;                                                   
                              write sflb;                                                    
                              *in91 = *off;                                                  
                              *in92 = *off;                                                  
                              pgrrn = 0;                                                     
                            endsr;                                                           
                                                                                     
                           /end-free                                                 
                                                                                     
                          p LoadSubFile     b                                        
                          d LoadSubFile     pi              n                        
                          d   Data                              LikeDS( MBRL0200 )   
                                                                                     
                           /free                                                     
                                                                                     
                              if pgrrn <> 9999;                                      
                                                                                     
                                pgrrn += 1;                                          
                                                                                     
                                Member = Data.MemberName;                            
                                Type = Data.SourceType;                              
                                Desc = Data.MemberDescription;                       
                                write sfla;                                          
                              endif;                                                 
                                                                                     
                              return *on;                                            
                                                          
                           /end-free                      
                          p                 e
                          Michael Catalani
                          IS Director, eCommerce & Web Development
                          Acceptance Insurance Corporation
                          www.AcceptanceInsurance.com
                          www.ProvatoSys.com

                          Comment


                          • #28
                            Re: QUSLOBJ example in free-format?

                            @#%@#%@#%@#% Michael you are like a doberman with a bag of half frozen ground beef...
                            (Ive actually seen this )
                            All my answers were extracted from the "Big Dummy's Guide to the As400"
                            and I take no responsibility for any of them.

                            www.code400.com

                            Comment


                            • #29
                              Re: QUSLOBJ example in free-format?

                              lol, yea, I just wanted to take a break from everything else and do some "fun coding" for a few hours
                              Michael Catalani
                              IS Director, eCommerce & Web Development
                              Acceptance Insurance Corporation
                              www.AcceptanceInsurance.com
                              www.ProvatoSys.com

                              Comment

                              Working...
                              X