'en un módulo coloca esta línea:
Public puertos() As Integer
' en el formulario pondrías esto, que responde a un botón, tu posiblemente deberías ponerlo en el load del formulario o en el main de un módulo si arrancas desde módulo.
Private Sub Command1_Click()
Call Examinar_Puertos
End Sub
' las siguientes funciones las puedes colocar indistintamente en el formulario o en un módulo, irían mejor en un módulo, separado del código de manejo de los controles, pero si lo cambias a un módulo, está 1ª rutina debes hacerla de pribate a public, para que la llamada: 'call Examinar_Puertos' pueda localizarla.
Private Function Examinar_Puertos()
puertos = Detectar_Puertos ' contiene la matriz de los 16 puertos con valores true-false (1-0)
puertos = filtrar_Puertos ' filtramos para obtener sólo los true
If puertos(0) <> 0 Then
' se podrían poner en un listbox para cambiar si un puerto arrojara problemas
' o si eso ocurre se podría volver a ejecutar nuevamente la rutina de detección de puertos
MSComm1.CommPort = puertos(1) ' tomamos el primero de los hallados, es lo más consecuente
MSComm1.PortOpen = True
'MSComm1.Settings= ' establecemos las características que deseemos y qeu sean acorde a nuestro hardware
' otras acciones
Else
MsgBox "No se encontraron puertos disponibles"
End If
End Function
' intenta 'ver' que puertos hay disponibles
Private Function Detectar_Puertos() As Integer()
Dim puertosExistentes(1 To 16) As Integer
Dim nError As Long
Dim PrevioError As ErrObject
Set PrevioError = Err ' guardamos el error previo (si se desea, si no, se puede obviar)
Err.Number = 0 ' reseteamos cualquier posible error previo...
On Local Error GoTo ErrorPuerto ' si se encuentra un errror salta a la etiqueta indicada
For k = 1 To 16
MSComm1.CommPort = k ' aquí esperamos recibir un error
'MSComm1.PortOpen = False
If nError = 0 Then
MSComm1.PortOpen = True ' aquí esperamos recibir un error
If nError = 0 Then
puertosExistentes(k) = 1 ' es ok no generó error
MSComm1.PortOpen = False ' si no se pudo abrir dará error de no está abierto
Else
nError = 0 ' reseteamos error para detedtarlo en el próximo ciclo
End If
Else
nError = 0 ' reseteamos error para detedtarlo en el próximo ciclo
End If
Next
Err = PrevioError ' si asignamos el error previo a la entrada, se lo devolvemos
Detectar_Puertos = puertosExistentes
Exit Function
ErrorPuerto:
nError = Err.Number
' errores 8002, 8005, 8012 ' no está disponible...
MsgBox ".se detectó otro error en el puerto " & k & " el mensaje devuelto fue: " & Err.Description & vbCrLf & _
" ... al cerrar este mensaje se continúa explorando.", vbExclamation, "Explorando puertos ..."
Resume Next ' no salgo, contínuo con la sigte. línea que dió error
End Function
' filtra la matriz de puertos ahora sólo contendrá los disponibles.
' su contenido ahora es el nº de puerto
Private Function filtrar_Puertos() As Integer()
Dim p() As Integer
Dim x As Integer ' contador de puertos 'válidos'
ReDim p(0 To 0) ' p(0) se usa para saber cuantos se encontraron... asegura no devolve una matriz vacía
For k = 1 To 16
If puertos(k) = 1 Then
x = x + 1
ReDim Preserve p(0 To x)
p(x) = k
End If
Next
p(0) = x
filtrar_Puertos = p
End Function