Option Compare Database
Option Explicit

Dim w_buf(0 To 24) As Byte, r_buf(0 To 12) As Byte, t_buf(0 To 12) As Byte


Const work_com_port As String = "COM1"
Const long_wait_time As Single = 2.5
Const little_wait_time As Single = 0.25

Const INVALID_HANDLE_VALUE = -1
Const GENERIC_READ = &H80000000
Const GENERIC_WRITE = &H40000000
Const OPEN_EXISTING = 3
Const FILE_ATTRIBUTE_NORMAL = &H80
Const EVENPARITY = 2
Const ODDPARITY = 1
Const NOPARITY = 0
Const MARKPARITY = 3
Const ONESTOPBIT = 0
Const ONE5STOPBITS = 1
Const TWOSTOPBITS = 2
Type OVERLAPPED
Internal As Long
InternalHigh As Long
offset As Long
OffsetHigh As Long
hEvent As Long
End Type
Type COMMTIMEOUTS
ReadIntervalTimeout As Long
ReadTotalTimeoutMultiplier As Long
ReadTotalTimeoutConstant As Long
WriteTotalTimeoutMultiplier As Long
WriteTotalTimeoutConstant As Long
End Type
Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Type DCB
DCBlength As Long
BaudRate As Long
fBitFields As Long 'See Comments in Win32API.Txt
wReserved As Integer
XonLim As Integer
XoffLim As Integer
ByteSize As Byte
Parity As Byte
StopBits As Byte
XonChar As Byte
XoffChar As Byte
ErrorChar As Byte
EofChar As Byte
EvtChar As Byte
wReserved1 As Integer 'Reserved; Do Not Use
End Type

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA"
(ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal
dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal
dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal
hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long)
As Long
Private Declare Function GetCommState Lib "kernel32" (ByVal nCid As Long,
lpDCB As DCB) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As
Long, lpDCB As DCB) As Long
Private Declare Function SetupComm Lib "kernel32" (ByVal hfile As Long,
ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As Long
Private Declare Function GetCommTimeouts Lib "kernel32" (ByVal hfile As
Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function SetCommTimeouts Lib "kernel32" (ByVal hfile As
Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hfile As Long,
lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long,
lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hfile As Long,
lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As
Long, lpOverlapped As Any) As Long
'*****************************************************************************
' ??????? ????? ? ????????? ??????????
Function open_com_port(name_com_port As String, error_fun As Long) As Long

Dim hcom As Long, tt As String, r As SECURITY_ATTRIBUTES, h1 As Boolean, h2
As Boolean
Dim r1 As DCB, h3 As Long, h4 As Boolean, h5 As Boolean, t1 As COMMTIMEOUTS
Dim h6 As Boolean

tt = name_com_port
error_fun = 0

r.lpSecurityDescriptor = 0
r.lpSecurityDescriptor = 0
r.nLength = 12

hcom = CreateFile(tt, GENERIC_READ + GENERIC_WRITE, 0, r, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, 0)
If hcom = INVALID_HANDLE_VALUE Then
h3 = GetLastError()
error_fun = h3
open_com_port = INVALID_HANDLE_VALUE
Exit Function
End If
h5 = SetupComm(hcom, 3000, 3000)
If (Not h5) Then
h3 = GetLastError()
error_fun = h3
open_com_port = INVALID_HANDLE_VALUE
Exit Function
End If
h2 = GetCommState(hcom, r1)
If (Not h2) Then
h3 = GetLastError()
error_fun = h3
open_com_port = INVALID_HANDLE_VALUE
Exit Function
End If
r1.BaudRate = 10472
r1.ByteSize = 8
r1.Parity = NOPARITY
r1.StopBits = ONESTOPBIT
r1.fBitFields = 12305

h4 = SetCommState(hcom, r1)
If (Not h4) Then
h3 = GetLastError()
error_fun = h3
open_com_port = INVALID_HANDLE_VALUE
Exit Function
End If

t1.ReadIntervalTimeout = 10
t1.ReadTotalTimeoutConstant = 100
t1.ReadTotalTimeoutMultiplier = 20
t1.WriteTotalTimeoutConstant = 0
t1.WriteTotalTimeoutMultiplier = 0
h6 = SetCommTimeouts(hcom, t1)
If (Not h6) Then
h3 = GetLastError()
error_fun = h3
open_com_port = INVALID_HANDLE_VALUE
Exit Function
End If

open_com_port = hcom

End Function
'****************************************************************************
' ?????? ?????? ? ??????

Private Function set_std_comm(bytes_to_inp As Byte, hfile As Long) As Long

Dim h5 As Long, h4 As Boolean, n2 As Long, a As Single
Dim h3 As Long, w_buf11(0 To 5) As Byte, b As Integer

set_std_comm = 0

w_buf11(0) = &HF0
w_buf11(1) = &HF0
w_buf11(2) = &HF0
w_buf11(3) = &HF0
w_buf11(4) = &HF0
w_buf11(5) = &HF0
h4 = WriteFile(hfile, w_buf11(0), 6, n2, ByVal 0&)
If (Not (h4)) Then
h5 = GetLastError()
set_std_comm = h5
Exit Function
End If

w_buf(4) = &HF
w_buf(5) = &HF
Call add_ctrl_summ(6)
h4 = WriteFile(hfile, w_buf(0), 7, n2, ByVal 0&)
If (Not (h4)) Then
h5 = GetLastError()
set_std_comm = h5
Exit Function
End If

h4 = ReadFile(hfile, r_buf(0), bytes_to_inp, n2, ByVal 0&)
If (Not (h4)) Then
h5 = GetLastError()
set_std_comm = h5
Exit Function
End If
If n2 <> bytes_to_inp Then
set_std_comm = 10003 ' ??????? ???????? ?? ???????, ??????? ????
h3 = close_com_port(hfile)
Exit Function
End If
h5 = test_read_inf(7, bytes_to_inp)
If h5 <> 0 Then
set_std_comm = h5 ' ????????? ????????? ??????
Exit Function
End If

End Function
'******************************************************************************
' ???????? ?????

Function close_com_port(handle_com_port As Long) As Long

close_com_port = 0
If (Not CloseHandle(handle_com_port)) Then
close_com_port = GetLastError()
End If

Если хотите работать с модемом напрямую, то изучите протокол обмена (есть на спец сайтах), и работайте на здоровье через компорт.