VBA – VBS

En passant

LES CONSTANTES
Syntaxe : Const ExConstante = 0

Tableaux statiques de constantes
ListeJours = Array(« Lundi », »Mardi », …. , »Vendredi », »Samedi »)
valeur minimale des index du tableau : LBound(ListeJours) = 0
valeur maximale des index du tableau : UBound(ListeJours) = 6

Exemples de constantes

bleufonce = 47: mauve=39: vert=35: jaune=19: orange=40: rouge0=22 : rouge1=3 : violet=39: bleu0=24: bleu1=17: bleu2=47 : blanc=2: gris20=15: gris40=48: gris60=16 : gris80=56: noir=1: rose=38: marron=53: vertfonce=14

LES VARIABLES
Syntaxe : Dim ExempleVariable as string

Portée des variables
projet : Public Dim VarAPortéeGlobale as string
module : Private Dim VarAPortéeModule as string
fonction/procédure : Dim VarAPortéeLocale as string

Picture

LES TYPES
Définition d’un nouveau Type :

Type Texemple
  Sheet As Sheets  
  Cat As String 
  Cell As Range
End Type

Utilisation du Type Texemple

Dim Exemple as Texemple '(Exemple.Sheet, Exemple.Cat, Exemple.Cell)

Picture

LES CHAINES DE CARACTERES

Transfo ASCII en caractères : Chr(34)
Transfo Caractère en code ASCII : Asc(« A »)
String(20,x) = xxxxxxxxxxxxxxxxxxxx
space(20) =
Len(« toto ») = 4
InStr(« toto », »o ») = 2
Lcase(« TOTO ») = toto
UCase(« toto ») = TOTO
Left(« Fabrice »,3) = « fab »
Right(« Fabrice »,3) = « ice »
mid(« Fabrice »,5,2) = « ic »


monTab = split("c/de/fgt","/") (montab(0) = "c" , montab(1) = "de" , montab(2) = "fgt" )
Supprimer les espaces des extremitées d'une chaine de caractères : **Trim**(" toto ") = "toto"
Supprimer les espaces de l'extremitées droite d'une chaine de caractères : **RTrim**(" toto ") = " toto"
Supprimer les espaces de l'extremitées gauche d'une chaine de caractères : **LTrim**(" toto ") = "toto "
remplacer les virgules par des points : strNew = Replace(strOld,",",".")

![Picture](http://nicosurfgadgets.weebly.com/uploads/3/3/9/9/3399316/5476495.png?697)

**LES ROUTINES**
Les routines du VBS sont de deux types : les fonctions qui sont des suites d'instructions retournant une valeur et les procédures qui sont elles aussi des suite d'instructions mais qui ne retournent pas de valeur.
**Portées des routines:**
Public:elle sera accessible à toutes les autres routines dans tous les autres modules de tous les projets actifs (défaut).
Private : si elle sera seulement accessible à d'autres procédures dans le même module.
Static : Les valeurs des variables déclarées dans cette Function sont préservées entre les appels VBA d'Excel.

**Les procédures**
Le test de présence d'une variable lors d'un appel à une procedure se fait avec l'instruction IsMissing
```VBS
Sub ExempleProcédureInit(arg1 as integer ,arg2 as string, optional arg3 as string)
if ismissing(arg3) then action1 else action2
End Sub

Les fonctions

Function exemple_de_fontion(arg1 as integer ,arg2 as string) as boolean  
echo "coucou"
End Function Public

LES TRIS des cellules

range("D1:D6").Sort Key1:=Range(myrange), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,DataOption1:=xlSortNormal  
Selection.Sort Key1:=Range(Cells(startline, Column\_selected), Cells(Endline,Column\_selected)),  
Order1:=xlAscending, Key2:=Range(Cells(startline,ConsoCat\_status.column), Cells(Endline, ConsoCat\_status.column)),  
Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,  
DataOption1:=xlSortTextAsNumbers, DataOption2:=xlSortNormal,
DataOption3:=xlSortNormal

LES BOUCLES

Boucles for | for x = 10 to 0 Step -1 action Next
Boucles for each | for each cellule in selected_range action Next
Boucles DO | x = 0 Do action loop Until test
Boucles While | x = 0 While test action Wend

LES FORMATS & DATES

Format(Date, "yy/mmmm/dd")  
n ieme jour de l'année = Format(Date, "y")
Now , time, date  
Nombre de millisecondes écoulées depuis le démarrage du système : **GetTickCount**  
nb de secondes depuis minuit = timmer  
Année = year(date)  
n° du Mois = month(date)  
nom du Mois = monthname(date)  
Jour = day(date)  
Heure = heure(time)  
Heure sur 2 chiffres= Cstr(right("0"& heure(time),2))  
Minute = minute(time)  
Seconde = seconde(time)  
num de série de la date du jour = aujourdhui()  
num de série de la date et de l'heure = maintenant()  
num de série du dern jr du mois = FIN.MOIS(Date\_départ;Mois)  
nb de jrs ouvrés entre 2 dates = NB.JOURS.OUVRES(Date1;Date1;liste\_Jours\_fériés)  
jour de la semaine (de 1 à 7) = JOURSEM(Numéro\_de\_série;Type\_retour)  
Nombre de jours dans le mois = JOUR(DATE(ANNEE(D);MOIS(D)+1;0))

Les converssions
Conv : CBool(), CByte(), CCur(), CDate(), CDbl(), CDec(), CInt(), CLng(), Csng(), Cstr(), Cvar()

LES STRUCTURES CONDITIONNELLES

IF THEN ELESE

Exemple 1 | if test1 then : action1 : Elseif test2 : action2 : Else : action3 : End if  
Exemple 2  | If test1 Then : action1 Else action2
Exemple 3  | If test1 Then {action1, action2}  
Exemple 4  | Valeur = IIF(test;Valeur1;Valeur2)

SELECT CASE

Select case valeur
    case valeur1: action1  
    case valeur2: action2  
End select

LES COLLECTIONS

initialiser le catalogue : Dim oCatalogue : Set oCatalogue = CreateObject("Scripting.Dictionary")  
Ajouter un élément : _oCatalogue.add

LES OBJETS

Set objExcel = CreateObject("Excel.Application")  
Sheets("nom\_de\_la\_feuille").Unprotect  
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True  
ActiveSheet.EnableSelection = xlUnlockedCells  
For Each feuille In Worksheets --- --- Next  
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=Sheet & "A1", TextToDisplay:=""  
Sheets("#1").Unprotect  
Sheets("#1").Copy After:=Sheets(Sheets.Count)  
newsheetname = "#" & Sheets.Count - 2  
Sheets("#1 (2)").name = newsheetname

LES COULEURS
Picture

LES CELLULES

IsNumeric(), IsDate(), IsEmpty()  
Cells(1,3) = range("a3") = \[a3\]  
Couleur_de_la_police_de_caractère = cells(x,y).Font.ColorIndex  
Couleur_de_fond = cells(x,y).Interior.ColorIndex  

Gras : cells(x,y).Font.bold = True  
Italic : cells(x,y).Font.italic = True  
Nom de la police : cells(x,y).Font.name = Arial  
Taille de la police : cells(x,y).Font.size = 12  
Underline : cells(x,y).Font.underline = True

Style_de_ligne = cells(x,y).Borders(bordure).LineStyle { xlNone – xlContinuous }
Taille_bordure = cells(x,y).Borders(bordure).Weight { xlThin – xlMedium – xlThick}
Couleur_des_bordures = cells(x,y).Borders.ColorIndex
Couleur_de_bordure = cells(x,y).Borders(bordure).ColorIndex { xlInsideVertical – xlEdgeTop – xlEdgeBottom – xlEdgeLeft – xlEdgeRight – xlDiagonalDown – xlDiagonalUp }
Valeur_de_la_cellule = cells(x,y).value
Cellule_avant_chgt_de_cellule = Target
Numéro_de_ligne = Cells(x,y).row
Numéro_de_colonne = Cells(x,y).column
Supprimer la ligne de la case D3 : range(« D3 »).Delete Shift:=xlUp ou range(« D3 »).EntireRow.Delete
Ajouter une ligne : Rows(« 10:10 »).Insert Shift:=xlDown
Rechercher un cellule : Set FoundCell = range(« D3:D7 »).Find(valtoseek, LookIn:=xlValues) : FoundLine = IIf (Cellule Is Nothing,0, FoundCell.row)
Fixer la taille de la ligne : Rows(« 10:10 »).RowHeight = 12.75
Selection.UnMerge
Set exemple_objet_cellule = Cells(x,y).offset(x,y)
Set sheet1 = Sheets(« Feuille n°1 »)
Set sheet2 = Sheets(2)

Effacer le contenu des cellules : [A1:A10].ClearContents
Sélectionner plusieurs lignes : sheet.Rows(« 25:43,52:58 »).Select
Sélectionner plusieurs colonnes : sheet.Columns(« A:B », »D:H »).Select
Première ligne de [A1:A10] : [A1:A10].CurrentRegion.Rows(1)
Dernière ligne de [A1:A10] : [A1:A10].CurrentRegion.Rows([A1:A10].CurrentRegion.Rows.Count)
Cellules vides de [A1:A10] : [A1:A10].SpecialCells(xlCellTypeBlanks)
Cellules num de [A1:A10] : [A1:A10].SpecialCells(xlCellTypeConstants, 1) { 1:num – 2:str – 3:str ou num }
Cells commentées de [A1:A10] : [A1:A10].SpecialCells(xlCellTypeComments)
Cellule non vide la plus à droite de [A1:A10] : [A1:A10].End(xlToRight) { xlDown – xlToRight – xlToLeft – xlUp }
Masquer des lignes : Range(« A1 »).EntireRow.Hidden = True

Compter le nb de lignes dans une selection : Selection.rows.Count
Compter le nb de colonnes dans une selection : Selection.Columns.Count

Picture

LES FICHIERS
Change l’attribut : SetAttr FichierUNC, attribut
Utilise le lecteur D comme lecteur courant = ChDrive « D »
Assigne le chemin courant à une variable a a = CurDir
crée un dossier dans le dossier courrant = MkDir « mon_dossier »
supprime un dossier vide dans le dossier courant = RmDir « mon_dossier »
Détruit tous les fichiers .doc du dossier courant = Kill « *.doc »
Utilise « c:\temp » comme nouveau dossier courant = ChDir « c:\temp »]

Dim oShellApp As Object: Set oShellApp = CreateObject(« Shell.Application »)
‘Decompresser tous le fichier searchedFile.txt du zip : toto.zip
oShellApp.Namespace(« c:\FoundFile »).CopyHere oShellApp.Namespace(« c:\toto\toto.zip »).Items.Item(« searchedFile.txt »)
‘Decompresser tous les fichier du zip : toto.zip
oShellApp.Namespace(« c:\FoundFile »).CopyHere oShellApp.Namespace(« c:\toto\toto.zip »).Items

Ouvrir un fichier (en lect seule):open « Fichier.txt » For Input As #1 {fichier n° 1)
Le lire Do While Not EoF(1):Line Input #1, Textline : Msgbox textline:loopFermer ce fichier:Close #1
Ouvrir un fichier (ecriture) :open « Fichier.txt » For output As #1 {fichier n° 1)
ecrire dedans :liste = 0 : Do While liste < liste = » Liste »>
Active une fenetre : Windows(nom_du_fichier).Activate

Sauvegarder un wkbook : ActiveWorkbook.SaveAs Filename:=nom_UNC_du_Fichier, FileFormat:=xlNormal, Password:= » », WriteResPassword:= » », ReadOnlyRecommended:=False, CreateBackup:=False
Fermeture d’une fenetre : ActiveWindow.Close
Quitter sans enregistrer: Private Sub Workbook_BeforeClose(Cancel As Boolean) ActiveWorkbook.Close savechanges:=False End Sub
Fermeture du classeur : wbExcel.Close
Fermeture de l’app Excel: appExcel.Quit
Désallocation mémoire : Set wsExcel = Nothing_

Ouverture d’une feuille excel XLS ou csv
(les fichiers CSV sont des fichiers textes où une ligne du fichier correspond à une ligne de la feuille et les colonnes sont séparées par des ‘;’) ,45, 4,10,23
Dim appExcel As Excel.Application ‘Définition de l’Application Excel
Dim wbExcel As Excel.Workbook ‘Définition du Classeur Excel
Dim wsExcel As Excel.Worksheet ‘Définition de la Feuille Excel
Set appExcel = CreateObject(« Excel.Application ») ‘Ouverture de l’application
Set wbExcel = appExcel.Workbooks.Open(nom_UNC_du_fichier) ‘Ouverture d’un fichier Excel
Set wsExcel = wbExcel.Worksheets(1) ‘wsExcel correspond à la première feuille du fichier_

Spécificité d’un fichier texte avec comme séparateur le ‘;’ commençant à la deuxième ligne et au format Windows(ANSI)
Dim appExcel As Excel.Application ‘Définition de l’Application Excel
Dim wbExcel As Excel.Workbook ‘Définition du Classeur Excel
Dim wsExcel As Excel.Worksheet ‘Définition de la Feuille Excel
Set appExcel = CreateObject(« Excel.Application »)’Ouverture de l’application
Workbooks.OpenText Filename:= nom_UNC_du_fichier, Origin:=xlWindows, StartRow:=2, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote,ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True ‘Ouverture d’un fichier Excel
Set wbExcel=appExcel.ActiveWorkbook
Set wsExcel=wbExcel.ActiveSheet_

LES NOMBRES

retourne la val absolue : Abs(-9) = 9
retourne le signe : Sgn(-9) = -1 {-1 0 1 }
arrondi a l’entier inférieur : Int(13,9) = 13 et Int(-13,1) = -14
Partie entière : Fix(13,9) = 13 et Fix(-13,1) = -13
nb aléat entre [0 – 1[ : Randomizepour initialiser puis Rdn
Modulo : 32 Mod 10 = 2
Puissance : 2^3 = 8
racine carré : SQR(4) = 2
Division complète : 10/3 = 3,33333
Division entière : 10\3 = 3

LES TABLES DE VERITE
[Picture]

IMPRESSION

Sheets(1).PageSetup.LeftFooter = « &Bcommentaire_de_gauche&B »
Sheets(1).PageSetup.CenterFooter = « &8Page &amp;amp;amp;amp;amp;amp;
amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;
amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;
amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;P & of &N »
Sheets(1).PageSetup.RightFooter = « &8Last Saved : &B » & ActiveWorkbook.BuiltinDocumentProperties(« Last save time »)
ActiveSheet.PageSetup.PrintArea = « $B$2:$AH$9 »
ActiveSheet.PrintOut Copies:=1, Collate:=True
Range(« A1:D4 »).PrintOut

LA BARRE DE STATUS
Application.DisplayStatusBar = True
Application.StatusBar = « Message à positionner dans la barre de status »

LES BOITES DE DIALOGUES
MSGBOX
La fonction MsgBox affiche un message dans une boîte de dialogue, attend que l’utilisateur clique sur un bouton, puis renvoie un entier indiquant le bouton choisi par l’utilisateur

reponse = MsgBox(prompt[,Options][,title][,helpfile, context])
reponse = MsgBox(« Question à poser », vbYesNo + vbCritical + vbDefaultButton, « Titreboite »)
Avec option = Type boutons + Style Icône + Bouton par défaut + Modalité de la boite de dialogue

INPUTBOX
La fonction InputBox affiche une invite dans une boîte de dialogue, attend que l’utilisateur tape du texte ou clique sur un bouton, puis renvoie le contenu de la zone de texte sous la forme d’une chaîne de caractère.
reponse = InputBox(prompt[,title][,default][,xpos][,ypos][,helpfile,context])

Picture

valeurs de la variable Type boutons
Picture

valeurs de la variable Style Icône
Picture

valeurs de la variable Bouton par défaut
Picture

valeurs de la variable Modale
Picture

valeurs possible de la réponse de la msgbox
Picture

LES USERFORMS
PréCharger un UserForm : Load UserForm1
Afficher un UserForm : UserForm1.Show
Cacher un UserForm : UserForm1.Hide
Décharger un UserForm : Unload UserForm1

CheckBoxes
Assigner un état clické à une checkBox : Sheets(1).CheckBox1.Value = true

TextBox
Remplir un champ : UserForm1.champ1 = « FR »
Mettre le focus sur un champ : UserForm1.TextBox13.SetFocus
Mettre le focus sur un Bouton : UserForm1.CommandButton1.SetFocus

Ordre de Tabulation
Afin de respecter un ordre de tabulation (« Enter » ou « Tab »)
Picture
Picture

LES EVENEMENTS
OnKey
Lancer la fonction Launchprg lors d’un appui sur la touche « 1 » :
application.onkey « 1 », »launchprg »
Ne fais rien lors d’un appui sur la touche « 1 » : application.onkey « 1 », » »
Rends sa fonction d’origine à la touche « 1 » : application.onkey « 1 »

GESTION DES ERREURS
saute la ligne en cas d’erreur : On Error Resume Next
va à la ligne « finprg: » en cas d’erreur :
On error Goto finprg
xxx xxx
xxx xxx
finprg:
arrete la détéction d’erreur : On Error GoTo 0

L’instruction Exit permet de quitter un bloc Do…Loop : Exit Do
L’instruction Exit permet de quitter un bloc For…Next : Exit For
L’instruction Exit permet de quitter une Function : Exit function
L’instruction Exit permet de quitter un Sub : Exit sub

BOITE A OUTILS
Cette boite à outil contient un ensemble de fonctions complètes, prêtes à l’emploi

Recopie des cellules d’un workbook excel non ouvert
Utilisation : GetDataFromClosedWorkbook nom_fichier_UNC, « F31:F32 », « A1 », False )
Function GetDataFromClosedWorkbook(SourceFile As String, SourceRange As String, TargetRange As range, IncludeFieldNames As Boolean)** _’Requires a reference to the Microsoft ActiveX Data Objects library
Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset, dbConnectionString As String
Dim TargetCell As range, i As Integer
dbConnectionString = « DRIVER={Microsoft Excel Driver (*.xls)}; » & « ReadOnly=1;DBQ= » & SourceFile
Set dbConnection = New ADODB.Connection
On Error GoTo InvalidInput
dbConnection.Open dbConnectionString ‘ open the database connection
Set rs = dbConnection.Execute(« [ » & SourceRange & « ] »)
Set TargetCell = TargetRange.Cells(1, 1)
TargetCell.CopyFromRecordset rs
rs.Close
dbConnection.Close ‘ close the database connection
Set TargetCell = Nothing
Set rs = Nothing
Set dbConnection = Nothing
GetDataFromClosedWorkbook = True
On Error GoTo 0
Exit Function
InvalidInput:
GetDataFromClosedWorkbook = False
End Function

Décompresse un fichier existant (ou non) dans l’un des fichiers zip d’un repertoire
Sub Unzip(FileSearched, ZipFolder, UnzipFolder)
Dim oShellApp As Object: Set oShellApp = CreateObject(« Shell.Application »)
Dim oFSO1: Set oFSO1 = CreateObject(« Scripting.FileSystemObject »)
Dim oZipFolder As Object: Set oZipFolder = oFSO1.GetFolder(ZipFolder)
Dim oFSO2: Set oFSO2 = CreateObject(« Scripting.FileSystemObject »)
Dim ZipFile As Variant
Dim oZipFile As Object
Dim oFileInZipFolder As Object
Dim message
If (oZipFolder.Files.Count > 0) Then
For Each oZipFile In oZipFolder.Files
ZipFile = oZipFile.Name
If (InStr(1, ZipFile, « .zip », 1) > 0) Then
For Each oFileInZipFolder In oShellApp.Namespace(ZipFolder & ZipFile).Items
If oFileInZipFolder.Name = FileSearched Then
If oFSO1.FileExists(UnzipFolder & FileSearched) Then oFSO1.DeleteFile (UnzipFolder & FileSearched)
oShellApp.Namespace(UnzipFolder).CopyHere
oShellApp.Namespace(ZipFolder & ZipFile).Items.Item(FileSearched)
End If
Next
End If
Next
End If
Set oShellApp = Nothing: Set oFSO2 = Nothing: Set oZipFolder = Nothing: Set oZipFile = Nothing: Set oFSO1 = Nothing
End Sub

Retourne « true » si un fichier existe
Private Function FileExist(File As String) As Boolean
Dim L As Long
On Error GoTo FExErr
L = FileLen(File)
FileExist = True
Exit Function
FExErr: FileExist = False
Exit Function
End Function

Retourne « true » si un fichier existe
Private Function FileExist(FileUNC As String) As Boolean
FileExist = IIf (Dir(fileUNC) = fileUNC,True, False)
End Function

Importe un fichier CSV dans une feuille Excel
Sub importCSVfile(file)
Sheets(« Transfert »).Range(« A1:BB500 »).ClearContents
With Sheets(« Transfert »).QueryTables.Add(Connection:= »TEXT;C:\Report.csv », Destination:=Sheets(« Transfert »).Range(« A1 »))
.Name = « Report »
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 4, 4, 4, 4, 4, 2)
.Refresh BackgroundQuery:=False
End With
Sheets(« Transfert »).Range(« N1 »).FormulaR1C1 = « User »
End Sub_

renvoie les valeurs d’une plage de cellules (srcRange)
d’une feuille (srcSheet) d’un fichier (srcFile) ferme
dans un tableau (outArr) le paramètre TTL indique si
la plage a ou non une ligne d’entêtes
Utilisation : GetExternalData nomduFichier, sourceSheetname, sourcerange, False, Arr
Sub GetExternalData(srcFile As String, srcSheet As String, srcRange As String, TTL As Boolean, outArr As Variant)
Dim myConn As ADODB.Connection, myCmd As ADODB.Command
Dim HDR As String, myRS As ADODB.Recordset, RS_n As Integer, RS_f As Integer
Dim Arr
Set myConn = New ADODB.Connection
If TTL = True Then HDR = « Yes » Else HDR = « No »
myConn.Open « Provider=Microsoft.Jet.OLEDB.4.0; » & « Data Source= » & srcFile & « ; » & « Extended Properties= » »Excel 8.0; » &_
« HDR= »&amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;
amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;
amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp;amp; HDR & « ;IMEX=1; » » »
Set myCmd = New ADODB.Command
myCmd.ActiveConnection = myConn
If srcSheet = «  »
Then myCmd.CommandText = « SELECT * from " & srcRange & " » Else: myCmd.CommandText = « SELECT * from "
&srcSheet & "$" &srcRange & "« 
Set myRS = New ADODB.Recordset
myRS.Open myCmd, , adOpenKeyset, adLockOptimistic
ReDim Arr(1 To myRS.RecordCount, 1 To myRS.Fields.Count)
myRS.MoveFirst
Do While Not myRS.EOF
For RS_n = 1 To myRS.RecordCount ‘lignes
For RS_f = 0 To myRS.Fields.Count – 1 ‘colonnes
Arr(RS_n, RS_f + 1) = myRS.Fields(RS_f).Value
Next
myRS.MoveNext
Next
Loop
myConn.Close
Set myRS = Nothing
Set myCmd = Nothing
Set myConn = Nothing
outArr = Arr
End Sub

Retourne le username de windows
Function UserNameWindows() As String
Dim lngLen As Long
Dim strBuffer As String
Const dhcMaxUserName = 255
strBuffer = Space(dhcMaxUserName)
lngLen = dhcMaxUserName
UserNameWindows = If (CBool(GetUserName(strBuffer, lngLen)) ,Left$(strBuffer, lngLen – 1), » »)
End Function_

déplace le curseur de nb positions vers la direction « direction » {Direction = « {LEFT} », « {RIGHT} »}
Sub arrowkeyleft(nb,direction)
for x = 1 to nb
Application.SendKeys « {LEFT} », True
Next
End Sub

Fermeture Automatique (à mettre dans thiworkbook)
Private Sub Workbook_Open()
Debut = Now
FermAuto
End Sub

**Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Debut = Now
FermAuto1
End Sub

Exemple à mettre ds un module
Option Explicit
Public Debut, DebutS, Annul As Byte
Declare Sub Sleep Lib « kernel32 » (ByVal dwMilliseconds As Long)
Sub FermAuto()
DebutS = Debut + TimeValue(« 02:00:00 ») ‘ Modifier ici la durée – actuellement 2 h sec.
Application.OnTime DebutS, « FermAuto2 »
End Sub

Sub FermAuto1()
On Error Resume Next
Application.OnTime DebutS, « FermAuto2 », , « False »
FermAuto
End Sub

Sub FermAuto2() _UserForm1.Show
Application.OnTime Now + TimeValue(« 00:00:10 »), « FermAuto3 »
End Sub

Sub FermAuto3() _If Annul <> 1 Then
ActiveWorkbook.Save
On Error Resume Next
Application.OnTime DebutS, « Ferauto2 », , « False »
ActiveWorkbook.Close
End If
End Sub

Trouver la position d’un variant dans un array
This function returns the index of an item in a one/two-dimensional array.
The function returns -1 if the item was not found [value: [Variant] Lookup value]
iColumn: (Optional) [Long] If the array has two dimensions, iColumn specifies which column (2nd dimension) will be searched.
iStart: (Optional) [Long] Determines where the search will be started.**
Function FindInArray(value, vArray As Variant, Optional iColumn, Optional iStart) As Long
FindInArray = -1
Dim i As Long, iCol As Long, iSta As Long, iTwo As Long
‘ check if vArray has two dimensions
On Error Resume Next
i = UBound(vArray, 2)
iTwo = IIf(Err.Number = 0, 1, -1)
On Error GoTo 0
‘ check variables
If IsMissing(iColumn) Or Not IsNumeric(iColumn) Then iCol = iTwo Else iCol = CLng(iColumn)
If IsMissing(iStart) Or Not IsNumeric(iStart) Then iSta = LBound(vArray, 1) Else iSta = CLng(iStart)
If iSta < itwo = » -1″ i = » 1″ findinarray = » i » i = » iSta » findinarray = » i »>LanceIE()
Dim IE As Object
Set IE = CreateObject(« InternetExplorer.Application »)
IE.Navigate « http://dj.joss.free.fr« 
IE.AddressBar = True
IE.MenuBar = True
IE.Toolbar = True
IE.Width = 800
IE.Height = 600
IE.Resizable = True
IE.Visible = True
Set IE = Nothing
End Sub

Donne le num de la semaine de la date fournie
Function NOSEM(D As Date) As Long
D = Int(D)
NOSEM = DateSerial(Year(D + (8 – WeekDay(D)) Mod 7 – 3), 1, 1)
NOSEM = ((D – NOSEM – 3 + (WeekDay(NOSEM) + 1) Mod 7)) \ 7 + 1
End Function

The WorkbookIsOpen Function
Private Function WorkbookIsOpen(wbname) As Boolean*
‘ Returns TRUE if the workbook is open
Dim x As Workbook
On Error Resume Next
Set x = Workbooks(wbname)
If Err = 0 Then WorkbookIsOpen = True
Else WorkbookIsOpen = False
End Function

Authentification automatique sur un serveur
Function mapping(SourceServer)
Set oNetwork = CreateObject(« WScript.Network »): Set oDrives = oNetwork.EnumNetworkDrives
mapping = False
Share = « \ » & SourceServer & « \e$ »
For i = 0 To oDrives.Count – 1 Step 2
If LCase(Share) = LCase(oDrives.Item(i + 1)) Then mapping = True: Exit Function
Next
Dim UserName: UserName = InputBox(« Compte », « Authentification sur  » & SourceServer, oNetwork.UserName)
Dim Password: Password = «  »
While Password = «  »: Password = InputBox(« mot de passe pour le Compte  » & UserName, « Authentification sur  » & SourceServer): Wend
On Error Resume Next: oNetwork.MapNetworkDrive «  », « \ » & SourceServer & « \e$ », True, UserName, Password: On Error GoTo 0
If (Err.Number > 0) Then MsgBox Err.Description Else mapping = True
Set oNetwork = Nothing: Set oDrives = Nothing
End Function

‘Password masked inputbox
API functions to be used
Private Declare Function CallNextHookEx Lib « user32 » (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetModuleHandle Lib « kernel32 » Alias « GetModuleHandleA » (ByVal lpModuleName As String) As Long
Private Declare Function SetWindowsHookEx Lib « user32 » Alias « SetWindowsHookExA » (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib « user32 » (ByVal hHook As Long) As Long
Private Declare Function SendDlgItemMessage Lib « user32 » Alias « SendDlgItemMessageA » (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib « user32 » Alias « GetClassNameA » (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib « kernel32 » () As Long_

Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
Private hHook As Long

Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim RetVal
Dim strClassName As String, lngBuffer As Long

If lngCode < HC_ACTION Then NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam): Exit Function
strClassName = String$(256,  » « )
lngBuffer = 255
If lngCode = HCBT_ACTIVATE Then ‘A window has been activated
RetVal = GetClassName(wParam, strClassName, lngBuffer)
If Left$(strClassName, RetVal) = « #32770 » Then SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc(« * »), &H0
‘This changes the edit control so that it display the password character *.
End If
CallNextHookEx hHook, lngCode, wParam, lParam ‘This line will ensure that any other hooks that may be in place are called correctly.
End Function_

Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, Optional YPos, Optional HelpFile, Optional Context) As String
Dim lngModHwnd As Long, lngThreadID As Long
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)
hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
UnhookWindowsHookEx hHook
End Function

Picture
Trucs & astuces
Picture

Activer l’Auto-Completion, au moment de l’écriture des premiers caractères de l’objet, appuyez sur les touches Ctrl+Espace simultanément.
Renforcer la sécurité du code, et forcer la necessité de déclarer chaque variable, il est d’usage de rajouter en début de Module : Option Explicit

LES FONCTIONS D’OPTIMISATION
blocage/déblocage des evenements : Application.EnableEvents = False/True
Activation/Désactivation du rafraîchissement de l’écran : Application.ScreenUpdating = False/True
choix de l’option par défaut pour toutes question : Application.DisplayAlerts = False/True
Calculs manuel : Application.Calculation = xlCalculationManual
Calculs automatique : Application.Calculation = xlCalculationAutomatic
Calculs d’un range : Range(« F2:F8 »).Calculate
Démarrage de prog, 5 secondes après avoir lancé Test : Application.OnTime Now + TimeValue(« 00:00:05 »), « prog »
OnRepeat, OnUndo, OnWindows