home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
S12780.ZIP
/
GENERAL.BAS
< prev
next >
Wrap
BASIC Source File
|
1990-10-25
|
12KB
|
367 lines
'============================================================================
'
' GENERAL.BAS - General Routines for the User Interface Toolbox in
' Microsoft BASIC 7.1, Professional Development System
' Copyright (C) 1987-1990, Microsoft Corporation
'
' NOTE: This sample source code toolbox is intended to demonstrate some
' of the extended capabilities of Microsoft BASIC 7.1 Professional
' Development system that can help to leverage the professional
' developer's time more effectively. While you are free to use,
' modify, or distribute the routines in this module in any way you
' find useful, it should be noted that these are examples only and
' should not be relied upon as a fully-tested "add-on" library.
'
' PURPOSE: These are the general purpose routines needed by the other
' modules in the user interface toolbox.
'
' NOTE: These routines have been modified to support under OS/2 both
' full-screen and windowed command prompts using OS/2 API functions
' to provide similar effect to the DOS based code.
'
' All sections of code that have been modified will have a comment
' preseeding the modifications in the following manner :
'
' '| --- Modified to support OS/2 changes ---
' '|
' '| Description of changes
' '| ----------------------
' '|
'
' THIS IS SAMPLE CODE AND IS NOT TO BE CONSIDERED A COMPLETE BUG FREE
' PACKAGE. THIS CODE IS DESIGNED SPECIFICALLY TO RUN UNDER OS/2 PROTECTED
' MODE. THE ORIGINAL CODE HAS NOT BEEN MODIFIED IN ANY WAY, EXCEPT TO
' PROVIDE THIS FUNCTIONALITY.
'
'
'============================================================================
DEFINT A-Z
'$INCLUDE: 'general.bi'
'$INCLUDE: 'mouse.bi'
'| --- Modified to support OS/2 changes ---
'|
'| Description of changes
'| ----------------------
'|
'| Added module global variables to be used by the OS/2 Keyboard handlers
'| for GetShiftState function.
'|
COMMON SHARED /APIKeys/ KeyBoardOpen as integer
COMMON SHARED /APIKeys/ KeyBoardHandle as integer
'| Added TYPE...END TYPE's to be used with the OS/2 API calls
TYPE tCell
Char as string * 1
Attr as string * 1
END TYPE
TYPE tKbdPeek
chChar as string * 1
chScan as string * 1
Status as string * 1
Reserved as string * 1
ShiftState as integer
TimeStamp as long
END TYPE
Type tKbdGetStatus
cb as integer
mask as integer
turnaround as integer
interim as integer
state as integer
end type
'| DECLARE Statements for OS/2 Keyboard API functions
DECLARE FUNCTION KbdPeek% ( SEG pvData AS tKbdPeek, _
BYVAL hDevice as integer _
)
DECLARE FUNCTION KbdFreeFocus% ( BYVAL hDevice as integer )
DECLARE FUNCTION KbdGetFocus% ( BYVAL fWait as integer, _
BYVAL hDevice as integer _
)
DECLARE FUNCTION kbdOpen% ( SEG hDevice as integer )
DECLARE FUNCTION KbdGetStatus% ( SEG pvData as tKbdGetStatus, _
BYVAL hDevice as Integer _
)
'| Declare Statement for OS/2 Video I/O API functions
DECLARE FUNCTION VioScrollUp% ( BYVAL ULRow as Integer, _
BYVAL ULCOL as Integer, _
BYVAL LRRow as Integer, _
BYVAL LRCol as Integer, _
BYVAL Lines as Integer, _
SEG Cell as tCell, _
BYVAL VideoHandle as Integer _
)
DECLARE FUNCTION VioScrollDn% ( BYVAL ULRow as Integer, _
BYVAL ULCOL as Integer, _
BYVAL LRRow as Integer, _
BYVAL LRCol as Integer, _
BYVAL Lines as Integer, _
SEG Cell as tCell, _
BYVAL VideoHandle as Integer _
)
FUNCTION AltToASCII$ (kbd$)
' =======================================================================
' Converts Alt+A to A,Alt+B to B, etc. You send it a string. The right
' most character is compared to the string below, and is converted to
' the proper character.
' =======================================================================
index = INSTR("xyz{|}~Çü !" + CHR$(34) + "#$%&,-./012éâ", RIGHT$(kbd$, 1))
IF index = 0 THEN
AltToASCII = ""
ELSE
AltToASCII = MID$("1234567890QWERTYUIOPASDFGHJKLZXCVBNM-=", index, 1)
END IF
END FUNCTION
SUB Box (row1, col1, row2, col2, fore, back, border$, fillFlag) STATIC
'=======================================================================
' Use default border if an illegal border$ is passed
'=======================================================================
IF LEN(border$) < 9 THEN
t$ = "┌─┐│ │└─┘"
ELSE
t$ = border$
END IF
' =======================================================================
' Check coordinates for validity, then draw box
' =======================================================================
IF col1 <= (col2 - 2) AND row1 <= (row2 - 2) AND col1 >= MINCOL AND row1 >= MINROW AND col2 <= MAXCOL AND row2 <= MAXROW THEN
MouseHide
BoxWidth = col2 - col1 + 1
BoxHeight = row2 - row1 + 1
LOCATE row1, col1
COLOR fore, back
PRINT LEFT$(t$, 1); STRING$(BoxWidth - 2, MID$(t$, 2, 1)); MID$(t$, 3, 1)
LOCATE row2, col1
PRINT MID$(t$, 7, 1); STRING$(BoxWidth - 2, MID$(t$, 8, 1)); MID$(t$, 9, 1);
FOR a = row1 + 1 TO row1 + BoxHeight - 2
LOCATE a, col1
PRINT MID$(t$, 4, 1);
IF fillFlag THEN
PRINT STRING$(BoxWidth - 2, MID$(t$, 5, 1));
ELSE
LOCATE a, col1 + BoxWidth - 1
END IF
PRINT MID$(t$, 6, 1);
NEXT a
LOCATE row1 + 1, col1 + 1
MouseShow
END IF
END SUB
SUB GetBackground (row1, col1, row2, col2, buffer$) STATIC
' =======================================================================
' Create enough space in buffer$ to hold the screen info behind the box
' Then, call GetCopyBox to store the background in buffer$
' =======================================================================
IF row1 >= 1 AND row2 <= MAXROW AND col1 >= 1 AND col2 <= MAXCOL THEN
Wid = col2 - col1 + 1
Hei = row2 - row1 + 1
size = 4 + (2 * Wid * Hei)
buffer$ = SPACE$(size)
CALL GetCopyBox(row1, col1, row2, col2, buffer$)
END IF
END SUB
'| --- Modified to support OS/2 changes ---
'|
'| Description of changes
'| ----------------------
'|
'| Added OpenKeyboard Function to open the keyboard and reduce the size
'| of GetShiftState function.
Function OpenKeyBoard%
If NOT KeyBoardOpen then
Rtn% = KbdOpen% (KeyBoardHandle)
if NOT Rtn% then
KeyBoardOpen = TRUE
End if
End if
OpenKeyBoard% = KeyBoardOpen
END Function
'| --- Modified to support OS/2 changes ---
'|
'| Description of changes
'| ----------------------
'|
'| Modified GetShiftState function to work according to the differences
'| between the DOS GetShiftState and the OS/2 equal by functionality.
FUNCTION GetShiftState% (bit%)
DIM KeyBoardInfo as tKbdPeek
DIM KeyBoardStatus as tKbdGetStatus
RtnState% = False
If NOT KeyBoardOpen then
rtn% = OpenKeyboard%
end if
IF bit% >= 0 and bit% <= 7 then
rtn% = kbdgetfocus% (iowait%, keyboardhandle)
if kbdpeek% (keyboardinfo, keyboardhandle) <> 0 then
'Skip
elseif keyboardinfo.status = chr$(0) then
keyboardstatus.cb = len(keyboardstatus)
if kbdgetstatus (keyboardstatus, keyhandle%) = 0 then
if keyboardstatus.state <> 0 then
ShiftState% = keyboardstatus.state
end if
end if
else
ShiftState% = keyboardinfo.ShiftState
end if
Rtn% = kbdFreeFocus (KeyHandle%)
if ShiftState% and 2 ^ bit% then
RtnState% = TRUE
end if
end if
GetShiftState% = RtnState%
END FUNCTION
SUB PutBackground (row, col, buffer$)
' =======================================================================
' This sub checks the boundries before executing the put command
' =======================================================================
IF row >= 1 AND row <= MAXROW AND col >= 1 AND col <= MAXCOL THEN
CALL PutCopyBox(row, col, buffer$)
END IF
END SUB
'| --- Modified to support OS/2 changes ---
'|
'| Description of changes
'| ----------------------
'|
'| Modified Scroll SUB to work with the OS/2 API video functions that scroll
'| the screen.
'|
'| The OS/2 API VIO calls replace the Call Interrupt service routines
SUB scroll (row1, col1, row2, col2, lines, attr)
ULRow% = Row1
ULCOl% = Col1
LRRow% = Row2
LRCOl% = Col2
IF ULRow% > LRRow% Then Swap ULRow%, LRRow%
IF ULCol% > LRCol% Then Swap ULCol%, LRCol%
IF row1 >= MINROW AND row2 <= MAXROW AND col1 >= MINCOL AND col2 <= MAXCOL THEN
DIM Cell as TCell
Cell.Char = chr$(32)
Cell.Attr = chr$(attr * 16)
ScrollLines% = lines
TopRow% = ULRow% - 1
LeftCol% = ULCol% - 1
BotRow% = LRRow% - 1
RightCol% = LRCol% - 1
IF lines < 0 THEN
'| Scroll the screen down
Rtn% = VioScrollDn% ( TopRow%, _
LeftCol%, _
BotRow%, _
RightCol%, _
ScrollLines%, _
Cell, _
VideoHandle% _
)
ELSEIf Lines = 0 Then
ScrollLines% = BotRow% - TopRow% + 1
Rtn% = VioScrollDn% ( TopRow%, _
LeftCol%, _
BotRow%, _
RightCol%, _
ScrollLines%, _
Cell, _
VideoHandle% _
)
ELSE
'| Scroll the screen up
Rtn% = VioScrollUp% ( TopRow%, _
LeftCol%, _
BotRow%, _
RightCol%, _
ScrollLines%, _
Cell, _
VideoHandle% _
)
END IF
END IF
END SUB