Como determinar si hay o no conexion con servidor

[EAMF]

HOLA A TODOS:

NECESITO UNA AYUDA POR FAVOR, ESTOY DESARROLLANDO UNA APLICACION QUE DEBE FUNCIONAR CON O SIN CONEXION A UN SERVIDOR (VB6, ACCESS), CON CONEXION FUNCIONA BIEN, EL PROBLEMA QUE TENGO ES QUE AL TRATAR DE VERIFICAR LA CONEXION (CUANDO APAGO EL SERVIDOR POR EJEMPLO) SE DEMORA MUCHO, PROMEDIO DE 5 SEGUNDOS, LO CUAL HACE QUE LA APLICACION NO FUNCIONE DE MANERA CORRECTA...

EL PROCESO QUE SE HACE ES EL SIGUIENTE:
TOMA UNA FOTO, GUARDA LOS DATOS DE HORA Y FECHA DE ENTRADA (TODO DE MANERA LOCAL) Y LUEGO SI TENGO CONEXION LO ENVIO AL SERVIDOR, SINO SE VAN ACUMULANDO LAS FOTOS Y LOS REGISTROS HASTA CUANDO REGRESE LA CONEXION.

REALICE LA SEPARACION DE LA PARTE LOCAL DEL ENVIO DE LA INFORMACION AL SERVIDOR, PERO DE IGUAL MANERA SE DEMORA.

SI ALGUIEN TIENE LA MANERA DE DARME UNA MANO LE AGRADECERIA...

SALUDOS Y MIL GRACIAS



USO UN FORM CON UN DIRLISTBOX Y UN FILELISTBOX

Private Sub Form_Load()
DatosConfiguracion

'Ruta de Fotos
Dir1.Path = App.Path & "\Fotos"
File1.Path = Dir1.Path

Guardar_BD_Servidor
End
End Sub

Sub DatosConfiguracion()
'Ubicación de la Base de Datos Principal.mdb
strConnect = ";DATABASE=" & "..\..\DB\Entrada.mdb" & ";PWD=" & "EMIAJ"
Set DBLOCAL = OpenDatabase(App.Path & "\Entrada.mdb", False, False, strConnect)

If Not IsNull(RSLOCAL!RUTABASEDATOSPRINCIPAL) Then
TRutaBaseDatosPrincipal = RSLOCAL!RUTABASEDATOSPRINCIPAL
Else
TRutaBaseDatosPrincipal = ""
MsgBox "La Ruta de la base de datos PRINCIPAL no ha sido definido", vbCritical + vbOKOnly, "Administrador del Sistema"
End If
End Sub

Sub Guardar_BD_Servidor()
File1.Refresh
TotFotos% = File1.ListCount
If TotFotos% = 0 Then
Else
'Colocarse en la primera foto a transferir
File1.ListIndex = 0
NumFoto% = File1.ListIndex

Do While NumFoto% < TotFotos%
DoEvents
File1.ListIndex = NumFoto%
'Copia y Renombra la Foto
NomFoto$ = File1.FileName
On Error Resume Next 'Archivo con el mismo nombre
FileCopy Dir1.Path & "\" & NomFoto$, TRutaBaseDatosPrincipal & "\FotosEntrada\" & NomFoto$
'FileCopy Dir1.Path & "\" & NomFoto$, TRutaBaseDatosPrincipal & "\Fotos\" & NomFoto$
If Err Then Exit Sub
Kill Dir1.Path & "\" & NomFoto$
'Pasar a la siguiente foto
NumFoto% = NumFoto% + 1
Label1.Caption = "ENVIANDO"
Loop
End If
Call Transferencia("BitacoraEntrada")
End Sub

*********************MODULO

Global SinRedGeneral_DB As Database
Global SinRedGeneral_DB2 As Database
Global SinRedGeneral_RS As Recordset
Global SinRedGeneral_RS2 As Recordset

Sub Transferencia(BDX As String)
Dim NUMEROARCHIVO As Integer

'Error Generado
On Error GoTo ErrorGENERADO

Select Case BDX
Case Is = "BitacoraEntrada"

'****Aqui se demora para verificar si hay o no conexion con BD

If Len(Dir(TRutaBaseDatosPrincipal & "\" & BDX & ".mdb")) > 0 Then
'2 Conexión con Base de Datos PRINCIPAL
strConnect = ";DATABASE=" & "..\..\DB\" & TRutaBaseDatosPrincipal & "\" & BDX & ".mdb" & ";PWD=" & "EMIAJ"
Set SinRedGeneral_DB = OpenDatabase(TRutaBaseDatosPrincipal & "\" & BDX & ".mdb", False, False, strConnect)
Set SinRedGeneral_RS = SinRedGeneral_DB.OpenRecordset("Select * From Bitacora")

'3 Conexión con Base de Datos LOCAL (Consulta de transferencia)
strConnect = ";DATABASE=" & "..\..\DB\" & App.Path & "\Principal\" & BDX & ".mdb" & ";PWD=" & "EMIAJ"
Set SinRedGeneral_DB2 = OpenDatabase(App.Path & "\Principal\" & BDX & ".mdb", False, False, strConnect)
Set SinRedGeneral_RS2 = SinRedGeneral_DB2.OpenRecordset("Select * From Bitacora")

'4 Transferencia de Registros Locales a Pirncipales
If Not SinRedGeneral_RS2.EOF Then
DoEvents
SQL = "Insert Into BitacoraPrincipal Select * From Bitacora"
SinRedGeneral_DB2.Execute SQL

DoEvents
'5 Eliminación de Registros Locales
SQL = "Delete From Bitacora"
SinRedGeneral_DB2.Execute SQL
End If
CerrarTransferencia
End If
End Select

'strConnect = ";DATABASE=" & "..\..\DB\" & App.Path & "\Principal\" & BDX & ".mdb" & ";PWD=" & "EMIAJ"

T1$ = App.Path + "\Principal\" & BDX & ".mdb"
T2$ = App.Path + "\Principal\Old" & BDX & ".mdb"

CompactDatabase T1$, T2$, , , ";pwd=EMIAJ"

Kill T1$

Name T2$ As T1$

ErrorGENERADO:
If Err.Number <> 0 Then
Error_Numero = Err.Number
Error_Descripcion = Err.Description
End If

End Sub

Sub CerrarTransferencia()
'Cierre de las Bases de Datos
On Error Resume Next
SinRedGeneral_RS.Close
SinRedGeneral_DB.Close
SinRedGeneral_RS2.Close
SinRedGeneral_DB2.Close
End Sub