-Accueil informatique- / -Logiciels utiles- / -Gifs animés / -Un PC loisir au travail-
-Logiciels faits main- / -Didacticiel VBA 1- / - Didacticiel VBA 2- / -Code VBA libre-
Livre d'or --Plan du site- -Accueil
TOUT PLEIN DE VBA.... |
|
| Pour provoquer une attente dans la procédure | Sub attendre(tps) Do tinit = Timer Do If Timer - tinit > tps Then GoTo azerty End If Loop azerty: End Sub |
| La procédure suivante permet de placer le curseur de la souris dans une position de votre choix | Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Dim rectPos As RECT Call SetCursorPos(xs, ys) End Sub Sub azerty() For i = 1 To 300 PlaceSouris i, 2 * i Next i End Sub |
| La procédure suivante permet de trouver la position de la souris |
Type POINTAPI X As Long Y As Long End Type Declare Sub GetCursorPos Lib "user32" (lpPoint As POINTAPI) Sub azerty() Dim lppt As POINTAPI Call GetCursorPos(lppt) MsgBox lppt.X & "; " & lppt.Y End Sub |
| Pour ecrire et lire dans un fichier quelconque: |
Type Record ' Désigne un type défini par l'utilisateur. ID As Integer Name As String * 20 End Type Public result Sub lit(fichier, pos) Dim MyRecord As Record, position ' Déclare les variables. ' Ouvre l'exemple de fichier en accès aléatoire. Open fichier For Random As #1 Len = Len(MyRecord) ' Lit l'exemple de fichier à l'aide de l'instruction Get. position = pos ' Définit le numéro d'enregistrement. Get #1, position, MyRecord ' Lit le troisième enregistrement. Close #1 ' Ferme le fichier result = MyRecord.Name End Sub Sub ecrit(fichier, pos As Integer, donnee) Dim MyRecord As Record, RecordNumber ' Déclare les variables. ' Ouvre le fichier en accès aléatoire. Open fichier For Random As #1 Len = Len(MyRecord) RecordNumber = pos MyRecord.ID = RecordNumber ' Définit l'identificateur. MyRecord.Name = donnee ' Crée une chaîne. ' Écrit l'enregistrement dans le fichier. Put #1, RecordNumber, MyRecord Close #1 ' Ferme le fichier. End Sub Sub test() ecrit "C:\Nouveau Document texte.txt", 25, "azerty" lit C:\Nouveau Document texte.txt", 25 Cells(1, 1).Select Selection.Value = result End Sub |
| Verifier l'existence d'un fichier: |
Function ExisteFichier(nomfic As String) As Boolean ExisteFichier = (Dir(nomfic) <> "") End Function |
| Creer un repertoire | Sub CREE_REPERTOIRE(Chemin As String) MkDir Chemin End Sub |
| Réalise tout plein d'opération sur les feuilles et le classeur excel comme lister, proteger en masse etc.... |
Public feuille(100), chemclass, nomclass Sub listfeuill() 'liste dans le tab feuille() le nom des feuilles du classeur For i = 1 To Sheets.Count feuille(i) = Sheets(i).Name Next i End Sub Sub ferme() 'Protege toutes les feuilles du classeur Attribute ferme.VB_Description = "" Attribute ferme.VB_ProcData.VB_Invoke_Func = " \n14" For i = 1 To Sheets.Count Sheets(i).Activate Next i ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub Sub ouvre() 'enleve la protection de toutes les feuilles du classeur For i = 1 To Sheets.Count Sheets(i).Activate ActiveSheet.Unprotect Next i End Sub Sub cheminclas() 'Donne le chemin et le nom du classeur chemclass = ActiveWorkbook.Path End Sub Sub nomclas() nomclass = ActiveWorkbook.Name End Sub |
| Ouvre n'importe quel média |
Dim ReturnValue, I Sub azerty() ReturnValue = Shell("C:\Program Files\Windows Media Player\MPLAYER2.EXE", 1) AppActivate ReturnValue SendKeys "^(o)", True SendKeys "C:\WINDOWS\Bureau\Steph\animations et divers\frimeur portuguais.mpg" & "{ENTER}", True ' Envoie des frappes de touches attendre 10 SendKeys "%{F4}", True End Sub Sub attendre(tps) tinit = Timer Do If Timer - tinit > tps Then GoTo azerty End If Loop azerty: End Sub |
Livre d'or --Plan du site- -Accueil