Newsgroup: it.comp.lang.visual-basic
Titolo: Seriali via api!

Tempo fa, sul numero 15 di VBJ era stato publlicato un progetto esempio per
pilotare le seriali via api.
Tale progetto era a 16 bit ed e' impossibile convertirlo: qualcuno sa se in
rete esiste un progetto analogo a 32bit????
GRAZIE!!

Io ho convertito un esempio dal VC e funge benissimo, l'unico problema é che
se non rilasci l'handle devi chiudere VB e rientrare.
Per il resto tutto OK!
Ciao
GL

 wrote in message
10kl9ke$mf0$2...@fe2.cs.interbusiness.it...



Waw
Che ne dici di inviarne un esempio al Sito Comune?
http://www.murialdo.it/it_lang_vb
Ciao
By -MES-   Maronese Ettore
http://www.maronese.com/mes
(con OCX per stampare i recordset)
Sito Comune di programmatori Visual Basic
http://www.murialdo.it/it_lang_vb

OK vedo di ritagliare la classe e la invio
GL

 wrote in message
867r66$fv8$1...@nslave2.tin.it...


Allora, ho trovato la soluzione studiando un po'...posto questo messaggio
perche' e' una cavolata che potrebbe essere utile!!
Utilizzando l'oggetto MSComm si ha a disposizione la proprietą CommID, che
e' un handle di riferimento della chiamata api CreateFile
utilizzando tale handle, e' possibile manipolare le impostazioni della
seriale quando e' aperta!
Public Type DCB
        DCBlength As Long
        BaudRate As Long
        fBitFields As Long 'Vedere i commenti 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 'Riservato. Non utilizzare
End Type
Public Declare Function GetCommState Lib "kernel32" (ByVal nCid As Long,
lpDCB As DCB) As Long
Public Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long,
lpDCB As DCB) As Long
Sub Manipola()
Dim test As DCB
MSComm.PortOpen = True
GetCommState MSComm1.CommID, test
test.BaudRate = 5799
SetCommState MSComm1.CommID, test
End Sub

Posto la classe qui, é stata 'troncata' peró puo servire per capire come
usare le API
Ciao!
GL
Option Explicit
'=========================================================
'                      ©1999 GL All rights reserved
'
'        Module:   CRs232
'  Description:   Rs232 Low level comunication unit
'       Created:   08/09/99-11:56:30
'         Author:   Gustavo Laroma
'
'         NOTES:
'=========================================================
'// Parity Data
Public Enum IC_PARITY
   IC_PARITY_NONE
   IC_PARITY_ODD
   IC_PARITY_EVEN
   IC_PARITY_MARK
End Enum
'// StopBit Data
Public Enum IC_STOPBIT
   IC_STOPBIT_1
   IC_STOPBIT_15
   IC_STOPBIT_2
End Enum
'// Error defintion
Public Enum IC_ERRORS
   IC_ERR_OPEN_CHANNEL_FAILURE = vbObjectError + 512 + 1
   IC_ERR_CHANNEL_NOT_OPENED
   IC_ERR_CHANNEL_SETUP
   IC_ERR_TIMEOUT
   IC_ERR_NACK
   IC_ERR_TX
   IC_ERR_CHECKSUM
   IC_ERR_MISSING_ETX
End Enum
'// Required APIs
Private Declare Function GetCommConfig Lib "kernel32" (ByVal hCommDev As
Long, lpCC As COMMCONFIG, lpdwSize As Long) As Long
Private Declare Function CommConfigDialog Lib "kernel32" Alias
"CommConfigDialogA" (ByVal lpszName As String, ByVal hwnd As Long, lpCC As
COMMCONFIG) As Long
Private Declare Function PurgeComm Lib "kernel32" (ByVal hFile As Long,
ByVal dwFlags As Long) As Long
Private Declare Function ClearCommError Lib "kernel32" (ByVal hFile As Long,
lpErrors As Long, ByVal l As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA"
(ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long,
ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long,
Arguments As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA"
(ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal
dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal
dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal
hTemplateFile As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal
lpBuffer As String, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead
As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long)
As Long
Private Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As
Long, lpDCB As DCB) As Long
Private Declare Function GetCommState Lib "kernel32" (ByVal nCid As Long,
lpDCB As DCB) As Long
Private Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA"
(ByVal lpDef As String, lpDCB As DCB) As Long
Private Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As
Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function GetCommTimeouts Lib "kernel32" (ByVal hFile As
Long, lpCommTimeouts As COMMTIMEOUTS) 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 WriteFile Lib "kernel32" (ByVal hFile As Long,
ByVal lpBuffer As String, ByVal nNumberOfBytesToWrite As Long,
lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
'// Required constants
Private Const PURGE_RXABORT = &H2
Private Const PURGE_RXCLEAR = &H8
Private Const PURGE_TXABORT = &H1
Private Const PURGE_TXCLEAR = &H4
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const INVALID_HANDLE_VALUE = -1
Private Const IO_BUFFER_SIZE = 1024
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const DEF_TIMEOUT = 2000
Private Const DEF_BAUDRATE = 9600
Private Const msCLASS_ID = "CComMedia_Rs232"
'// Required structures
Private Type DCB                 ' *Win32API.TXT is incorrect here.*
        DCBlength As Long
        BaudRate As Long
        Bits1 As Long
        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
        wReserved2 As Integer
End Type
Private Type COMMTIMEOUTS
        ReadIntervalTimeout As Long
        ReadTotalTimeoutMultiplier As Long
        ReadTotalTimeoutConstant As Long
        WriteTotalTimeoutMultiplier As Long
        WriteTotalTimeoutConstant As Long
End Type
Private Type COMMCONFIG
    dwSize As Long
    wVersion As Integer
    wReserved As Integer
    dcbx As DCB
    dwProviderSubType As Long
    dwProviderOffset As Long
    dwProviderSize As Long
    wcProviderData As Byte
End Type
'// Private Class Members
Private Type ClassData
   lBaudRate As Long
   sRXData As String
   sTxData As String
   lDataBit As Long
   eStopBit As IC_STOPBIT
   eParity As IC_PARITY
   lPort As Long
   hComm As Long
   lTimeOut As Long
End Type
Private mCD As ClassData
Private Sub Class_Initialize()
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Initialize Class
'       Created:   08/09/99-12:07:25
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
'// Setup class defaults
With mCD
   .lBaudRate = DEF_BAUDRATE
   .lTimeOut = DEF_TIMEOUT
   .eParity = IC_PARITY_NONE
   .eStopBit = IC_STOPBIT_1
   .lDataBit = 8
End With
End Sub
Private Sub Class_Terminate()
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Closes Comunication Port if not done
'       Created:   09/09/99-10:46:31
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
CloseChannel
End Sub
Public Property Let BaudRate(ByVal BaudRate As Long)
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Set baud rate
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
mCD.lBaudRate = BaudRate
End Property
Public Property Get BaudRate() As Long
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Returns baud rate
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
BaudRate = mCD.lBaudRate
End Property
Public Sub CloseChannel()
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Close Comunication Channel
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
'// Closes Channel
If mCD.hComm <> 0 Then
   CloseHandle mCD.hComm
   mCD.hComm = 0
End If
End Sub
Public Property Let Data(ByVal TxData As String)
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Set Data to transmit
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'        TxData: MsgBody made of: TypeMessage+CodeMessage+DataField
'         NOTES:
'=========================================================
mCD.sTxData = TxData
End Property
Public Property Get Data() As String
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Return received data stream
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:  Data is made of: CodeMessage+DataField
'=========================================================
Data = mCD.sRXData
End Property
Public Property Let DataBit(ByVal DataBit As Long)
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Set Databit
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
mCD.lDataBit = DataBit
End Property
Public Property Get DataBit() As Long
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Returns Databit
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
DataBit = mCD.lDataBit
End Property
Public Sub OpenChannel()
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Open Comunication Channel
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
Dim sDcbConf As String, uDcb As DCB, sParity As String, uCtm As
COMMTIMEOUTS, lRc As Long
'---------------------------------------------------------------------
sParity = "noem"
mCD.hComm = CreateFile("COM" & CStr(mCD.lPort), _
                                 GENERIC_READ Or GENERIC_WRITE, 0, 0, _
                                 OPEN_EXISTING, 0, 0)
If mCD.hComm = INVALID_HANDLE_VALUE Then
      '// Error occurred while opening
      Err.Raise IC_ERR_OPEN_CHANNEL_FAILURE, msCLASS_ID, pApiError
   Else
      '// Reset Com Port
      Reset
      '// Clears I/O buffers
      PurgeComm mCD.hComm, PURGE_RXCLEAR Or PURGE_TXCLEAR
      '// Get Dcb block,Update with current data
      lRc = GetCommState(mCD.hComm, uDcb)
      With mCD
         sDcbConf = CStr(.lBaudRate) & "," & _
                       Mid$(sParity, .eParity + 1, 1) & "," & _
                       CStr(.lDataBit) & "," & "1" 'CStr(.eStopBit)
      End With
      lRc = BuildCommDCB(sDcbConf, uDcb)
      lRc = SetCommState(mCD.hComm, uDcb)
      If lRc = 0 Then Err.Raise IC_ERR_CHANNEL_SETUP, msCLASS_ID, pApiError
      '// Set I/O queues
      lRc = SetupComm(mCD.hComm, IO_BUFFER_SIZE, IO_BUFFER_SIZE)
      '// Set Timeouts
      With uCtm
         .ReadIntervalTimeout = 0
         .ReadTotalTimeoutMultiplier = 0
         .ReadTotalTimeoutConstant = mCD.lTimeOut
         .WriteTotalTimeoutMultiplier = 10
         .WriteTotalTimeoutConstant = 100
      End With
      lRc = SetCommTimeouts(mCD.hComm, uCtm)
      If lRc = 0 Then Err.Raise IC_ERR_TIMEOUT, msCLASS_ID, pApiError
End If
End Sub
Private Function pApiError() As String
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:   Returns a string representing Last DLL Error
'       Returns:
'       Created:   08/09/99-09:29:28
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
Dim s As String, c As Long, ErrCode As Long
'// Get last API Error Code
ErrCode = Err.LastDllError
If ErrCode > 0 Then
   '// Get Error
   s = String(256, 0)
   c = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or
FORMAT_MESSAGE_IGNORE_INSERTS, 0&, ErrCode, 0&, s, Len(s), ByVal 0&)
   If c Then pApiError = Left$(s, c - 2)
End If
End Function
Public Property Let Parity(ByVal Value As IC_PARITY)
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Set Comunication Parity
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
mCD.eParity = Value
End Property
Public Property Get Parity() As IC_PARITY
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Return Comunication Parity
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
Parity = mCD.eParity
End Property
Public Property Let Port(ByVal PortNumber As Long)
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Set Comunication Parity
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'     Portnumber:= Comunication Port to use
'         NOTES:
'=========================================================
mCD.lPort = PortNumber
End Property
Public Property Get Port() As Long
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Return Comunication Port
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
Port = mCD.lPort
End Property
Public Function Reset() As Long
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:   Resets Comunication Error
'       Returns:   Last Comunication Error
'       Created:   08/09/99-10:03:15
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
Dim lpErrCode As Long
'----------------------------
If mCD.hComm > 0 Then
      ClearCommError mCD.hComm, lpErrCode, 0&
      Reset = lpErrCode
   Else
      '// Channel not opened
      Err.Raise IC_ERR_CHANNEL_NOT_OPENED, msCLASS_ID, "Channel not opened"
End If
End Function
Public Sub Rx(NumChar2Wait As Long)
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Get data from comunication Port
'       Created:   08/09/99-15:26:39
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'     NumChar2Wait:= Number of characters to recive
'         NOTES:
'=========================================================
Dim lpRead As Long, sRx As String, lRc As Long, lLen As Long, cChkSum As
Byte
'---------------------------------------------------------------------------
-------------------------
mCD.sRXData = vbNullString
'// Get 2 byte, getting total MsgLenght
lpRead = 0
sRx = String$(NumChar2Wait, vbNullChar)
lRc = ReadFile(mCD.hComm, sRx, NumChar2Wait, lpRead, 0)
'// Check for STX
If (lpRead = 0) Then
            '// No chars readed, probable timeout
            Err.Raise IC_ERR_TIMEOUT, msCLASS_ID, "Comunication Timeout"
End If
'// Clears Input Buffers
PurgeComm mCD.hComm, PURGE_RXCLEAR
'//saves value
mCD.sRXData = Left$(sRx, lpRead)
End Sub
Public Sub ShowConfigPanel(hwnd As Long, Optional Port As Long = -1)
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Display Comunication Port setup
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'        hWnd:= Handle of parent window
'        Port:=    Port to configure *Optional*
'         NOTES:
'=========================================================
Dim lpCC As COMMCONFIG, lRc As Long, lPort As Long
'----------------------------------------------------
lPort = IIf(Port > 0, Port, mCD.lPort)
If lPort = 0 Then Exit Sub
If mCD.hComm > 0 Then
      '// Get current configuration data
      GetCommConfig mCD.hComm, lpCC, Len(lpCC)
   Else
      '// Setup struct
      lpCC.dwSize = 52
End If
lRc = CommConfigDialog("COM" & CStr(lPort), hwnd, lpCC)
'// If not user aborted,setup comunication infos
If Err.LastDllError = 0 Then
   SetCommState mCD.hComm, lpCC.dcbx
End If
End Sub
Public Property Let StopBit(ByVal StopBit As IC_STOPBIT)
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Sets Comunication Stopbit
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
mCD.eStopBit = StopBit
End Property
Public Property Get StopBit() As IC_STOPBIT
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Retruns Comunication Stopbit
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
StopBit = mCD.eStopBit
End Property
Public Property Let Timeout(ByVal Value As Long)
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Set  Timeout(in ms)
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'     Value:=  Timeout value in milliseconds
'
'         NOTES:
'=========================================================
Dim uCtm As COMMTIMEOUTS
'-------------------------------------
mCD.lTimeOut = Value
If mCD.hComm > 0 Then
   '// On-fly update
   With uCtm
      .ReadIntervalTimeout = 0
      .ReadTotalTimeoutMultiplier = 0
      .ReadTotalTimeoutConstant = mCD.lTimeOut
      .WriteTotalTimeoutMultiplier = 10
      .WriteTotalTimeoutConstant = 100
   End With
   If SetCommTimeouts(mCD.hComm, uCtm) = 0 Then
      Err.Raise IC_ERR_TIMEOUT, msCLASS_ID, pApiError
   End If
End If
End Property
Public Property Get Timeout() As Long
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Returns Timeout(in ms)
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
Timeout = mCD.lTimeOut
End Property
Public Sub Tx()
'=========================================================
'                      ©1999 GL All rights reserved
'
'      Purpose:    Transmits Data via Rs232
'       Created:   08/09/99-12:06:53
'         Author:   Gustavo Laroma
'
'         -- Parameters List --
'
'         NOTES:
'=========================================================
Dim sBuf As String, lpWritten As Long, lRc As Long, sLen As String, cChkSum
As Byte
'---------------------------------------------------------------------------
--------------------------------
'// Clears I/O Buffers
PurgeComm mCD.hComm, PURGE_RXCLEAR Or PURGE_TXCLEAR
'// Sends data to RS232
lRc = WriteFile(mCD.hComm, mCD.sTxData, Len(mCD.sTxData), lpWritten, 0)
If lRc = 0 Then Err.Raise IC_ERR_TX, msCLASS_ID, pApiError
End Sub