Savoir si et se connecter au net

Commenter

Contenu du snippet

Savoir si et se connecter au NET et quelques outils pouvant servir
Attendre dans une procédure que le prg lancé soit exécuté
ExecuteAndWait

cmdConnect_Click permet de tester si une connection INTERNET existe sinon on
se connecte par téléphone en utilisant les parametres de MaConnection

ouvre la messagerie pour composer puis envoi d'un mail
ex ='VBHref "mailto:jean-paul.faidherbe@wanadoo.fr?subject=COUCOU"
ou se connecte sur URL
Foo = ShellExecute(hWnd, "Open", "http://perso.wanadoo.fr/jean-paul.faidherbe", "", "", 1)

ShellExecute(hWnd, "Open", strURL, "", "", 1)

Source / Exemple : 


Public Declare Function RasGetConnectStatus Lib "RasApi32.DLL" Alias "RasGetConnectStatusA" (ByVal hRasConn As Long, lpRASCONNSTATUS As Any) As Long
Public Declare Function RasEnumConnections Lib "RasApi32.DLL" Alias "RasEnumConnectionsA" (lpRasConn As Any, lpcb As Long, lpcConnections As Long) As Long
Public Declare Function RasHangUp Lib "RasApi32.DLL" Alias "RasHangUpA" (ByVal hRasConn As Long) As Long

Public Const RAS_MAXENTRYNAME As Integer = 256
Public Const RAS_MAXDEVICETYPE As Integer = 16
Public Const RAS_MAXDEVICENAME As Integer = 128
Public Const RAS_RASCONNSIZE As Integer = 412

Type RasEntryName
    dwSize As Long
    szEntryName(RAS_MAXENTRYNAME) As Byte
End Type

Public Type RasConn
    dwSize As Long
    hRasConn As Long
    szEntryName(RAS_MAXENTRYNAME) As Byte
    szDeviceType(RAS_MAXDEVICETYPE) As Byte
    szDeviceName(RAS_MAXDEVICENAME) As Byte
End Type

Global lpRasConn(255) As RasConn
Global lpcb As Long
Global lpcConnections As Long
Global hRasConn As Long

Global gstrISPName As String
Global ReturnCode As Long

    Global ChaineConnect$
    Global NomConnection As String
    Global NomUtilisateur As String
    Global MotDePasse As String
    Global NumeroTelephone As String
    Global NomServeurSMTP As String
    Global AdressDestinataire As String
    Global AdressExpediteur  As String
    Global AdressCopy  As String
    Global TypeConnect  As String

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function SleepEx Lib "kernel32" (ByVal dwMilliseconds As Long, ByVal bAlertable As Long) As Long
Public Declare Function GetKeyState Lib "USER32" (ByVal nVirtKey As Long) As Integer
Public Declare Function GetInputState Lib "USER32" () As Long

Public Declare Function SetWindowPos Lib "USER32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function ExitWindowsEx Lib "USER32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Public Declare Function GetDesktopWindow Lib "USER32" () As Long

Private Type PROCESS_INFORMATION
      hProcess As Long
      hThread As Long
      dwProcessID As Long
      dwThreadID As Long
End Type

      Private Type STARTUPINFO
         cb As Long
         lpReserved As String
         lpDesktop As String
         lpTitle As String
         dwX As Long
         dwY As Long
         dwXSize As Long
         dwYSize As Long
         dwXCountChars As Long
         dwYCountChars As Long
         dwFillAttribute As Long
         dwFlags As Long
         wShowWindow As Integer
         cbReserved2 As Integer
         lpReserved2 As Long
         hStdInput As Long
         hStdOutput As Long
         hStdError As Long
      End Type

      Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
         hHandle As Long, ByVal dwMilliseconds As Long) As Long

      Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
         lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _
         lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
         ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
         ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
         lpStartupInfo As STARTUPINFO, lpProcessInformation As _
         PROCESS_INFORMATION) As Long

      Private Declare Function CloseHandle Lib "kernel32" (ByVal _
         hObject As Long) As Long

      Private Const NORMAL_PRIORITY_CLASS = &H20&
      Private Const INFINITE = -1&
      Const SYNCHRONIZE = 1048576
      
   Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal _
      dwAccess As Long, ByVal fInherit As Integer, ByVal hObject _
      As Long) As Long

   Private Declare Function TerminateProcess Lib "kernel32" (ByVal _
      hProcess As Long, ByVal uExitCode As Long) As Long

Public Const EWX_SHUTDOWN = 1
Public Const VK_CAPITAL = &H14
Public Const VK_NUMLOCK = &H90

Public Const SWP_HIDEWINDOW = &H80
Public Const SWP_SHOWWINDOW = &H40

Public Type KeyboardBytes
    KbByte(0 To 255) As Byte
End Type

Public kbArray As KeyboardBytes
Public Declare Function GetKeyboardState Lib "USER32" (kbArray As KeyboardBytes) As Long
Public Declare Function SetKeyboardState Lib "USER32" (kbArray As KeyboardBytes) As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Declare Function GetTickCount Lib "kernel32" () As Long

'-------------------------------
Sub AttenteTick(temps As Single)
' un timer précis !!
'-------------------------------

'/Start est un réel
'Fini  est un réel
'//si Temps =0.1 soit 100 Millsecondes
'//alors temps=temps * 1000
''''''''''''' Temps = Temps * 1000
Dim lgTime As Long
lgTime = GetTickCount
Do While lgTime + temps > GetTickCount
    DoEvents
    DoEvents
    DoEvents
Loop
    'Debug.Print (GetTickCount - lgTime) / 1000
End Sub

'============================
Private Sub cmdConnect_Click()
'============================
Dim I%, Rc%
Dim ReturnCode
Dim EssaiADSL
Dim str$

 ' Rasphone
            ReturnCode = RasEnumConnections(lpRasConn(0), lpcb, lpcConnections)
            If lpcConnections = 0 Then
                   Rc = ConnectTelephone
                   If Rc >= 0 Then
'                        GoTo prepareZip
                    Else'
                        msgbox("Pas de connection Valide sur Internet "
                        Exit Sub
                    End If
            End If
end sub 

'==========================================
Public Function ConnectTelephone()
'==========================================
Dim I%, J%
Dim Rc%

lpRasConn(0).dwSize = RAS_RASCONNSIZE
lpcb = RAS_MAXENTRYNAME * lpRasConn(0).dwSize
lpcConnections = 0
ReturnCode = RasEnumConnections(lpRasConn(0), lpcb, lpcConnections)
stbEtat.Panels(1) = " Demande de Connexion vers  " & NomConnection
        If lpcConnections = 1 Then
            ConnectTelephone = Rc
            GoTo OK
        End If
        
            Rem    Composition de l'entrée RAS
            Rem   -----------------------------
#If RASPHONE Then
' MaConnection est à déclarer dans les connexions 
' avec login mot de passe  etc................................
' cette fonction attend ici que rasphone soit fini 
' si abandon de  la connection ou non réussie on passe à SUITE
		Rc = ExecCmd("rasphone  -d   MaConnection") ' ET aTTENDRE
                Rem    Fermeture de l'entrée RAS
                Rem   ---------------------------                'RASPHONE -h %1
#End If
SUITE:
' qui dit si on est connecté ou pas 
            ReturnCode = RasEnumConnections(lpRasConn(0), lpcb, lpcConnections)
                If lpcConnections = 0 Then ' Abandon ou pas de tonalité
                    stbEtat.Panels(1) = " Pas Connecté à " & NomConnection
                    ConnectTelephone = -1
                    Exit Function
                End If
            ConnectTelephone = Rc
OK:
        stbEtat.Panels(1) = " Connecté à " & NomConnection
'        Rc = sndPlaySound(App.Path & "\acqcoucou.wav", 1)
End Function

'================='=================
      Public Function ExecCmd(cmdline As String)
'================='=================
         Dim proc As PROCESS_INFORMATION
         Dim start As STARTUPINFO
         Dim ReturnValue
Dim Retour
         ' Initialize the STARTUPINFO structure:
         start.cb = Len(start)
    ' Start the shelled application:
         ReturnValue = CreateProcessA(0&, cmdline$, 0&, 0&, 1&, _
            NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)

         ' INFINITE
         ReturnValue = WaitForSingleObject(proc.hProcess, INFINITE)
            Retour = ReturnValue
            Attente (0.1)
         ReturnValue = CloseHandle(proc.hProcess)
            Attente (0.1)
            ExecCmd = Retour
            
      End Function

'=============================
Public Sub VBHref(strURL As String)
'=============================
Dim Foo As String
    Foo = ShellExecute(hWnd, "Open", strURL, "", "", 1)
End Sub

     
'=================
Public Function Testing()
'=================
Dim Rc
         Rc = ExecCmd("NOTEPAD.EXE")
         MsgBox "Process Finished"
End Function

'=============================
Sub AlerteSon(Fichier)
'=============================
Dim Rc
Rc = sndPlaySound(App.Path & "\" & Fichier & ".wav", 3)
End Sub

' en bonus des fonctions utiles 

'============================
Public Sub Majuscule(ON_OFF As Integer)
'============================
Dim L As Long
 'L = GetKeyboardState(kbArray)
 GetKeyboardState kbArray
kbArray.KbByte(VK_CAPITAL) = ON_OFF
'L = SetKeyboardState(kbArray)
SetKeyboardState kbArray
End Sub
'============================
Public Sub NumLock(ON_OFF As Integer)
'============================
Dim L As Long
L = GetKeyboardState(kbArray)
kbArray.KbByte(VK_NUMLOCK) = ON_OFF
L = SetKeyboardState(kbArray)
End Sub

'============================
Public Function FermeWindows() As Long
'============================
    FermeWindows = ExitWindowsEx(EWX_SHUTDOWN, 0)
End Function

'============================
Public Sub CacheBarreTache()
'============================
Dim Thwnd As Long
Thwnd = FindWindow("Shell_traywnd", "")
Call SetWindowPos(Thwnd, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
End Sub
'============================
Public Sub VoirBarreTache()
'============================
Dim Thwnd As Long
Thwnd = FindWindow("Shell_traywnd", "")
Call SetWindowPos(Thwnd, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
End Sub

'============================
Public Function DecToBinaire(Valeur As Variant) As String
'============================
' rend une chaine avec des 1 & 0
Dim MaBoucle As Integer

'If Valeur And (2 ^ 31) Then
If Valeur >= 2 ^ 31 Then
    DecToBinaire = "-1"
    Exit Function
End If
Do
    If (Valeur And 2 ^ MaBoucle) = 2 ^ MaBoucle Then
        DecToBinaire = "1" & DecToBinaire
    Else
        DecToBinaire = "0" & DecToBinaire
    End If
    MaBoucle = MaBoucle + 1
Loop Until 2 ^ MaBoucle > Valeur

End Function

'-----------------------------------------------------
Public Sub FondDegrade(frmCall As Form)
'------------------------------------------------------
' Cette fonction permet de faire un fond en dégradé sur la fenêtre passé en paramètre.
' Pour faire varier les couleurs, il suffit de jouer avec la fonction RGB,
' pour un dégradé noir vers bleu on prend par exemple RGB(0, 0, lgFor / lgInc).
' Pour conserver son aspect dégradé il est conseillé d'appelé cette fonction
' dans l'évènement Resize de la fenêtre.
Dim lgFor As Long, lgWidth As Long, lgInc As Long
    frmCall.AutoRedraw = True
    frmCall.DrawWidth = 2
    frmCall.DrawStyle = 6
    lgWidth = frmCall.Width
    lgInc = frmCall.Height / 256
    For lgFor = 0 To frmCall.Height Step lgInc
        frmCall.Line (0, lgFor)-(lgWidth, lgFor + lgInc), RGB(256, lgFor / lgInc, 0), BF
    Next lgFor
End Sub

'-----------------------------------------------------
Public Sub FondImageDegrade(frmCall As Object)
'------------------------------------------------------
' Cette fonction permet de faire un fond en dégradé sur la fenêtre passé en paramètre.
' Pour faire varier les couleurs, il suffit de jouer avec la fonction RGB,
' pour un dégradé noir vers bleu on prend par exemple RGB(0, 0, lgFor / lgInc).
' Pour conserver son aspect dégradé il est conseillé d'appelé cette fonction
' dans l'évènement Resize de la fenêtre.
Dim lgFor As Long, lgWidth As Long, lgInc As Long
    frmCall.AutoRedraw = True
    frmCall.DrawWidth = 2
    frmCall.DrawStyle = 6
    lgWidth = frmCall.Width
    lgInc = frmCall.Height / 256
    For lgFor = 0 To frmCall.Height Step lgInc
        frmCall.Line (0, lgFor)-(lgWidth, lgFor + lgInc), RGB(256, lgFor / lgInc, 0), BF
    Next lgFor
End Sub

'================='=================
      Public Sub ExploreFolder(FormName As Long, FolderName As String)
'================='=================
    On Error Resume Next
    Dim X As Long
    X = ShellExecute(FormName, "Explore", FolderName, 0&, 0&, SW_SHOWMAXIMIZED)
End Sub

'================='=================
Public Sub ExecuteAndWait(cmdline As String)
'================='=================
    Dim NameOfProc As PROCESS_INFORMATION
    Dim NameStart As STARTUPINFO
    Dim X As Long
    NameStart.cb = Len(NameStart)
    X = CreateProcessA(0&, cmdline$, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, NameStart, NameOfProc)
    X = WaitForSingleObject(NameOfProc.hProcess, INFINITE)
    X = CloseHandle(NameOfProc.hProcess)
End Sub

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_jipef)