Programming Tool Box/SIMS_2.iso/vb_code1/commdemo/module1.txt

Text 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