Discussion :

[David_Geek]

Je vous invite à partager vos fonctions ou snippets, toute utilité confondue

Voici les miennes ( * -> je ne suis pas l'auteur de certaines de celles-ci) :

1. VirtualBox, partage de dossiers :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
 
Function NetUse_VboxSvr(nom, lecteur)
Set WshNetwork = WScript.CreateObject("WScript.Network")
WshNetwork.MapNetworkDrive lecteur,"\\vboxsvr\" & nom,false
End Function
 
Function PremierLecteurLibre()
Dim oFSO
lecteurs = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Set oFSO = CreateObject("Scripting.FileSystemObject")
For i = 1 To len(lecteurs)
If Not oFSO.DriveExists(Mid(lecteurs, i, 1)) Then
PremierLecteurLibre = Mid(lecteurs, i, 1) & ":"
Exit For
End If
Next
End Function

2. Votre passeport Navigo :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
 
Function GenerateNavigoID() ' Générer un numéro de passeport Navigo
Randomize
For i = 1 To 6
x = Int(9*Rnd)
Str1 = Str1 & CStr(x)
TotStr1 = TotStr1 + x
Next
y = Int(8*Rnd) + 1
Check = TotStr1 Mod y
GenerateNavigoID = Str1 & y & Check
End Function
 
Function CheckNavigoID(StrID) ' Vérification d'un numéro de passeport Navigo
If Len(StrID) <> 8 Then
        CheckNavigoID = "*Err* : ID"
Else
        For i = 1 To 6
                Tmp = Tmp + CInt(Mid(StrID, i, 1))
        Next
        Check = Mid(StrID, 7, 1)
        If Tmp Mod Check = CInt(Mid(StrID, 8, 1)) Then
        CheckNavigoID = True
        Else
        CheckNavigo = False
        End If
End If
End Function

3. Vérification de chaîne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
 
Function ValidWithCharset(str, strCharset) ' Vérifier une chaine selon un charset
For i = 1 To Len(str)
char = Mid(str,i,1)
        For j = 1 To Len(strCharset)
                If char = Mid(strCharset,j,1) Then
                nbchar = nbchar + 1
                Exit For
                End If
        Next
        Next
If nbchar = Len(str) Then
ValidWithCharset = True
Else
ValidWithCharset = False
End If
End Function

4. Créer un serial :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
Function MakeSerial(strserial, spacing, strchar) ' Exemple : MakeSerial("ABCDEF", 2, "-") -> "AB-CD-EF"
If len(strserial) mod spacing = 0 Then
Dim sp()
ReDim sp((len(strserial) /spacing) - 1)
ts = 1
For i = lBound(sp) To uBound(sp)
sp(i) = Mid(strserial, ts, spacing)
ts = ts + spacing
Next
MakeSerial = join(sp, strchar)
Else
MakeSerial = "*ERR* (" & (len(strserial) mod spacing) & ")"
End If
End Function

5. Génération de mot de passe aléatoire * :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
Function PasswordGeneration(intLen)
    Dim i
    Randomize
    Dim strElmts
    Dim intNbElmts
    strElmts = "abcdefghijklmnopqrstuvwxyz" & _
                "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & _
                "0123456789"
    intNbElmts = Len(strElmts)
    PasswordGeneration = ""
    For i = 1 to intLen
        PasswordGeneration = PasswordGeneration & mid(strElmts, Int(rnd * intNbElmts) + 1, 1)
    Next
End Function

6. Ouverture d'un lien avec le navigateur par défaut * :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
 
Sub RunUrl(sUrl, bMaximized)
 Dim oShell
 Set oShell = WScript.CreateObject("WSCript.shell")
 If bMaximized = True Then
    oShell.run sUrl, 3
 Else
    oShell.run sUrl, 1
 End If
 Set oShell = Nothing
End Sub

7. Obtention de votre adresse IP :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 
Function MyIP() ' Extraire l'adresse IP de la page web
MyIP = RechercheInfo(PageResultat("http://www.ip-adress.com/"),"My IP address is: ", "</h2>")
End Function
 
Function PageResultat(page) ' Obtenir le code source d'une page
	Dim objHTTP
	Set objHTTP = CreateObject("Microsoft.XMLHTTP")
                objHTTP.open "GET", page, False
                objHTTP.send ()
		PageResultat = objHTTP.responseText
	Set objHTTP = nothing
End Function
 
Function RechercheInfo(RechercherDans, BaliseDebut, BaliseFin)
        DebutOu = 1
        DebutOu = InStr(DebutOu, RechercherDans, BaliseDebut)
        DebutOu = DebutOu + Len(BaliseDebut)
        FinOu = DebutOu
        FinOu = InStr(FinOu, RechercherDans, BaliseFin)
        RechercheInfo = Mid(RechercherDans, DebutOu, FinOu - DebutOu)
End Function

8. Auto-suppression du script * :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
 
Sub DeleteSelf()
        Dim objFSO
        'Create a File System Object
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        'Delete the currently executing script
        objFSO.DeleteFile WScript.ScriptFullName
        Set objFSO = Nothing
End Sub

9. Rechercher, remplacer * :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
Function FindAndReplace(strInString, strFindString, strReplaceString)
Dim intPtr
If Len(strFindString) > 0 Then 'catch if try to find empty string
Do
intPtr = InStr(strInString, strFindString)
If intPtr > 0 Then
FindAndReplace = FindAndReplace & Left(strInString, intPtr - 1) & _
strReplaceString
strInString = Mid(strInString, intPtr + Len(strFindString))
End If
Loop While intPtr > 0
End If
FindAndReplace = FindAndReplace & strInString
End Function

10. Envoi de messages sur Twitter (rappel : 140 caractères maxi !) * :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
 
Function SendToTwitter(strMessage, strUsername, strPassword)
	Dim objHTTP
	Set objHTTP = CreateObject("Microsoft.XMLHTTP")
                objHTTP.open "POST", "http://twitter.com/statuses/update.xml", false, strUsername, strPassword
		objHTTP.send "status=" & strMessage
		SendToTwitter = objHTTP.responseText
	Set objHTTP = nothing
End Function