|
midrange.com
Dale,
>I did a scan for QsnQryModSup on all of my source, and did turn up this
>source, which I wisely saved as a member named DET27X132 in my source file -
>the credit goes to Doug Handy:
For the record, the prototype Dale reposted had two arguments coded as *NoPass
which should have been coded as *Omit. Depending on what happened to be on the
stack, this could potentially cause problems if the arguments were not passed.
Since I've had private requests for what I use, I'm posting relevant portions of
the code below. The code was written to support a V3R2 client, so it doesn't
use compiler directives like /DEFINE, names are limited to 10 chars, and it
returns 1A character values which really should be type N indicator values. In
the code below, I've only changed return values to N where applicable. Using
/DEFINE is left as an excercise for the reader. <g>
Most of the subprocedures do not require an argument, but since RPG IV doesn't
allow you to append empty () to a proc name (yet!), I typically define an
optional/omissible dummy argument to make it clear a procedure is being called
as opposed to a variable being referenced, e.g.
C If Is27x132OK( *Omit )
C ...
C Else
C ...
C Endif
The same thing could be coded leaving out the ( *Omit ) if desired.
First the prototypes (put into a /COPY member):
* Prototype to determine if device is capable of 27x132 mode
D Is27x132OK PR N
D Dummy 1A Options( *NoPass: *Omit )
* Prototype to determine if device is capable of 24x80 mode
D Is24x80OK PR N
D Dummy 1A Options( *NoPass: *Omit )
* Prototype to check if a given screen mode is valid. The
* first argument, Mode, can be '3' for 24x80 or '4' for 27x132.
D ChkScrMode PR N
D Mode 1A Const
* Prototype to retrieve current screen mode (3=24x80; 4=27x132)
D RtvScrMode PR 1A
D Dummy 1A Options( *NoPass: *Omit )
* Prototype to retrieve current screen dimensions
D RtvScrDim PR
D Rows 5I 0
D Cols 5I 0
* Prototype to determine if WS supports color
D IsColorDev PR N
D Dummy 1A Options( *NoPass: *Omit )
* Prototype to determine if WS supports extended foreground colors
D IsExtColor PR N
D Dummy 1A Options( *NoPass: *Omit )
* Prototype to determine if WS supports Write Extended Attribute
D IsWeaDev PR N
D Dummy 1A Options( *NoPass: *Omit )
* Prototype to determine if WS ctl supports Enhanced User Interface
D IsEuiCtl PR N
D Dummy 1A Options( *NoPass: *Omit )
* Prototype to determine if WS uses GUI-like characters
D IsGuiDev PR N
D Dummy 1A Options( *NoPass: *Omit )
* Prototype to determine if WS has a pointer device available
D HasMouse PR N
D Dummy 1A Options( *NoPass: *Omit )
Then here is the service program source to go with it:
H NoMain
H Option(*SrcStmt: *NoDebugIO)
* DS used by QsnQry5250 receiver variable
D QryRcvDS DS
D QryBytRtn 10I 0
D QryBytAvl 10I 0
D QryStatus 1A
D QryWsCtlU 5I 0
D QryCodeLvl 3A
D 16A
D QryWsType 1A
D QryMchType 4A
D QryModel 3A
D QryKbdID 1A
D QryExtKbd 1A
D QryPcKbd 1A
D QrySerial 4A
D QryMaxInp 5I 0
D QryCtlUCst 2A
D 1A
D QryDevCap 12A
D QryDev1 1A Overlay(QryDevCap:1)
D QryDev2 1A Overlay(QryDevCap:2)
D QryDev3 1A Overlay(QryDevCap:3)
D QryDev4 1A Overlay(QryDevCap:4)
D QryDev5 1A Overlay(QryDevCap:5)
D QryDev6 1A Overlay(QryDevCap:6)
D QryDev7 1A Overlay(QryDevCap:7)
D QryDev8 1A Overlay(QryDevCap:8)
D QryDev9 1A Overlay(QryDevCap:9)
D QryDev10 1A Overlay(QryDevCap:10)
D QryDev11 1A Overlay(QryDevCap:11)
D QryDev12 1A Overlay(QryDevCap:12)
D QryGridBuf 1A
D 9A
D QryRcvLen S 10I 0 Inz( %size( QryRcvDS ))
D ApiErrorDS DS
D ErrBytPrv 10I 0 Inz( %size( ApiErrorDS ) )
D ErrBytAvl 10I 0 Inz( 0 )
D ErrMsgID 7A
D 1A
D ErrMsgDta 256A
D Qry5250 PR ExtProc( 'QsnQry5250' )
D RcvVar Like( QryRcvDS )
D RcvVarLen 10I 0
D ErrorDS Like( ApiErrorDS )
D/Copy (prototypes listed above; whatever you called it)
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
* Procedure to determine if device is capable of 27x132 mode
P Is27x132OK B Export
D Is27x132OK PI N
D Dummy 1A Options( *NoPass: *Omit )
C Return ChkScrMode( '4' )
P Is27x132OK E
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
* Procedure to determine if device is capable of 24x80 mode
P Is24x80OK B Export
D Is24x80OK PI N
D Dummy 1A Options( *NoPass: *Omit )
C Return ChkScrMode( '3' )
P Is24x80OK E
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
* Procedure to check if a given screen mode is valid. The
* first argument, Mode, can be '3' for 24x80 or '4' for 27x132.
P ChkScrMode B Export
D ChkScrMode PI N
D Mode 1A Const
D IsValid S 1A
D QryMode PR ExtProc( 'QsnQryModSup' )
D DspMode 1A Const
D IsValid N
D Handle 10I 0 Options( *Omit )
D ErrorDS Options( *Omit: *Varsize )
D Like( ApiErrorDS )
C Callp QryMode( Mode: IsValid: *Omit: *Omit )
C Return IsValid
P ChkScrMode E
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
* Procedure to retrieve current screen mode (3=24x80; 4=27x132)
P RtvScrMode B Export
D RtvScrMode PI 1A
D Dummy 1A Options( *NoPass: *Omit )
D RtvMode PR ExtProc( 'QsnRtvMod' )
D DspMode 1A
D Handle 10I 0 Options( *Omit )
D ErrorDS Options( *Omit: *Varsize )
D Like( ApiErrorDS )
D CurMode S 1A Inz( '0' )
C Callp RtvMode( CurMode: *Omit: *Omit )
C Return CurMode
P RtvScrMode E
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
* Procedure to retrieve current screen dimensions
P RtvScrDim B Export
D RtvScrDim PI
D Rows 5I 0
D Cols 5I 0
D R S 10I 0
D C S 10I 0
D RtvSize PR ExtProc( 'QsnRtvScrDim' )
D NumRow 10I 0
D NumCol 10I 0
D Handle 10I 0 Options( *Omit )
D ErrorDS Options( *Omit: *Varsize )
D Like( ApiErrorDS )
C Callp RtvSize( R: C: *Omit: *Omit )
C Eval Rows = R
C Eval Cols = C
C Return
P RtvScrDim E
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
* Procedure to determine if WS supports color
P IsColorDev B Export
D IsColorDev PI N
D Dummy 1A Options( *NoPass: *Omit )
D QryColor PR ExtProc( 'QsnQryColorSup' )
D Color N
D Handle 10I 0 Options( *Omit )
D ErrorDS Options( *Omit: *Varsize )
D Like( ApiErrorDS )
D IsColor S N Inz( '0' )
C Callp QryColor( IsColor: *Omit: *Omit )
C Return IsColor
P IsColorDev E
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
* Procedure to determine if WS supports extended foreground colors
P IsExtColor B Export
D IsExtColor PI N
D Dummy 1A Options( *NoPass: *Omit )
D TempChar S 1A
C Callp Qry5250( QryRcvDS: QryRcvLen: ApiErrorDS )
C Eval TempChar = QryDev3
C Bitoff '012345' TempChar
C If TempChar = x'02'
C Return *On
C Else
C Return *Off
C Endif
P IsExtColor E
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
* Procedure to determine if WS supports Write Extended Attribute
P IsWeaDev B Export
D IsWeaDev PI N
D Dummy 1A Options( *NoPass: *Omit )
C Callp Qry5250( QryRcvDS: QryRcvLen: ApiErrorDS )
C Testb '5' QryDev3 90
C Return *In90
P IsWeaDev E
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
* Procedure to determine if WS ctl supports Enhanced User Interface
P IsEuiCtl B Export
D IsEuiCtl PI N
D Dummy 1A Options( *NoPass: *Omit )
C Callp Qry5250( QryRcvDS: QryRcvLen: ApiErrorDS )
C Testb '6' QryDev5 90
C Return *In90
P IsEuiCtl E
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
* Procedure to determine if WS uses GUI-like characters
P IsGuiDev B Export
D IsGuiDev PI N
D Dummy 1A Options( *NoPass: *Omit )
C Callp Qry5250( QryRcvDS: QryRcvLen: ApiErrorDS )
C Testb '5' QryDev5 90
C Return *In90
P IsGuiDev E
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
* Procedure to determine if WS has a pointer device available
P HasMouse B Export
D HasMouse PI N
D Dummy 1A Options( *NoPass: *Omit )
C Callp Qry5250( QryRcvDS: QryRcvLen: ApiErrorDS )
C Testb '4' QryDev5 90
C Return *In90
P HasMouse E
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A few lines may have word wrapped in the message body, but fit on one line in a
source member. The TESTB operations have the indicator in columns 75-76 (EQ).
Doug
+---
| This is the RPG/400 Mailing List!
| To submit a new message, send your mail to RPG400-L@midrange.com.
| To subscribe to this list send email to RPG400-L-SUB@midrange.com.
| To unsubscribe from this list send email to RPG400-L-UNSUB@midrange.com.
| Questions should be directed to the list owner/operator: david@midrange.com
+---
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2024 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
