home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Black Box 4
/
BlackBox.cdr
/
w3_prog
/
vbcomdem.arj
/
MODULE1.BAS
< prev
next >
Wrap
BASIC Source File
|
1991-07-11
|
6KB
|
219 lines
Sub Delay (amount As Single)
t! = Timer
While t! + amount > Timer
Wend
End Sub
Sub UpdateCaption (Msg$, Wait As Single)
Dim wHeight As Integer
Dim wCenter As Integer
If CommDemo.TextWidth(CaptionText$) > CommDemo.TextWidth(Msg$) Then
CommDemo.CurrentX = CaptionLeft
CommDemo.CurrentY = CaptionCenter
CommDemo.ForeColor = CommDemo.BackColor
CommDemo.Print CaptionText$;
CommDemo.ForeColor = 0
End If
wHeight = CommDemo.TextHeight(Msg$)
wCenter = (CaptionHeight - wHeight) / 2
CaptionCenter = CaptionTop + wCenter
CaptionText$ = Msg$
CommDemo.CurrentX = CaptionLeft
CommDemo.CurrentY = CaptionCenter
CommDemo.Print CaptionText$;
If Wait Then
Delay Wait
End If
End Sub
Function ReadCommPort (ReadAmount As Integer) As String
Dim ApiErr As Integer
Dim EventMask As Integer
Dim Found As Integer
If ReadAmount < 1 Then
ReadCommPort = ""
Exit Function
End If
EventMask = CommEventMask
ApiErr = GetCommEventMask(CommHandle, EventMask)
If ApiErr And EV_RXCHAR Then
Buffer$ = Space$(ReadAmount)
ApiErr = ReadComm(CommHandle, Buffer$, Len(Buffer$))
If ApiErr < 0 Then
UpdateCaption " ReadCOMM API FAILED! (ERR " + Str$(ApiErr) + ")", 3
Buffer$ = ""
Else
Buffer$ = Left$(Buffer$, ApiErr)
' Expand CR to CR/LF for "Text" box display
Found = 1
Do
Found = InStr(Found, Buffer$, Chr$(13))
If Found Then
Buffer$ = Left$(Buffer$, Found) + Chr$(10) + Right$(Buffer$, Len(Buffer$) - Found)
Found = Found + 1
End If
Loop While Found
End If
End If
If (ApiErr And EV_RXFLAG) And (CommEventMask And EV_RXFLAG) Then
End If
If (ApiErr And EV_TXEMPTY) And (CommEventMask And EV_XFLAG) Then
End If
If (ApiErr And EV_CTS) And (CommEventMask And EV_CTS) Then
End If
If (ApiErr And EV_DSR) And (CommEventMask And EV_DSR) Then
End If
If (ApiErr And EV_RLSD) And (CommEventMask And EV_RLSD) Then
End If
If (ApiErr And EV_BREAK) And (CommEventMask And EV_BREAK) Then
End If
If (ApiErr And EV_ERR) And (CommEventMask And EV_ERR) Then
End If
If (ApiErr And EV_PERR) And (CommEventMask And EV_PERR) Then
End If
If (ApiErr And EV_RING) And (CommEventMask And EV_RING) Then
UpdateCaption " Receive Window: RING! ", 0
Beep
End If
ReadCommPort = Buffer$
End Function
Sub WriteCommPort (Send$)
ApiErr% = WriteComm(CommHandle, Send$, Len(Send$))
If ApiErr% < 0 Then
UpdateCaption " WriteComm API Failed! (ERR " + Str$(ApiErr%) + ")", 2
End If
End Sub
Sub DisplayQBOpen (TempDCB As CommStateDCB, DevName As String, RB As Integer, TB As Integer, Interval As Integer)
ParityChar$ = "NOEMS"
A$ = " Open " + Chr$(34) + DevName
A$ = A$ + LTrim$(Str$(TempDCB.BaudRate)) + ","
A$ = A$ + Mid$(ParityChar$, Asc(TempDCB.Parity) + 1, 1) + ","
A$ = A$ + LTrim$(Str$(Asc(TempDCB.ByteSize))) + ","
Select Case Asc(TempDCB.StopBits)
Case 0
B$ = "1"
Case 1
B$ = "1.5"
Case 2
B$ = "2"
Case Else
End Select
A$ = A$ + B$ + ","
A$ = A$ + "RB" + LTrim$(Str$(RB)) + ","
A$ = A$ + "TB" + LTrim$(Str$(TB)) + ","
A$ = A$ + "CD" + LTrim$(Str$(TempDCB.RlsTimeOut)) + ","
A$ = A$ + "CS" + LTrim$(Str$(TempDCB.CtsTimeOut)) + ","
A$ = A$ + "DS" + LTrim$(Str$(TempDCB.DsrTimeOut)) + ","
A$ = A$ + "TI" + LTrim$(Str$(Interval))
A$ = A$ + Chr$(34)
UpdateCaption A$, 0
End Sub
Sub Remove_Items_From_SysMenu (A_Form As Form)
HSysMenu = GetSystemMenu(A_Form.Hwnd, 0)
R = RemoveMenu(HSysMenu, 8, MF_BYPOSITION) 'Switch to
R = RemoveMenu(HSysMenu, 7, MF_BYPOSITION) 'Separator
R = RemoveMenu(HSysMenu, 5, MF_BYPOSITION) 'Separator
R = RemoveMenu(HSysMenu, 4, MF_BYPOSITION) 'Maximize
R = RemoveMenu(HSysMenu, 3, MF_BYPOSITION) 'Minimize
R = RemoveMenu(HSysMenu, 2, MF_BYPOSITION) 'Size
R = RemoveMenu(HSysMenu, 0, MF_BYPOSITION) 'Restore
End Sub
Sub CenterDialog (A_Form As Form)
Dim cLeft As Integer
Dim cTop As Integer
cLeft = (Screen.Width - A_Form.Width) / 2
cTop = (Screen.Height - A_Form.Height) / 2
A_Form.Move cLeft, cTop
End Sub
Sub Draw3d (wLeft As Integer, wTop As Integer, wWidth As Integer, wHeight As Integer, A_Form As Form)
Dim LeftY As Integer
Dim LeftX As Integer
Dim RightY As Integer
Dim RightX As Integer
Dim Depth As Integer
Dim OffSet As Integer
Dim SetIn As Integer
OffSet = 15
SetIn = 1
' Draw the Black and White lines to give a "Set In" effect
' around the text and buttons
For Depth = OffSet To OffSet * SetIn Step OffSet
LeftX = wLeft - Depth
LeftY = wTop - Depth
RightX = wLeft + wWidth + Depth
RightY = wTop + wHeight + Depth
' Draw the Top and Bottom Lines
A_Form.Line (LeftX, LeftY)-(RightX, LeftY), QBColor(0)
A_Form.Line (LeftX, RightY)-(RightX, RightY), QBColor(15)
' Draw the Left and Right Lines
A_Form.Line (LeftX - OffSet, LeftY)-(LeftX - OffSet, RightY + OffSet), QBColor(0)
A_Form.Line (RightX, LeftY)-(RightX, RightY + OffSet), QBColor(15)
Next Depth
End Sub