Dll pour vb/vba (5)

Soyez le premier à donner votre avis sur cette source.

Vue 4 857 fois - Téléchargée 219 fois

Description

La dll (6,5 Ko) qui s'etend selon les demandes.
NOUVEAUTES:
- Ecritue registres CURENT_USER et LOCAL_MACHINE.
DEJA FOURNI:
Lecture registres CURENT_USER et LOCAL_MACHINE.
Determine si current user est administrateur.
Vitesse processeur.
Mesures en hautes precisions.
Selecteur de dossiers avec initialisation du dossier de depart.
Existe et taille fichier, place libre sur disque.

Source / Exemple :


' enlever chemin de "D:\bn2Vb.dll", juste pour tests perso
Declare Function bnIsWinNT Lib "D:\bn2Vb.dll" () As Long
Declare Function bnIsUserAdminNT Lib "D:\bn2Vb.dll" () As Long

Declare Function bnIsPrecisionOK Lib "D:\bn2Vb.dll" () As Long
Declare Function bnCpuSpeedMghz Lib "D:\bn2Vb.dll" () As Long
Declare Sub bnTicksStart Lib "D:\bn2Vb.dll" ()
Declare Function bnTicksResult Lib "D:\bn2Vb.dll" () As Double
Declare Sub bnMilliscndStart Lib "D:\bn2Vb.dll" ()
Declare Function bnMilliscndResult Lib "D:\bn2Vb.dll" () As Double

Declare Function bnRegLireStringCU Lib "D:\bn2Vb.dll" (sKey As String, sValue As String, sDest As String) As Long
Declare Function bnRegLireStringLM Lib "D:\bn2Vb.dll" (sKey As String, sValue As String, sDest As String) As Long
' valeurs de retour
' 0 - OK, sDest sera String valide, vide possible
' 1 - cle ou valeur inexistante ou impossible d'ouvrir ou autre
' 2 - type non string
' 3 - defaut de memoire
Declare Function bnRegLireDwordCU Lib "D:\bn2Vb.dll" (sKey As String, sValue As String, lDest As Long) As Long
Declare Function bnRegLireDwordLM Lib "D:\bn2Vb.dll" (sKey As String, sValue As String, lDest As Long) As Long
' valeurs de retour
' 0    - OK, lDest sera valide au retour
' <> 0 - impossible de lire, valeur non DWORD ou autre
Declare Function bnRegEcritStringCU Lib "D:\bn2Vb.dll" (ByVal sKey As String, ByVal sValue As String, ByVal sStr As String) As Long
Declare Function bnRegEcritStringLM Lib "D:\bn2Vb.dll" (ByVal sKey As String, ByVal sValue As String, ByVal sStr As String) As Long
Declare Function bnRegEcritDwordCU Lib "D:\bn2Vb.dll" (ByVal sKey As String, ByVal sValue As String, ByVal lVal As Long) As Long
Declare Function bnRegEcritDwordLM Lib "D:\bn2Vb.dll" (ByVal sKey As String, ByVal sValue As String, ByVal lVal As Long) As Long
' retourne <> 0 si erreur

Declare Function bnSelectDir Lib "D:\bn2Vb.dll" (sTitre As String, sDir As String) As Long
' retourne <> 0 - dossier choisi, sDir sort avec \ final
' retourne 0    - sDir ne change pas
Declare Function bnFileExists Lib "D:\bn2Vb.dll" (ByVal sFile As String) As Long
' retourne <> 0 si fichier existe
Declare Function bnFileSize Lib "D:\bn2Vb.dll" (ByVal sFile As String) As Double
' de 0 => (2^64)-1 qui est le maxi sur win32.
Declare Function bnGetDiskFreeSpace Lib "D:\bn2Vb.dll" (ByVal sRootFile As String) As Double
' peut passer "D:\" ou "C:" ou "D:\toto.txt", va idem.

Sub DireSiUserAdmin()
  Dim res As Long, titre As String
  titre = "ADMIN"
  res = bnIsWinNT()
  If res Then res = bnIsUserAdminNT()
  If res Then
    MsgBox "OUI", vbInformation, titre
  Else
    MsgBox "NON", vbExclamation, titre
  End If
End Sub

Sub TestPrecision()
  If bnIsPrecisionOK Then MsgBox "bnPrecisionOK"
End Sub

Sub DireCpuSpeed()
  If bnIsPrecisionOK Then MsgBox bnCpuSpeedMghz
End Sub

Sub TestTicks()
  Dim res As Double
  If bnIsPrecisionOK = 0 Then Exit Sub
  bnTicksStart
  res = PerdreTemps(9500000)
  MsgBox bnTicksResult
End Sub

Sub TestMillisecondes()
  Dim res As Double
  If bnIsPrecisionOK = 0 Then Exit Sub
  bnMilliscndStart
  res = PerdreTemps(9500000)
  MsgBox bnMilliscndResult
End Sub

Sub litSringCurrentUser()
  Dim lret As Long, sdst As String
  lret = bnRegLireStringCU("Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders", "My Pictures", sdst)
  If lret = 0 Then
    Debug.Print sdst
    Debug.Print Len(sdst)
   Else: Debug.Print "ERROR " & lret
  End If
  lret = bnRegLireStringLM("SOFTWARE\Elaborate Bytes\CloneCD", "Install_Dir", sdst)
  If lret = 0 Then
    Debug.Print sdst
    Debug.Print Len(sdst)
   Else: Debug.Print "ERROR " & lret
  End If
End Sub

Sub LireDwordLocalMachine()
  Dim ldst As Long
  If bnRegLireDwordLM("SOFTWARE\Ahead\Shared", "ResourceCounter", ldst) Then
    Debug.Print "ERROR"
   Else: Debug.Print ldst
  End If
End Sub

Sub EcritStringLocalMachine()
  Dim toIns As String
'  toIns = "Un exemple"
  If bnRegEcritStringLM("SOFTWARE\BruNews\Test", "MaStr", toIns) Then
    MsgBox "ERROR"
   Else: MsgBox "OK"
  End If
End Sub

Sub EcritDwordCurrentUser()
  If bnRegEcritDwordCU("SOFTWARE\BruNews\Test2", "MaStr", 278) Then
    MsgBox "ERROR"
   Else: MsgBox "OK"
  End If
End Sub

Sub ChoisitDossier()
  Dim strDir As String, sTitle As String
  sTitle = "Dossier depuis Excel"
  strDir = "D:\bosser"
  If bnSelectDir(sTitle, strDir) Then Debug.Print strDir
  If bnSelectDir(sTitle, strDir) Then Debug.Print strDir
End Sub

Sub ExisteFichier()
  Dim strFile As String
  strFile = "d:\NTT586.C"
  If bnFileExists(strFile) Then
    MsgBox "OUI"
   Else: MsgBox "NON"
  End If
End Sub

Sub TailleFichier()
  Dim strFile As String
  strFile = "d:\NTT586.C"
  MsgBox strFile, vbInformation, bnFileSize(strFile)
End Sub

Sub LibreSurDisque()
  Dim strFile As String
  strFile = "h:"
  MsgBox strFile, vbInformation, bnGetDiskFreeSpace(strFile)
End Sub

Function PerdreTemps(num As Long) As Double
  Dim d As Double, i As Long
  d = 1.5
  While num
    d = d + 1.5
    d = d - 1
    d = d + i
    num = num - 1
  Wend
  PerdreTemps = d
End Function

Conclusion :


Tous les exemples sont faits sur Excel.
Postez moi vos demandes d'extensions.
Sera fait suivant disponibilite.

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

beeline
Messages postés
83
Date d'inscription
jeudi 20 décembre 2001
Statut
Membre
Dernière intervention
9 juin 2009
-
je comprend pas vraiment se ke fait la fonction :
Function PerdreTemps(num As Long) As Double
Dim d As Double, i As Long
d = 1.5
While num
d = d + 1.5
d = d - 1
d = d + i
num = num - 1
Wend
PerdreTemps = d
End Function

c'é une fonction pour passé le temps ?
BruNews
Messages postés
21054
Date d'inscription
jeudi 23 janvier 2003
Statut
Modérateur
Dernière intervention
7 novembre 2014
13 -
elle est utilisee en dans les exemples de mesure de temps/ticks de procedures. Certain que sinon ne sert proprement a rien.

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.