Option Compare Database   'Use database order for string comparisons
Option Explicit

'code provided here is just a SAMPLE of Access calling a DLL!!

Global gCom1 As Integer ' typecast port#
Global gCom2 As Integer

' here comes the global comport list
' you have to do your own Access Basic port housekeeping!
' no Access Basic error traping included!

Declare Function SerialStartUp Lib "ACSERIAL.DLL" (ByVal iStart%, ByVal sApp As String, ByVal sTopic As String, ByVal sCode As String) As Integer
Declare Function SerialShutDown Lib "ACSERIAL.DLL" () As Integer
Declare Function SerialOpenPort Lib "ACSERIAL.DLL" (ByVal iPort%, ByVal iInque%, ByVal iOutQue%, ByVal lBaudrate&, ByVal iDatabits%, ByVal iStopbits%, ByVal sParity As String, ByVal sHandshake As String) As Integer
Declare Function SerialClosePort Lib "ACSERIAL.DLL" (ByVal iClosePort%) As Integer
Declare Function SerialReceive Lib "ACSERIAL.DLL" (ByVal iReadPort As String, ByVal sSerialData As String, ByVal iDataLen%) As Integer
Declare Function SerialSend Lib "ACSERIAL.DLL" (ByVal iSendPort%, ByVal sSendData As String, ByVal iSendLen%) As Integer
Declare Function SerialNotification Lib "ACSERIAL.DLL" (ByVal iNotifPort%, ByVal iNotifLevel%) As Integer
Declare Function SerialDial Lib "ACSERIAL.DLL" (ByVal iDialPort%, ByVal sDialNumber As String) As Integer
Declare Function SerialDisplayErrors Lib "ACSERIAL.DLL" () As Integer
Declare Function SerialErrorOn Lib "ACSERIAL.DLL" () As Integer
Declare Function SerialErrorOff Lib "ACSERIAL.DLL" () As Integer
Declare Function SerialModemHangup Lib "ACSERIAL.DLL" (ByVal iPort%) As Integer
Declare Function SerialGetModemRespone Lib "ACSERIAL.DLL" (ByVal sModemResponse As String) As Integer

Declare Function SerialLowLevelRead Lib "ACSERIAL.DLL" (ByVal IOAddress%, ByVal sValue$) As Integer
Declare Function SerialLowLevelWrite Lib "ACSERIAL.DLL" (ByVal IOAddress%, ByVal sValue$) As Integer


'functions you can execute with build in  windows-functions
Declare Function EscapeCommFunction Lib "User" (ByVal nCid As Integer, ByVal nFunc As Integer) As Integer
' returns zero if successfull, otherwise, it is less than zero.

'the values for nFunc
Global Const SETXOFF = 1   ' Simulate XOFF received
Global Const SETXON = 2    ' Simulate XON received
Global Const SETRTS = 3    ' Set RTS high
Global Const CLRRTS = 4    ' Set RTS low
Global Const SETDTR = 5    ' Set DTR high
Global Const CLRDTR = 6    ' Set DTR low
Global Const RESETDEV = 7  ' Reset device if possible
Global Const GETMAXLPT = 8
Global Const GETMAXCOM = 9

Declare Function FlushComm Lib "User" (ByVal nCid As Integer, ByVal nQueue As Integer) As Integer
' flushes all characters from recieve- or transmit-queue for the
' specified port (opened via SerialOpenPort())
' nQueue is the queue to be flushed.
' If zero, the transmission queue is flushed.
' If 1, the receiving queue is flushed.


' functions for preventing starting twice
Declare Function GetModuleHandle Lib "Kernel" (ByVal lpModuleName As String) As Integer
Declare Function GetModuleUsage Lib "Kernel" (ByVal hModule As Integer) As Integer


Function CheckRunning () As Integer

Dim Msg, Msgtype%, Msgtitle, i
CheckRunning = 0

If GetModuleUsage(GetModuleHandle("MSACCESS.EXE")) > 1 Then
  Msg = "Access is already active"
  Msgtitle = "Access to RS232"
  Msgtype% = 16
  i = MsgBox(Msg, Msgtype%, Msgtitle)
  CheckRunning = 1
End If

If GetModuleUsage(GetModuleHandle("MSARN200")) > 1 Then
  Msg = "Access is already active"
  Msgtitle = "Access to RS232"
  Msgtype% = 16
  i = MsgBox(Msg, Msgtype%, Msgtitle)
  CheckRunning = 1
End If

End Function

Function SerClosePort (p As Integer) 'defined in push-button

Dim r%

If p = 1 And gCom1 < 0 Then
 MsgBox "Port is NOT open!"
 Exit Function
End If
If p = 2 And gCom2 < 0 Then
 MsgBox "Port is NOT open!"
 Exit Function
End If

If p = 1 Then
 r% = SerialModemHangup(gCom1) ' just to be sure
 r% = SerialClosePort(gCom1)
 gCom1 = -1
End If

If p = 2 Then
 r% = SerialModemHangup(gCom2) ' just to be sure
 r% = SerialClosePort(gCom2)
 gCom2 = -1
End If

 If r% = 0 Then
  MsgBox "port closed OK"
 Else
  MsgBox "port NOT cloes OK"
 End If

End Function

Function SerDial (p As Integer) 'defined in push-button

Dim r%
Dim sNumber$

If p = 1 And gCom1 < 0 Then
 MsgBox "Port is NOT open!"
 Exit Function
End If
If p = 2 And gCom2 < 0 Then
 MsgBox "Port is NOT open!"
 Exit Function
End If

sNumber$ = InputBox$("Enter your phone number to dial ", "Access to RS232")
If Len(sNumber$) = 0 Then
 MsgBox "No number to dial!"
 Exit Function
End If

sNumber$ = "ATDT" & sNumber$

If p = 1 Then
 r% = SerialDial(gCom1, sNumber$)
 ' r% = 1 = successfull
 ' r% = 0 = error occurred or user pressed cancel
 If r% = -1 Then
  MsgBox "Already dialing! Dialogbox could not be created"
 End If
End If

If p = 2 Then
 r% = SerialDial(gCom2, sNumber$)
 If r% = -1 Then
  MsgBox "Already dialing! Dialogbox could not be created"
 End If
End If

End Function

Function SerDispErrors ()

Dim r%

MsgBox "No error checking implemented in demo. All errors are set to zero!"

r% = SerialDisplayErrors()

End Function

Function SerErrOff ()

Dim r%

MsgBox "No error checking implemented in demo. All errors are set to zero!"

r% = SerialErrorOff()

If r% = 1 Then
 MsgBox "Error checking of!"
End If

End Function

Function SerErrOn ()

Dim r%

MsgBox "No error checking implemented in demo. All errors are set to zero!"

r% = SerialErrorOn()

If r% = 1 Then
 MsgBox "Error checking on!"
End If

End Function

Function SerGetModemResp () ' no params

Dim s$
Dim r%

s$ = String$(32, 0) ' allocate string of 32 byte's
		    ' this is the max lenght of the string in
		    ' DLL the reponse is saved in. Don't go higher
r% = SerialGetModemRespone(s$)

If r% = 0 Then
 MsgBox "No response from modem (yet)!"
Else
 MsgBox "Last modem response: " & s$ ' could be big-tall msgbox
End If                               ' because of cr/lf in response

End Function

Function SerHangUp (p As Integer) 'defined in push-button

Dim r%

If p = 1 And gCom1 < 0 Then
 MsgBox "Port is NOT open!"
 Exit Function
End If
If p = 2 And gCom2 < 0 Then
 MsgBox "Port is NOT open!"
 Exit Function
End If

If p = 1 Then
 r% = SerialModemHangup(gCom1)
 MsgBox "Hangup completed on COM1!"
End If

If p = 2 Then
 r% = SerialModemHangup(gCom2)
 MsgBox "Hangup completed on COM2!"
End If

End Function

Function SerLowLevelRead (p As Integer) 'defined in push-button

 Dim COM1_BASE%
 Dim COM2_BASE%
 Dim LSR%
 Dim RBR%
 Dim r%
 Dim s$

 COM1_BASE% = &H3F8  ' I/O address COM1 (check hardware via MSD)
 COM2_BASE% = &H2F8  ' I/O address COM2
 LSR% = &H5          ' line status register in UART.
 RBR% = &H0          ' Receive buffer register in UART.

 MsgBox "Function NOT implemented in demo."
 Exit Function

 s$ = String$(2, 0)  ' allocate receive string

 If p = 1 Then                        'LSR%
  r% = SerialLowLevelRead(COM1_BASE% + RBR%, s$)
 End If

 If p = 2 Then
  r% = SerialLowLevelRead(COM2_BASE% + RBR%, s$)
 End If

 MsgBox "Integer-value " & CStr(r%) & "  String-value " & s$

End Function

Function SerLowLevelWrite (p As Integer) 'defined in push-button

 Dim COM1_BASE%
 Dim COM2_BASE%
 Dim TB%
 Dim r%

 COM1_BASE% = &H3F8  ' I/O address COM1 (check hardware via MSD)
 COM2_BASE% = &H2F8  ' I/O address COM2
 TB% = &H0           ' transmit buffer register in UART.

 MsgBox "Function NOT implemented in demo."
 Exit Function

' ports don't need to be open
' be very carefull in using this functions
' reading resets the UART registers!!
If p = 1 Then
 r% = SerialLowLevelWrite(COM1_BASE% + TB%, Chr$(13))
End If

If p = 2 Then
 r% = SerialLowLevelWrite(COM2_BASE% + TB%, Chr$(13))
End If

End Function

Function SerOnOpen () ' called from: form-on-open

' initialize global var's

 gCom1 = -1
 gCom2 = -1

End Function

Function SerOpenPort (p As Integer) 'defined in push-button

' error values returned from SerialOpenPort ()
Const IE_BADID = -1 'The device identifier is invalid or unsupported.
Const IE_OPEN = -2  'The device is already open.
Const IE_NOPEN = -3 'The device is not open.
Const IE_MEMORY = -4 'The function cannot allocate the queues.
Const IE_DEFAULT = -5 'The default parameters are in error.
Const IE_HARDWARE = -10 'The hardware is not available (is locked by another device).
Const IE_BYTESIZE = -11 'The specified byte size is invalid.
Const IE_BAUDRATE = -12 'The device's baud rate is unsupported.

If p = 1 And gCom1 <> -1 Then
 MsgBox "Com1 already open!"
 Exit Function
End If
If p = 1 Then
 gCom1 = SerialOpenPort(1, 0, 0, 2400, 8, 1, UCase$("N"), UCase$("X"))
 MsgBox "Port# " & CStr(gCom1)
End If

If p = 2 And gCom2 <> -1 Then
 MsgBox "Com2 already open!"
 Exit Function
End If
If p = 2 Then
 gCom2 = SerialOpenPort(2, 0, 0, 2400, 8, 1, UCase$("N"), UCase$("X"))
 MsgBox "Port# " & CStr(gCom2)
End If

End Function

Function SerReadData ()

Dim s$, s2$, revport$, text$
Dim r%, rport%
Dim FileName

revport$ = String$(2, 0) ' allocate memory for port#
			 ' 1 pos for port# and one for hex-0
r% = 1 ' initialize to 1 for a nice loop

While r% > 0
 s$ = String$(2048, 0)    'allocate 2K of data, max 32k-1
 r% = SerialReceive(revport$, s$, Len(s$))'go into DLL get the data
 If r% > 0 Then
  s2$ = Mid$(s$, 1, r%)         'get rid of terminating hex-nul's
  revport$ = Mid$(revport$, 1, 1)'can't pass integer with port# from DLL (Access??)
  rport% = CInt(revport$)        ' convrt from null-term-string to integer

' Display incomming char's in the textbox
  If IsNull(forms![WinTerm]![Received]) Or forms![WinTerm]![Received] = "" Then
   forms![WinTerm]![Received] = s2$
  Else
   text$ = forms![WinTerm]![Received] & s2$ '& Chr(13) & s2$ & Chr$(32)
   forms![WinTerm]![Received] = text$
  End If
 End If
Wend

 s2$ = " "
 text$ = " "

End Function

Function SerSend (p As Integer) 'defined in push-button

Dim r%
Dim sSend$

DoCmd GoToControl "ToBeSend"

If p = 1 And gCom1 < 0 Then
 MsgBox "Port is NOT open!"
 Exit Function
End If
If p = 2 And gCom2 < 0 Then
 MsgBox "Port is NOT open!"
 Exit Function
End If

sSend$ = forms![WinTerm]![ToBeSend] & Chr$(13)

'max string len to send is 32K
If p = 1 Then
 r% = SerialSend(gCom1, sSend$, Len(sSend$)) 'max 32k-1
End If

If p = 2 Then
 r% = SerialSend(gCom2, sSend$, Len(sSend$))
End If

MsgBox CStr(Len(sSend$)) & " chars entered  " & CStr(r%) & " chars actualy sent"

End Function

Function SerShutDown () 'called from: form-on-close AND button 'Down'

Dim r%

'go into DLL

 r% = SerialShutDown()

 If r% = 1 Then
  MsgBox "communications down"
 Else
  MsgBox "communications NOT down"
 End If

 gCom1 = -1
 gCom2 = -1

End Function

Function SerStartUp ()

Dim r%

 MsgBox "Look at the 'RS232ViaDLL'-module and check out the minimum of Access Basic code by wich this application is created!"

'go in DLL         1 0 application  topic
 r% = SerialStartUp(0, "MSAccess", "System", "MReadPort")
					    ' code to be executed
 gCom1 = -1                                 ' through DDE max 32 chars
 gCom2 = -1

 If r% = 1 Then
  MsgBox "communications started"
 Else
  MsgBox "communications NOT started, or already started"
 End If

End Function

Function SetSetNotification (p As Integer) 'defined in push-button

Dim r%

' begin passing data to Access when a number of bytes
' did realy arrive

' can be called at any time for any open port

If p = 1 And gCom1 < 0 Then
 MsgBox "Port is NOT open!"
 Exit Function
End If
If p = 2 And gCom2 < 0 Then
 MsgBox "Port is NOT open!"
 Exit Function
End If

If p = 1 Then
 r% = SerialNotification(gCom1, 10)
 MsgBox "Notification completed on COM1!"
End If

If p = 2 Then
 r% = SerialNotification(gCom2, 10)
 MsgBox "Notification completed on COM2!"
End If

End Function

