** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Access y VBA > Access y VBA
  Mensajes nuevos Mensajes nuevos RSS - LEER BASCULA DESDE ACCESS
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

LEER BASCULA DESDE ACCESS

 Responder Responder
Autor
Mensaje
jghernandez15 Ver desplegable
Nuevo
Nuevo
Avatar

Unido: 03/Mayo/2016
Localización: Colombia
Estado: Sin conexión
Puntos: 5
Opciones de entrada Opciones de entrada   Gracias (0) Gracias(0)   Cita jghernandez15 Cita  ResponderRespuesta Enlace directo a este mensaje Tema: LEER BASCULA DESDE ACCESS
    Enviado: 05/Diciembre/2018 a las 19:36
Hola comunidad soy nuevo aqui, y un tanto en access pero me defiendo, tengo una necesidad que me esta volviendo loco, teengo un sistemas de facturacion y necesito leer el peso de la bascula, he utilidad varios codigos y he logrado leer el puerto, pero al cabo de un tiempo mi equipo comienza a bloquearse y la lectura que con el cursos suspendido, y a veces me toca reiniciar, no se si es la rutina pero me gustaria me hecharan una mano. O si ya el tema es de conocimiento me puedan ayudar con el codigo que este ya probado.
J.Gabriel Hernandez
Arriba
IvoneR2017 Ver desplegable
Habitual
Habitual
Avatar

Unido: 02/Marzo/2018
Localización: Costa Rica
Estado: Sin conexión
Puntos: 81
Opciones de entrada Opciones de entrada   Gracias (0) Gracias(0)   Cita IvoneR2017 Cita  ResponderRespuesta Enlace directo a este mensaje Enviado: 05/Diciembre/2018 a las 22:14
Tal vez si pones el código que llevas te podría venir mejor, debes aportar que tipo de báscula es (conexion serial, etc) cada báscula tiene sus propios comandos de comunicacion con el puerto (aunque hay muchos que son estandar) Hace ya unos años un buen amigo de Venezuela (Jefferson) me apoyó en ese empeño pero de inicio te digo que hay que "moler un poco".
Te dejo el link de su sitio en google por si te sirve de algo como inicio, pero te repito, debes mostrar en donde estas y a donde quieres llegar por que como dijo un amigo (Xavier) "Si no sabes para donde vas cualquier metro te sirve". Adelante!

https://sites.google.com/site/jjjt1973/ejemplos-access/balanza-o-bascula
Arriba
jghernandez15 Ver desplegable
Nuevo
Nuevo
Avatar

Unido: 03/Mayo/2016
Localización: Colombia
Estado: Sin conexión
Puntos: 5
Opciones de entrada Opciones de entrada   Gracias (0) Gracias(0)   Cita jghernandez15 Cita  ResponderRespuesta Enlace directo a este mensaje Enviado: 05/Diciembre/2018 a las 22:35
Hola Ivonne Gracias por contestar, precisamente el codigo de jeferson lo probe, con este es que me he conectado al puerto, pero tengo problemas el codigo es el siguiente: corresponden a 2 modulos y el evento donde lo aplico

modulo 1
Option Compare Database
Option Explicit

'DECLARANDO LAS API's
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3
Private Const FILE_ATTRIBUTE_NORMAL = &H80

Type COMSTAT
    fCtsHold As Long
    fDsrHold As Long
    fRlsdHold As Long
    fXoffHold As Long
    fXoffSent As Long
    fEof As Long
    fTxim As Long
    fReserved As Long
    cbInQue As Long
    cbOutQue As Long
End Type

Type COMMTIMEOUTS
    ReadIntervalTimeout As Long
    ReadTotalTimeoutMultiplier As Long
    ReadTotalTimeoutConstant As Long
    WriteTotalTimeoutMultiplier As Long
    WriteTotalTimeoutConstant As Long
End Type

Type DCB
    DCBlength As Long
    BaudRate As Long
    fBinary As Long
    fParity As Long
    fOutxCtsFlow As Long
    fOutxDsrFlow As Long
    fDtrControl As Long
    fDsrSensitivity As Long
    fTXContinueOnXoff As Long
    fOutX As Long
    fInX As Long
    fErrorChar As Long
    fNull As Long
    fRtsControl As Long
    fAbortOnError As Long
    fDummy2 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
End Type

Type OVERLAPPED
    Internal As Long
    InternalHigh As Long
    offset As Long
    OffsetHigh As Long
    hEvent As Long
End Type
Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

Private Declare Function ReadFile Lib "kernel32" _
                                                        (ByVal hFile As Long, _
                                                        lpBuffer As Any, _
                                                        ByVal nNumberOfBytesToRead As Long, _
                                                        lpNumberOfBytesRead As Long, _
                                                        lpOverlapped As Long) As Long
    
Private Declare Function WriteFile Lib "kernel32" _
                                                        (ByVal hFile As Long, _
                                                        lpBuffer As Any, _
                                                        ByVal nNumberOfBytesToWrite As Long, _
                                                        lpNumberOfBytesWritten As Long, _
                                                        lpOverlapped As Long) 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 BuildCommDCB Lib "kernel32" _
                                                        Alias "BuildCommDCBA" _
                                                        (ByVal lpDef As String, _
                                                        lpDCB As DCB) 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 CreateFile1 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 FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB As DCB) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long

'ESTABLECIENDO LAS VARIABLES NECESARIAS
Public ElPuerto As String
Public PuertoEs As Boolean
Private Const PuertoConfig As String = "9600,n,8,1"
Private ArrayPuerto(1 To 10) As Integer 'Private ArrayPuerto(1 To 100) As Integer
Private PuertoNumero As String
Private PuertoEncontrado As Integer
Global COM_Numero As Long
Global LeeBytes(256) As Byte
Private Const Mensaje As String = "No encontramos puerto disponible conectado a ninguna Balanza"

'LAS FUNCIONES ESTAN CLARAS
'********************************************************************************************************

'ESTA SUB LA QUE HACE TODO    *************************************************************
Sub BuscandoPuerto(Optional Lbl As Access.Label)
Dim LblOut As Boolean
Dim Read As String
Dim VP As Integer
Dim TestPort As Integer
Dim PortChck As Long
   DoEvents
   If Not Lbl Is Nothing Then Lbl.Caption = "Iniciando el proceso"
   DoEvents
DoCmd.Hourglass True
If PuertoNumero = vbNullString Then
For PortChck = 1 To 10 '100
   DoEvents
   If Not Lbl Is Nothing Then Lbl.Caption = "Enumerando puertos abiertos... : " & PortChck
   DoEvents
    If ChequeaPuerto(PortChck) Then
       PuertoEncontrado = PuertoEncontrado + 1
      ArrayPuerto(PuertoEncontrado) = PortChck
    End If
  Next
For TestPort = 1 To PuertoEncontrado
   DoEvents
   If Not Lbl Is Nothing Then Lbl.Caption = "Testeando la conexion...   COM : " & ArrayPuerto(TestPort)
   DoEvents
    PuertoNumero = "\\.\COM" & ArrayPuerto(TestPort)
    IniciandoPuerto PuertoNumero, PuertoConfig
   DoEvents
   If Not Lbl Is Nothing Then Lbl.Caption = "Comunicando...   COM : " & ArrayPuerto(TestPort)
   DoEvents
    EscribePuerto "$"
    EscribePuerto (Chr$(7))
    Sleep 400
    Read = Read + LeyendoPuerto()
   DoEvents
   If Not Lbl Is Nothing Then Lbl.Caption = "Obteniendo Respuesta . . . "
   DoEvents
   Sleep 500 '500
    If InStr(1, Read, "RSSI") > 0 Or InStr(1, Read, "^") > 0 Then
    Read = vbNullString
    End If
    If SoloNumeros(Read) <> "" Or SoloNumeros(Read) <> vbNullString Then
    ElPuerto = Mid(PuertoNumero, 8, Len(PuertoNumero))
    PuertoEs = True
    Dim rsP As DAO.Recordset
    Set rsP = CurrentDb.OpenRecordset("PuertoCOM")
     rsP.Edit
     rsP!PuertoEs = ElPuerto
     rsP.Update
     rsP.Close
    Set rsP = Nothing
    If Not Lbl Is Nothing Then Lbl.Caption = "Puerto establecido...   COM : " & ArrayPuerto(TestPort)
    DoCmd.Hourglass False
    Exit For
    End If
   Call CerrarPuerto
 Next TestPort
 If PuertoEs = False Then
    PuertoNumero = vbNullString
    If Not Lbl Is Nothing Then Lbl.Caption = Mensaje Else MsgBox Mensaje
 End If
 DoCmd.Hourglass False
 End If
End Sub
Function CerrarPuerto()
CerrarPuerto = CloseHandle(COM_Numero): PuertoNumero = vbNullString
End Function
Private Function NivelarCOM()
    FlushFileBuffers (COM_Numero)
End Function
Function IniciandoPuerto(COMnumero As String, AjusteCOM As String) As Boolean
On Error GoTo VerError
    Dim ComSetup As DCB, Answer, STAT As COMSTAT, RetBytes As Long
    Dim RetVal As Long
    Dim TimeOut As COMMTIMEOUTS, BarDCB As DCB
    COM_Numero = CreateFile(COMnumero, &HC0000000, 0, 0&, &H3, 0, 0)
    If COM_Numero = -1 Then IniciandoPuerto = False: Exit Function
    TimeOut.ReadIntervalTimeout = 50
    TimeOut.ReadTotalTimeoutConstant = 50
    TimeOut.ReadTotalTimeoutMultiplier = 10
    TimeOut.WriteTotalTimeoutConstant = 50
    TimeOut.WriteTotalTimeoutMultiplier = 10
    RetVal = SetCommTimeouts(COM_Numero, TimeOut)
    If RetVal = -1 Then
        RetVal = GetLastError()
        MsgBox "Incapaz de establecer tiempos de espera para los puertos " & COMnumero & " Error: " & RetVal
        RetVal = CloseHandle(COM_Numero)
        IniciandoPuerto = False
        Exit Function
    End If
    RetVal = BuildCommDCB(AjusteCOM, BarDCB)
    If RetVal = -1 Then
        RetVal = GetLastError()
        MsgBox "Incapaz de construir COM DCB " & AjusteCOM & " Error: " & RetVal
        RetVal = CloseHandle(COM_Numero)
        IniciandoPuerto = False
        Exit Function
    End If
    RetVal = SetCommState(COM_Numero, BarDCB)
    If RetVal = -1 Then
        RetVal = GetLastError()
        MsgBox "Incapaz de establecer COM DCB " & AjusteCOM & " Error: " & RetVal
        RetVal = CloseHandle(COM_Numero)
        IniciandoPuerto = False
        Exit Function
    End If
IniciandoPuerto = True
VerError:
    Exit Function
End Function
Private Function LeyendoPuerto() As String
On Error GoTo VerError
    Dim RetBytes As Long, i As Integer, ReadStr As String, RetVal As Long
    Dim CheckTotal As Integer
    RetVal = ReadFile(COM_Numero, LeeBytes(0), 22, RetBytes, 0) 'ReadFile(COM_Numero, LeeBytes(0), 255, RetBytes, 0)
    ReadStr = ""
    If (RetBytes > 0) Then
        For i = 0 To RetBytes - 1
            ReadStr = ReadStr & Chr(LeeBytes(i))
        Next i
    Else
        NivelarCOM
    End If
    LeyendoPuerto = ReadStr
VerError:
    Exit Function
    
End Function
Private Function EscribePuerto(COMString As String) As Integer
On Error GoTo VerError
    Dim RetBytes As Long, LenVal As Long
    Dim RetVal As Long
    If Len(COMString) > 255 Then
        EscribePuerto left$(COMString, 255)
        EscribePuerto right$(COMString, Len(COMString) - 255)
        Exit Function
    End If
    For LenVal = 0 To Len(COMString) - 1
        LeeBytes(LenVal) = Asc(Mid$(COMString, LenVal + 1, 1))
    Next LenVal
    LeeBytes(LenVal) = 0
    RetVal = WriteFile(COM_Numero, LeeBytes(0), Len(COMString), RetBytes, ByVal CLng(0))
    NivelarCOM
    EscribePuerto = RetBytes
VerError:
    Exit Function
End Function
Function ChequeaPuerto(Puerto As Long) As Boolean
    Dim hPort As Long
    Dim sPort As String
    Dim sa As SECURITY_ATTRIBUTES
    If Val(Puerto) > 0 Then
        sPort = "\\.\COM" & Puerto
        hPort = CreateFile1(sPort, _
                                    0, _
                                    FILE_SHARE_READ Or FILE_SHARE_WRITE, _
                                    sa, _
                                    OPEN_EXISTING, _
                                    FILE_ATTRIBUTE_NORMAL, 0)
    If hPort Then CloseHandle hPort
     ChequeaPuerto = hPort > 0
        Else
     ChequeaPuerto = False
    End If
End Function
Function SoloNumeros(Cadena As String) As String
    Dim c As Integer
    For c = 1 To Len(Cadena)
    If InStr("0123456789", Mid$(Cadena, c, 1)) Then '(".0123456789", Mid$(Cadena, c, 1)) Then
        SoloNumeros = SoloNumeros & Mid$(Cadena, c, 1)
        SoloNumeros = Replace(SoloNumeros, ".", ",")
    End If
    Next
End Function
Function PuertoChequeado() As Boolean
On Local Error GoTo VerError
Dim bdPuerto, Read As String
Dim Res As Double
If DLookup("IsBalanza", "PuertoCOM", "IdPuerto=1") = -1 Then
bdPuerto = DLookup("PuertoEs", "PuertoCOM", "IdPuerto=1")
Call IniciandoPuerto("\\.\COM" & bdPuerto, PuertoConfig)
    Sleep 200
    EscribePuerto "$"
    EscribePuerto (Chr$(13))
    Sleep 350
    Read = LeyendoPuerto()
    If InStr(1, Read, "RSSI") > 0 Or InStr(1, Read, "^") > 0 Then
    Read = Null
    End If
    Res = CDbl(SoloNumeros(Read))
    PuertoChequeado = True
End If
Exit Function
VerError:
Select Case err.Number
Case 13, 94
Call CerrarPuerto
MsgBox "Error #  " & err.Number & vbCrLf & "No hay comunicacion al Puerto Serial COM " & bdPuerto & vbCrLf & vbCrLf & _
"Asegurese el cable este conectado y la Balanza este encendida" & vbCrLf & _
"Y vuelva a oprimir el boton ESCANEAR NUEVAMENTE" & vbCrLf & vbCrLf & _
"O bien no dispone de una Balanza electronica conectada al Soft" & vbCrLf & _
"De ser asi, DESACTIVE la opcion recordar la balanza", vbInformation
Case Else
MsgBox "Error #  " & err.Number & vbCrLf & err.Description, vbInformation
End Select
End Function
Function LeerLaBalanza() As Double
On Local Error GoTo VerError
    EscribePuerto "$"
    EscribePuerto (Chr$(13))
    Sleep 100
    LeerLaBalanza = SoloNumeros(LeyendoPuerto())
Exit Function
VerError:
If err.Number <> 13 Then MsgBox "Error #  " & err.Number & vbCrLf & err.Description, vbInformation
End Function

Modulo 2
Option Compare Database

Option Explicit

Declare Function WriteFile& Lib "kernel32" _
    (ByVal hFile As Long, lpBuffer As Any, _
    ByVal nNumberOfBytesToWrite&, _
    lpNumberOfBytesWritten&, ByVal lpOverlapped&)
    
Declare Function CreateFile& Lib "kernel32" Alias "CreateFileA" _
    (ByVal lpFileName$, ByVal dwDesiredAccess&, _
    ByVal dwShareMode&, ByVal lpSecurityAttributes&, _
    ByVal dwCreationDisposition&, ByVal dwFlagsAndAttributes&, _
    ByVal hTemplateFile&)
    
Declare Function CloseHandle& Lib "kernel32" (ByVal hObject&)
Declare Function FlushFileBuffers& Lib "kernel32" (ByVal hFile&)

Function OCD(Mensaje As String, CommPort As String) As Boolean
Dim bModemCommand(256) As Byte
Dim OpenPort As Long
Dim RetVal As Long, RetBytes As Long, i As Integer
OCD = False
OpenPort = CreateFile(CommPort, &HC0000000, 0, 0, 3, 0, 0)
If OpenPort = -1 Then
    MsgBox "Error al abrir el puerto " & CommPort
    Exit Function
End If
For i = 0 To Len(Mensaje) - 1
    bModemCommand(i) = Asc(Mid(Mensaje, i + 1, 1))
Next
RetVal = WriteFile(OpenPort, bModemCommand(0), Len(Mensaje), RetBytes, 0)
If RetVal = 0 Then
    MsgBox "Error al escribir en " & CommPort
Else
    RetVal = FlushFileBuffers(OpenPort)
    OCD = True
End If
RetVal = CloseHandle(OpenPort)
End Function


Evento aplicado en el formulario para traer el dato del peso:
Private Sub Form_Load()
'Me.VerificaBalanza = 1
 'EL CODIGO SE PUEDE USAR DE DOS FORMAS
    'BuscandoPuerto Me.EtiInfo 'INDICANDO QUE EL FORM TIENE UNA ETIQUETA QUE INFORMA
    BuscandoPuerto 'O ASI QUE NO TIENE ETIQUETA PARA INFORMAR
    Op = 2: Me.TimerInterval = 5
    Me.PesoVal = 0
    Me.PesoVal = LeerLaBalanza
    CerrarPuerto
    Si esta abierto Facturacion Pos
    If CurrentProject.AllForms("FacturacionPos-Supermercado").IsLoaded Then
        Me.PrecioMedid = Forms![FacturacionPos-Supermercado]!VlrUnit
        Me.ProduBascula = Forms![FacturacionPos-Supermercado]!nomProducto & " * " & Forms![FacturacionPos-Supermercado]!PRESENT
        Me.ValPesaje = (PrecioMedid * PesoVal) / 1000
    ElseIf Me.PesoVal > 0 Then
        Me.Comando5.SetFocus
    ElseIf Me.PesoVal = 0 Then
        PesoVal.SetFocus
    End If

End Sub


Actualmente lee el puerto, pero a veces bloquea el equipo y se pone super lento, que toca desconectar la bascula, esta es serial, pero tiene un cable adaptador USB.
J.Gabriel Hernandez
Arriba
IvoneR2017 Ver desplegable
Habitual
Habitual
Avatar

Unido: 02/Marzo/2018
Localización: Costa Rica
Estado: Sin conexión
Puntos: 81
Opciones de entrada Opciones de entrada   Gracias (0) Gracias(0)   Cita IvoneR2017 Cita  ResponderRespuesta Enlace directo a este mensaje Enviado: 05/Diciembre/2018 a las 22:47
Juan G. ese es el código que usamos en su momento, pero te confieso que hace rato desistimos de proyectos que usen ese tipo de báscula por que como te comento dan mucho lio. La otra opcion es usar software de terceros que hacen ese puente entre el aplicativo que desarrollas y la bascula, googlea un poco y lo encuentras, nosotros decidimos usar esta ultima alternativa por los problemas que te comento. Saludos

aqui un punto de partida
https://www.mt.com/mt_ext_files/Editorial/Generic/8/MTConnections_0x000010083ef9f5e84001f1d4_files/MTConnections_Brochure_2S.pdf

Dar las gracias impulsa el deseo de respuestas!!
Arriba
jghernandez15 Ver desplegable
Nuevo
Nuevo
Avatar

Unido: 03/Mayo/2016
Localización: Colombia
Estado: Sin conexión
Puntos: 5
Opciones de entrada Opciones de entrada   Gracias (0) Gracias(0)   Cita jghernandez15 Cita  ResponderRespuesta Enlace directo a este mensaje Enviado: 05/Diciembre/2018 a las 23:06
Ok ivone, si es muy inestable, mas he utilizado también las interfaz como Billproduction, pero la licencia se limita x equipo y se pierde si se formatea, mas sin embargo da guerra algunas vece, ya que apaga el teclado numérico o se de-sincroniza. Pense que al tiempo de hoy ya habia algun codigo estable.Llorar
J.Gabriel Hernandez
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable