LISTE DE FONCTIONS VISUAL BASIC
Bas du formulaire
1 - Les premiers
programmes BASIC, où l'on numérotait les lignes, étaient quelque peu
ésotériques
3
- Ce code active la feuille de mot de
passe
4
- Le code du menu contrôle la couleur
et le contenu du label
5
- Ce code met en œuvre des variables et des instructions d'affectation
6
- Comparaison de données avec
instruction If
7
- Test du mot de passe par une
instruction If
8
- Les instructions If imbriquées
permettent des comparaisons plus poussées
9
- L'instruction Exit Sub permet
d'interrompre une procédure
10
- Le mot clé ElseIf permet de combiner
les instructions If... Else
11
- Les instructions Select Case
comparent des valeurs multiples
12
- Comparaisons conditionnelles dans Select Case
13
- Comparaisons de valeurs séquentielles dans Select Case
14
- L'instruction Do existe en plusieurs formats
15
- L'utilisateur n'entre pas toujours
des données valides du premier coup
16
- Les boucles For permettent d'incrémenter une variable compteur
17
- Boucle For avec valeur de Step positive (incrémentation)
18
- Boucle For avec valeur de Step
négative (décrémentation)
19
- Code pour tester l'état de shift
20
- Réception du choix de l'utilisateur
par les boutons d'option
21
- Affichage des drapeaux pour chaque
case cochée
22
- Affichage du drapeau selon le bouton
d'option sélectionné
23
- La première procédure passe des
arguments à la seconde
24
- Les fonctions renvoient à la
procédure appelante une valeur unique
25
- Vérification de variables vides
26
- VarType() permet de déterminer le
type des données passées
27
- Contrairement à CStr(), Str() fait
précéder les nombres positifs d'un blanc
28
- Cette fonction se sert des fonctions
de chaînes pour inverser une chaîne
29
- Chronométrage du temps de réponse de
l'utilisateur
30
- Ce code calcule le prochain jour
ouvrable après la date spécifiée
31
- Format() appliqué aux nombres
32
- Format() appliqué aux dates et heures
33
- Gestion du bouton Annuler
35
- Gestion de la boîte de dialogue
Imprimer
36
- Déterminer quelles touches ont été
frappées conjointement à l'événement souris
37
- La procédure événementielle
initialise le contrôle ListBox
38
- Les tableaux simplifient le stockage
des données
39
- On peut déclarer plus d'éléments que
l'on n'a de données
40
- Programme de recherche de données
41
- L'utilisateur indique au programme la
fin de la série de données
42
- Initialiser la zone de liste et
interroger les sélections multiples
43
- Répondre aux événements souris
44
- La méthode Print écrit directement
sur la feuille
45
- Le point-virgule empêche les sauts de
lignes
46
- Espacement de la sortie de Print à
l'aide des fonctions Tab() et Spc()
47
- Print permet aussi d'insérer des
lignes vierges
48
- Positionnement de la sortie à l'aide
des propriétés CurrentX et CurrentY
49
- La procédure Property Get renvoie la valeur de la propriété
50
- La procédure Property Let affecte une
valeur à la propriété
51
- Création d'une variable de référence
pointant vers la fenêtre fille
52
- FreeFile() permet d'obtenir un numéro
de fichier libre
53
- Ecriture dans un fichier séquentiel
avec Print #
54
- Le point-virgule permet d'écrire
plusieurs valeurs sur une même ligne
55
- Ecriture et lecture dans un fichier
au sein d'une même procédure
56
- Ecriture dans un fichier séquentiel
avec Write
57
- L'instruction Type permet de déclarer
les nouveaux types de données
58
- Les chaînes de longueur fixe
permettent de spécifier la longueur des enregistrements
59
- Ecriture dans un enregistrement
particulier
60
- Les types personnalisés peuvent être
inclus dans un autre type personnalisé
61
- Le type de données public peut servir
dans tous les modules
62
- Chargement du fichier dans un
contrôle zone de liste
63
- Le code prend connaissance de chaque
imprimante du système
64
- Recherche d'une imprimante couleur
sur le système de l'utilisateur
65 - Cette procédure permet d'imprimer les
contrôles de la feuille
66
- Print permet également d'envoyer une
sortie vers la feuille
67
- Affichage d'un message sur la
feuille, puis impression de la feuille
68
- On Error Goto permet de gérer les
erreurs d'impression
69
- Affiche une boîte de message avant de
lancer l'impression
70
- Interroge la valeur de PrReady()
avant d'imprimer
71
- Initialise les zones de liste et
répond aux sélections de l'utilisateur
72
- Dessin d'un motif à l'aide de la
méthode Line, option "cadre"
74
- Initialise les labels avec les
informations d'état
75
- Associe le lecteur vidéo au contrôle
PictureBox
76
- Les barres de défilement modifient la
taille de l'image
77
- La boîte de dialogue Connexion permet
à l'utilisateur de se connecter à votre application
78
- Enregistrer l'objet contrôle
conteneur OLE sur disque
79
- Lire le contenu de l'objet contrôle
conteneur OLE enregistré à la précédente exécution
80
- Utilisation de Add pour ajouter des
éléments à la nouvelle collection
81
- Votre application peut utiliser Excel
pour créer une feuille de calcul
82
- L'assistant a initialisé les valeurs
par défaut des nouvelles propriétés
83
- Vous devez définir les valeurs
énumérées qui s'afficheront dans la fenêtre Propriétés
86
- Vous devez compléter les procédures
Let des deux propriétés
87
- Ces procédures événementielles
permettront de tester le nouveau contrôle ActiveX
88
- Le code de l'animation peut être
simple
89
- Vous pouvez utiliser des méthodes d'écriture des données dans la table par
programmation
91
- Un exemple de VBScript qui montre les
ressemblances avec Visual Basic
92
- Vous pouvez afficher une aide
contextuelle
93
- Vous pouvez analyser les procédures individuelles à un point d'arrêt
94
- Les boucles imbriquées permettent de
parcourir rapidement les tables
95
- Les boucles imbriquées fournissent
des indices pour parcourir tout le tableau
96
- Les éléments d'inventaire
apparaissent souvent dans une table
97
- La procédure Form_Load() initialise
plusieurs valeurs à l'aide de sous-routines
99
- Vous devez initialiser les en-têtes
de la grille et les cellules de données
100
- Les commissions sont affectées en
fonction du contrôle choisi par l'utilisateur
101
- Vous pouvez utiliser l'API Windows
pour déclencher le haut-parleur
102
- Utilisation de l'API Windows pour en
savoir plus sur un disque dans votre application
104
- Exemple de propriété Property
106
- Code de l'application Livre des
contacts
107
- Procédure UserForm_Initialize
108
- Procédure cboContactList_Change
116
- Code de l'écran Recherche
117
- Code de l'écran Recherche par domaine
118
- Code de l'écran Recherche par nom de
salarié
119 - Code du module SearchMod
120
- Fonction listChange du formulaire
SkillSearch.aspx
121
- Fonction Validateskill() du
formulaire SkillSearch.aspx
122 - Fonction moveback() du formulaire SkillSearch.aspx
123
- Code de la fonction cmdOK_Click()
124 - Fonction OpenStandardControlFileAndStoreErrWords()
125 - Fonction OpenScriptAndStartProcessing()
10 REM Ce programme calcule et affiche les 10 premiers carrés.
20 CLS
30 PRINT "Carrés de 1 à 10"
40 PRINT "Valeur", "Carré"
50 FOR N = 1 TO 10
60 PRINT N, (N*N)
70 NEXT N
80 PRINT
90 END
Private Sub cmdExit_DblClick ( )
lblTitle.Caption = "Nouvelle page"
intTotal = intCustNum + 1
End Sub
Private Sub cmdExit_Click()
End
End Sub
Private Sub cmdTest_Click()
' Cette procédure événementielle s'exécute dès que
' l'utilisateur décide de tester le mot de passe saisi
If txtPassword.Text = "SSM" Then
' Mot de passe correct
Beep
Beep ' Affiche l'image
imgPassword.Picture =
LoadPicture("C:\Program Files\" _
& "Microsoft Visual
Studio\Common\Graphics\MetaFile\" _
& "Business\coins.wmf")
lblPrompt.Caption = "Aboule le fric !"
Else
lblPrompt.Caption = "Mot de passe incorrect - Essayez encore "
txtPassword.Text = "" ' Efface le mauvais mot de passe
txtPassword.SetFocus ' Met le focus sur la zone de texte
End If
End Sub
Private Sub mnuColorBlue_Click()
' Colore le label en bleu et coche l'option de menu
' Bleu. S'assure que les options Vert
' et Rouge sont toutes les deux décochées.
lblMenu.BackColor = vbBlue
mnuColorBlue.Checked = True
mnuColorGreen.Checked = False
mnuColorRed.Checked = False
End Sub
Private Sub mnuColorGreen_Click()
' Colore le label en vert et coche l'option de menu
' Vert. S'assure que les options Bleu
' et Rouge sont toutes les deux décochées.
lblMenu.BackColor = vbGreen
mnuColorBlue.Checked = False
mnuColorGreen.Checked = True
mnuColorRed.Checked = False
End Sub
Private Sub mnuColorRed_Click()
' Colore le label en rouge et coche l'option de menu
' Rouge. S'assure que les options Bleu
' et Vert sont toutes les deux décochées.
lblMenu.BackColor = vbRed
mnuColorBlue.Checked = Fasle
mnuColorGreen.Checked = False
mnuColorRed.Checked = True
End Sub
Private Sub mnuFileExit_Click()
' Termine le programme
End
End Sub
Private Sub mnuMessageInitial_Click()
' Restaure le texte initial du label et
' coche l'option de menu correspondante.
' S'assure que les autres options sont décochées.
lblMenu.Caption = "Sélectionnez une option de menu"
mnuMessageInitial.Checked = True
mnuMessageProgramming.Checked = False
mnuMessageSimple.Checked = False
End Sub
Private Sub mnuMessageProgramming_Click()
' Change le texte du label et coche
' l'option de menu correspondante.
' S'assure que les autres options sont décochées.
lblMenu.Caption = "La programmation, c'est le pied !"
mnuMessageInitial.Checked = False
mnuMessageProgramming.Checked = True
mnuMessageSimple.Checked = False
End Sub
Private Sub mnuMessageSimple_Click()
' Change le texte du label et coche
' l'option de menu correspondante.
' S'assure que les autres options sont décochées.
lblMenu.Caption = "VB, c'est simple !"
mnuMessageInitial.Checked = False
mnuMessageProgramming.Checked = False
mnuMessageSimple.Checked = True
End Sub
Private Sub cmdCalcPay_Click()
' Calcule les trois variables de la paye.
Dim intHoursWorked As Integer
Dim sngRate As Single, sngTaxRate As
Single
Dim curTaxes As Currency, curGrossPay As
Currency
Dim curNetPay As Currency
' Initialise les variables
' (En réalité, ces données viendraient de
' l'utilisateur ou d'un fichier).
intHoursWorked = 40 ' Total des heures travaillées.
sngRate = 7.8 ' Paye par heure.
sngTaxRate = 0.42 ' Pourcentage de prélèvements.
' Calcule les sommes
curGrossPay = intHoursWorked * sngRate
curTaxes = sngTaxRate * curGrossPay
curNetPay = curGrossPay - curTaxes
' Affiche les résultats dans les labels
lblGrossPay.Caption = curGrossPay
lblTaxes.Caption = curTaxes
lblNetPay.Caption = curNetPay
End Sub
If (curSales > curSalesGoal) Then
' Ce commercial explose ses objectifs
curSalaryBonus = 10000.00
lblSalesNote.Caption = "Objectifs explosés !"
lblSalesNote.BackColor = Red
lblSalesNote.FontBold = True
End If
' Le code continue ici
If txtPassword.Text = "SSM" Then
' Mot de passe correct
Beep
Beep ' Afficher l'image
imgPassword.Picture =
LoadPicture("C:\Program Files\"
& "Microsoft Visual
Studio\Common\Graphics\MetaFile\"
& "Business\coins.wmf")
lblPrompt.Caption = "Aboule le fric !"
Else
lblPrompt.Caption = "Mot de passe incorrect - Essayer encore "
txtPassword.Text = "" ' Efface le mauvais mot de passe
txtPassword.SetFocus ' Met le focus sur la zone de texte
End If
If
(curSales > 100000.00) Then
If (intHrsWorked > 40) Then
curBonus = 7500.00
Else
curBonus = 5000.00
End If
lblBonus.Caption = "Bon boulot !"
End If
Private Sub cmdCalc ()
If (txtSales.Text < 50000.00) Then
Exit Sub ' Interrompt la procédure
Else
' Si le chiffre de vente est au moins
' de 50 000 F, exécute l'instruction
' suivante, qui affiche le bonus comme
' pourcentage des ventes.
lblBonus.Caption = txtSales.Text *
.05
End If
End Sub
If (intHours <= 40) Then
curOverTime = 0.0
' Interroge les heures entre 40 et 50,
' et paye les 50 % d'heures sup.
ElseIf (intHours <= 50) Then
curOverTime = (intHours - 40) * 1.5 *
sngRate
Else
' Au-delà de 50, les heures doivent être payées
' doubles ; entre 40 et 50 heures, la prime
' est de 50 %.
curOverTime = ((intHours - 50) * 2 +
(10 * 1.5)) * sngRate
End If
' Interrogation d'une note scolaire
Select Case txtGrade.Text
Case "A"
lblAnnounce.Caption = "Très
bien"
Case "B"
lblAnnounce.Caption = "Bien"
Case "C"
lblAnnounce.Caption = "Peut mieux faire"
Case "D"
lblAnnounce.Caption = "Médiocre"
Case "E"
lblAnnounce.Caption =
"Mauvais"
Case Else
lblAnnounce.Caption = "Note non validée"
End Select
' Test d'une note scolaire
Select Case txtGrade.Text
Case Is >= 18
lblAnnounce.Caption = "Très
bien"
Case Is >= 15
lblAnnounce.Caption = "Bien"
Case Is >= 12
lblAnnounce.Caption = "Peut mieux
faire"
Case Is >= 10
lblAnnounce.Caption =
"Médiocre"
Case Else
lblAnnounce.Caption = "Mauvais"
End Select
' Interrogation d'une note scolaire
Select Case txtGrade.Text
Case 0 To 9
lblAnnounce.Caption =
"Mauvais"
Case 10 To 11
lblAnnounce.Caption =
"Médiocre"
Case 12 To 14
lblAnnounce.Caption = "Peut mieux
faire"
Case 15 To 17
lblAnnounce.Caption = "Bien"
Case Else
lblAnnounce.Caption = "Très bien"
End Select
Do While intCtr <= 10
' Cette boucle fait la même chose
' que celle de la Figure 6.2
lblOut.Caption = intCtr
intCtr = intCtr + 1
Loop
Dim strAns As String
'
' L'utilisateur doit répondre par Oui ou Non.
lblPrompt.Caption = "Continuer ? (Oui ou Non)"
'
' Stockage de la réponse dans la
' variable chaîne nommée strAns.
' Test de la réponse et réitération
' de la question si nécessaire.
Do While (strAns <> "Oui" And
strAns <> "Non")
Beep ' Avertissement
lblError.Caption = "Merci de répondre par Oui ou Non"
' Stockage de la réponse dans la
' variable chaîne nommée strAns (rebelote).
Loop
' Effacement du message d'erreur.
lblError.Caption = Null
For intCtr = 1 to 10
lblOut.Caption = intCtr
Next
For intCtr = 10 to 100 Step 5
lblOut.Caption = intCtr
Next
For intCtr = 1000 to 0 Step -100
lblOut.Caption = intCtr
Next
Private Sub Text1_KeyDown(KeyCode As Integer,
Shift As Integer)
Dim intShiftState As Integer
intShiftState = Shift And 7 ' "And" binaire
Select Case intShiftState
Case 1
' Code pour les combinaisons Maj
Case 2
' Code pour les combinaisons Ctrl
Case 3
' Code pour les combinaisons Alt
Case 4
' Code pour les combinaisons Maj-Ctrl
Case 5
' Code pour les combinaisons Maj-Alt
Case 6
' Code pour les combinaisons Ctrl-Alt
Case 7
' Code pour les combinaisons Maj-Ctrl-Alt
End Select
End Sub
Private Sub cmdSelect_Click()
' Vérifier l'absence d'erreur puis afficher
' la feuille selon les choix de l'utilisateur.
Dim strMsg As String ' Valeur renvoyée par la boîte de message
If ((optCheck.Value = False) And
(optOption.Value = False)) Then
strMsg = MsgBox("Vous devez sélectionner une option", vbCritical, "Erreur !")
ElseIf (optCheck.Value = True) Then
frmFlagsCheck.Show ' Option cases à cocher.
Else
frmFlagsOpt.Show ' Option boutons d'option.
End If
End Sub
Private Sub Form_Load()
' Désélectionner tous les boutons d'option.
optCheck.Value = False
optOption.Value = False
End Sub
Private Sub cmdExit_Click()
' fermer le programme.
End
End Sub
Private Sub chkEngland_Click()
' Case cochée = drapeau affiché.
If chkEngland.Value = 1 Then
imgEngland.Visible = True
Else
imgEngland.Visible = False
End If
End Sub
Private Sub chkItaly_Click()
' Case cochée = drapeau affiché.
If chkItaly.Value = 1 Then
imgItaly.Visible = True
Else
imgItaly.Visible = False
End If
End Sub
Private Sub chkSpain_Click()
' Case cochée = drapeau affiché.
If chkSpain.Value = 1 Then
imgSpain.Visible = True
Else
imgSpain.Visible = False
End If
End Sub
Private Sub chkMexico_Click()
' Case cochée = drapeau affiché.
If chkMexico.Value = 1 Then
imgMexico.Visible = True
Else
imgMexico.Visible = False
End If
End Sub
Private Sub chkFrance_Click()
' Case cochée = drapeau affiché.
If chkFrance.Value = 1 Then
imgFrance.Visible = True
Else
imgFrance.Visible = False
End If
End Sub
Private Sub chkUSA_Click()
' Case cochée = drapeau affiché.
If chkUSA.Value = 1 Then
imgUSA.Visible = True
Else
imgUSA.Visible = False
End If
End Sub
Private Sub cmdReturn_Click()
' Retour à la feuille de sélection.
frmFlagsCheck.Hide
frmSelect.Show
End Sub
Private Sub optEngland_Click()
' Bouton sélectionné = drapeau affiché.
If optSmall.Value = True Then
imgEngland.Height = 480
imgEngland.Width = 480
Else
' Grande taille.
imgEngland.Height = 2800
imgEngland.Width = 2800
End If
imgEngland.Visible = True
' Masquer les autres drapeaux.
imgItaly.Visible = False
imgSpain.Visible = False
imgMexico.Visible = False
imgFrance.Visible = False
imgUSA.Visible = False
End Sub
Private Sub optItaly_Click()
' Bouton sélectionné = drapeau affiché.
If optSmall.Value = True Then
imgItaly.Height = 480
imgItaly.Width = 480
Else ' Grande taille.
imgItaly.Height = 2800
imgItaly.Width = 2800
End If
imgItaly.Visible = True
' Masquer les autres drapeaux.
imgEngland.Visible = False
imgSpain.Visible = False
imgMexico.Visible = False
imgFrance.Visible = False
imgUSA.Visible = False
End Sub
Private Sub optSpain_Click()
' Bouton sélectionné = drapeau affiché.
If optSmall.Value = True Then
imgSpain.Height = 480
imgSpain.Width = 480
Else ' Grande taille
imgSpain.Height = 2800
imgSpain.Width = 2800
End If
imgSpain.Visible = True
' Masquer les autres drapeaux.
imgItaly.Visible = False
imgEngland.Visible = False
imgMexico.Visible = False
imgFrance.Visible = False
imgUSA.Visible = False
End Sub
Private Sub optMexico_Click()
' Bouton sélectionné = drapeau affiché.
If optSmall.Value = True Then
imgMexico.Height = 480
imgMexico.Width = 480
Else ' Grande taille
imgMexico.Height = 2800
imgMexico.Width = 2800
End If
imgMexico.Visible = True
' Masquer les autres drapeaux.
imgItaly.Visible = False
imgSpain.Visible = False
imgEngland.Visible = False
imgFrance.Visible = False
imgUSA.Visible = False
End Sub
Private Sub optFrance_Click()
' Bouton sélectionné = drapeau affiché.
If optSmall.Value = True Then
imgFrance.Height = 480
imgFrance.Width = 480
Else ' Grande taille
imgFrance.Height = 2800
imgFrance.Width = 2800
End If
imgFrance.Visible = True
' Masquer les autres drapeaux.
imgItaly.Visible = False
imgSpain.Visible = False
imgMexico.Visible = False
imgEngland.Visible = False
imgUSA.Visible = False
End Sub
Private Sub optUSA_Click()
' Bouton sélectionné = drapeau affiché.
If optSmall.Value = True Then
imgUSA.Height = 480
imgUSA.Width = 480
Else ' Grande taille
imgUSA.Height = 2800
imgUSA.Width = 2800
End If
imgUSA.Visible = True
' Masquer les autres drapeaux.
imgItaly.Visible = False
imgSpain.Visible = False
imgMexico.Visible = False
imgFrance.Visible = False
imgEngland.Visible = False
End Sub
Private Sub cmdReturn_Click()
' Retour à la feuille de sélection.
frmFlagsOpt.Hide
frmSelect.Show
End Sub
Private Sub optSmall_Click()
' Masquer tous les drapeaux affichés.
' Les drapeaux seront maintenant petits.
imgEngland.Visible = False
imgItaly.Visible = False
imgSpain.Visible = False
imgMexico.Visible = False
imgFrance.Visible = False
imgUSA.Visible = False
' Désélectionner tous les boutons d'option
optEngland.Value = False
optItaly.Value = False
optSpain.Value = False
optMexico.Value = False
optFrance.Value = False
optUSA.Value = False
End Sub
Private Sub optLarge_Click()
' Masquer tous les drapeaux affichés.
' Les drapeaux seront maintenant petits.
imgEngland.Visible = False
imgItaly.Visible = False
imgSpain.Visible = False
imgMexico.Visible = False
imgFrance.Visible = False
imgUSA.Visible = False
' Désélectionner tous les boutons d'option
optEngland.Value = False
optItaly.Value = False
optSpain.Value = False
optMexico.Value = False
optFrance.Value = False
optUSA.Value = False
End Sub
Private Sub GetTotal()
' Cette procédure additionne les valeurs d'un
' formulaire, puis envoie le total et le pourcentage
' d'abattement à la procédure qui calcule la taxe.
Dim curTotal As Currency
Dim sngDisc As Single ' Special tax discount
'
' Calculer le total d'après le formulaire.
curTotal = txtSale1.Text + txtSale2.Text + txtSale3.txt
'
' Envoyer le total à la procédure de taxation.
Call SalesTax(curTotal, sngDisc)
End Sub
Public Sub SalesTax(curTotal As Currency,
sngRateDisc As Single)
' Calculer la taxe et déduire l'abattement.
Dim curSalesTax As Currency
Dim intMsg As Integer ' For MsgBox()
'
' Calcul de la taxe de vente
' à 3,5 % du total.
curSalesTax = (curTotal * .035)
'
' Déduction du pourcentage d'abattement.
curSalesTax = curSalesTax - (sngRateDisc * curTotal)
'
' Afficher le montant total de la taxation.
intMsg = MsgBox("Taxation totale : " & curSalesTax)
'
' Après exécution, les procédures redonnent
' la main à la procédure appelante.
End Sub
Private Sub GetTotal()
' Cette procédure additionne les valeurs d'un
' formulaire, puis envoie le total et le pourcentage
' d'abattement à la procédure qui calcule la taxe.
Dim curTotal As Currency
Dim sngDisc As Single ' Special tax discount
'
' Calculer le total d'après le formulaire.
curTotal = txtSale1.Text + txtSale2.Text + txtSale3.txt
'
' Envoyer le total à la procédure de taxation.
intMsg = MsgBox("The sales tax is "
& SalesTax(curTotal, _sngDisc))
End Sub
Public Function SalesTax(curTotal As
Currency, sngRateDisc As _Single) As Currency
' Envoyer le total à la procédure de taxation.
Dim curSalesTax As Currency
'
' Dans le chapitre, ce code était une sous-routine.
' Calcul de la taxe de vente
' à 3,5 % du total.
curSalesTax = (curTotal * .03) + (curTotal * .005)
'
' Déduction du pourcentage d'abattement.
curSalesTax = curSalesTax - (sngRateDisc * curTotal)
'
' Définit la valeur renvoyée.
SalesTax = curSalesTax
'
' Une fois terminée, la procédure revient à
' la procédure appelante.
End Function
' La procédure appelante commence ici.
Private Sub CP()
Dim varR As Variant ' Variables locales à l'origine
Dim varV As Variant ' de la valeur renvoyée.
Dim intI As Integer ' Contiendra la valeur renvoyée.
varR = 32 ' Valeurs initiales.
varV = 64
intI = RF(varR, varV) ' Passe varR et varV.
' intI reçoit la valeur renvoyée.
MsgBox("Après renvoi, intI vaut " & intI)
MsgBox("Après renvoi, varR vaut " & varR)
MsgBox("Après renvoi, varV vaut " & varV)
End Sub
' La fonction appelée commence ici.
Public Function RF (varR As Variant, ByVal varV
As Variant) As Integer
' varR est reçu par référence et varV par valeur.
varR = 81 ' Modifie les deux arguments.
varV = varV + 10
' Définit la valeur de renvoi.
RF = varR + varV
End Function
' Interroge les fonctions Is().
Dim var1 As Variant, var2 As Variant,
Dim var3 As Variant, var4 As Variant
Dim intMsg As Integer ' valeur de renvoi de MsgBox
' Affectations de valeurs d'exemple.
var1 = 0 ' Valeur zéro.
var2 = Null ' Valeur Null.
var3 = "" ' Chaîne Null.
' Appelle chaque fonction Is().
If IsEmpty(var1) Then
intMsg = MsgBox("var1 est vide.", vbOKOnly)
End If
If IsEmpty(var2) Then
intMsg = MsgBox("var2 est vide.", vbOKOnly)
End If
If IsEmpty(var3) Then
intMsg = MsgBox("var3 est vide.", vbOKOnly)
End If
If IsEmpty(var4) Then
intMsg = MsgBox("var4 est vide.", vbOKOnly)
End If
Private Sub PrntType(varA) ' Variant par défaut.
Dim intMsg As Integer ' Valeur de renvoi de MsgBox().
Select Case VarType(varA) ' VarType() renvoie un entier.
Case 0
intMsg = MsgBox("L'argument est de type Empty.")
Case 1
intMsg = MsgBox("L'argument est de type Null.")
Case 2
intMsg = MsgBox("L'argument est de type Integer.")
Case 3
intMsg = MsgBox("L'argument est de type Long.")
Case 4
intMsg = MsgBox("L'argument est de type Single.")
Case 5
intMsg = MsgBox("L'argument est de type Double.")
Case 6
intMsg = MsgBox("L'argument est de type Currency.")
Case 7
intMsg = MsgBox("L'argument est de type Date.")
Case 8
intMsg = MsgBox("L'argument est de type String.")
Case 9
intMsg = MsgBox("L'argument est de type Object.")
Case 10
intMsg = MsgBox("L'argument est de type Error.")
Case 11
intMsg = MsgBox("L'argument est de type Boolean.")
Case 12
intMsg = MsgBox("L'argument est de type tableau de Variant.")
Case 13
intMsg = MsgBox("L'argument est de type objet d'accès aux données.")
Case 14
intMsg = MsgBox("L'argument est de type Decimal.")
Case 17
intMsg = MsgBox("L'argument est de type Byte.")
Case Else
intMsg = MsgBox("L'argument est de type Array (tableau).")
End Select
End Sub
Private Sub convStr ()
Dim str1 As String, s2 As String
Dim intMsg As Integer ' Clic sur le bouton.
str1 = CStr(12345)
str2 = Str(12345)
intMsg = MsgBox("***" & str1 & "***")
intMsg = MsgBox("***" & str2 & "***")
End Sub
Public Function ReverseIt (strS As String,
ByVal n As Integer) As String
' Attend une chaîne, ainsi qu'un entier indiquant
' le nombre de caractères à inverser.
' Inverse le nombre spécifié de
' caractères dans la chaîne spécifiée.
' Renvoie la chaîne inversée.
'
' Inverse les n premiers caractères de la chaîne.
Dim strTemp As String, intI As
Integer
If n > Len(strS) Then n = Len(strS)
For intI = n To 1 Step -1
strTemp = strTemp + Mid(strS, intI,
1)
Next intI
ReverseIt = strTemp + Right(strS,
Len(strS) - n)
End Function
Public Sub CompTime ()
' Cette procédure mesure le temps de réponse.
Dim intMsg As Integer ' Valeur de renvoi de MsgBox().
Dim varBefore, varAfter, varTimeDiff As Variant
Dim intMathAns As Integer
varBefore = Timer ' Valeur au moment de la question.
intMathAns = Inputbox("Combien font 150 + 235 ?")
varAfter = Timer ' Valeur au moment de la réponse.
' La différence entre les deux valeurs représente
' le temps de réponse de l'utilisateur.
varTimeDiff = varAfter - varBefore
intMsg = MsgBox("Vous avez mis "
+ Str(varTimeDiff) & " secondes !")
End Sub
Function DueDate (dteAnyDate) As Variant
' Attend une valeur date.
' Calcule le prochain jour ouvrable
' après la date spécifiée.
' Renvoie la date de ce jour-là.
Dim varResult As Variant
If Not IsNull(dteAnyDate) Then
varResult =
DateSerial(Year(dteAnyDate), Month(dteAnyDate) + 1, 1)
If Weekday(varResult) = 1 Then ' Dimanche : ajouter un jour.
DueDate = Result + 1
ElseIf Weekday(varResult) = 7
Then ' Samedi : ajouter deux jours.
DueDate = varResult + 2
Else
DueDate = varResult
End If
Else
varResult = Null
End If
End Function
strS = Format(9146, "|######|") ' |9146|
strS = Format(2652.2, "00000.00") ' 02652.20
strS = Format(2652.2, "#####.##") ' 2652.2
strS = Format(2652.216, "#####.##") ' 2652.22
strS = Format(45, "+###") ' +45
strS = Format(45, "-###") ' -45
strS = Format(45, "###-") ' 45-
strS = Format(2445, "####.##
FF") ' 2445. FF
strS = Format(2445, "####.00
FF") ' 2445.00 FF
strS = Format(2445, "00H00") ' 24H45
Dim varD As Variant
varD = Now ' Suppose comme date fictive
' le 21 mai 1999 à 12:30 précises.
strND = Format(varD, "c") ' 21/5/99 12:30:00
strND = Format(varD, "w") ' 6
strND = Format(varD, "ww")' 22
strND = Format(varD, "dddd") ' vendredi
strND = Format(varD, "q") ' 2
strND = Format(varD, "hh") ' 12
strND = Format(varD, "d mmmm h:nn:ss") ' "21 mai 12:30:00"
Private Sub mnuViewColor_Click()
cdbColor.CancelError = True ' Un clic sur Annuler
' équivaut à une erreur.
On Error Goto dbErrHandler ' Bascule vers l'étiquette en cas d'erreur.
' Définit la propriété Flags.
cdbColor.Flags = cdlCCFullOpen +
cdlCCHelpButton ' Affichage complet.
Color DB
' Affiche la boîte de dialogue Couleur.
cdbColor.ShowColor
' Définit la couleur d'arrière-plan de la
' feuille selon les choix de l'utilisateur.
frmTitle.ForeColor = cdbColor.Color
Exit Sub ' Fin de la procédure normale.
dbErrHandler:
' L'utilisateur ayant cliqué sur Annuler,
' la procédure doit être ignorée.
Exit Sub
End Sub
' Définir les valeurs de Flags.
CdbFont.Flags = cdlCFBoth Or cdlCFEffects
CdbFont.ShowFont ' Affiche la boîte de dialogue.
' Définit les propriétés du label qui
' reflétera les choix de l'utilisateur.
LblMessage.Font.Name = CdbFont.FontName
LblMessage.Font.Size = CdbFont.FontSize
LblMessage.Font.Bold = CdbFont.FontBold
LblMessage.Font.Italic = CdbFont.FontItalic
LblMessage.Font.Underline = CdbFont.FontUnderline
LblMessage.FontStrikethru =
CdbFont.FontStrikethru
LblMessage.ForeColor = CdbFont.Color
' Présuppose que CancelError vaut True.
On Error Goto dbErrHandler
' Définit les valeurs Flags.
CdbFont.Flags = cdlCFBoth Or
cdlCFEffects
CdbFont.ShowFont ' Affiche la boîte de dialogue Police.
' Définit les propriétés du label qui
' reflètera les choix de l'utilisateur.
LblMessage.Font.Name = CdbFont.FontName
LblMessage.Font.Size = CdbFont.FontSize
LblMessage.Font.Bold = CdbFont.FontBold
LblMessage.Font.Italic = CdbFont.FontItalic
LblMessage.Font.Underline =
CdbFont.FontUnderline
LblMessage.FontStrikethru = CdbFont.FontStrikethru
LblMessage.ForeColor = CdbFont.Color
Exit
Sub
dbErrHandler:
' L'utilisateur a cliqué sur Annuler.
Exit Sub ' Pas de modification.
La procédure :
Private Sub mnuFileOpen_Click ()
' Présuppose que CancelError vaut True.
On Error Goto dbErrHandler
' Determine les types de fichiers
' qui apparaîtront.
cdbFile.Filter = "Texte (*.txt) | *.txt"
' Spécifie le filtre par défaut.
cdbFile.FilterIndex = 1
cdbFile.DialogTitle = "Open"
' Affiche la boîte de dialogue Ouvrir.
cdbFile.ShowOpen
'**********************************
' Ici, placez ou appelez une *
' procédure qui ouvre le fichier *
' sélectionné par l'utilisateur. *
'**********************************
Exit Sub
dbErrHandler:
' L'utilisateur a cliqué sur Annuler.
Exit Sub ' Ne pas ouvrir de fichier.
End Sub
Private mnuFilePrint_Click()
Dim intBegin As Integer, intEnd As
Integer
Dim intNumCopies As Integer, intI As
Integer
' Suppose que Cancel est définie comme True.
On Error Goto dbErrHandler
' Affiche la boîte de dialogue Imprimer.
cbdPrint.ShowPrinter
' Reçoit les valeurs sélectionnées par l'utilisateur.
intBegin = cbdPrint.FromPage
intEnd = cbdPrint.ToPage
intNumCopies = cbdPrint.Copies
'
' Imprime le nombre de copies demandé.
For intI = 1 To intNumCopies
' Ici, code chargé de gérer la sortie imprimante.
Next intI
Exit Sub
dbErrHandler:
' L'utilisateur a appuyé sur Annuler.
Exit Sub
End Sub
Private Sub imgMouse_MouseDown(intButton As
Integer, intShift As Integer, sngX As Single, sngY As Single)
Dim intShiftState As Integer
intShiftState = intShift And 7 ' And binaire.
Select Case intShiftState
Case 1
' Combinaisons Maj.
Case 2
' Combinaisons Ctrl.
Case 3
' Combinaisons Alt.
Case 4
' Combinaisons Maj-Ctrl.
Case 5
' Combinaisons Maj-Alt.
Case 6
' Combinaisons Ctrl-Alt.
Case 7
' Combinaisons Maj-Ctrl-Alt.
End Select
End Sub
Private Sub Form_Load()
' Initialise les valeurs du contrôle.
lstColors.AddItem "Rouge"
lstColors.AddItem "Bleu"
lstColors.AddItem "Vert"
lstColors.AddItem "Jaune"
lstColors.AddItem "Orange"
lstColors.AddItem "Blanc"
End Sub
Private Sub association ()
' Reçoit puis affiche les noms et les sommes dues.
Dim strFamilyName(35) As String ' Réserve les éléments du tableau.
Dim curFamilyDues(35) As Currency
Dim intSub As Integer
Dim intMsg As Integer ' Valeur de renvoi de MsgBox().
' Collecte les données.
For intSub = 1 To 35
strFamilyName(intSub) = InputBox("Famille suivante ?")
curFamilyDues(intSub) = InputBox("Cotisations dues ?")
Next intSub
' Les données peuvent maintenant être affichées.
' (Cet exemple utilise à cette fin des boîtes
' de message pour simplifier les choses.)
intSub = 1 ' Initialise le premier indice.
Do
intMsg = MsgBox("Famille numéro " & intSub & " : "
& strFamilyName(intSub))
intMsg = MsgBox("Cotisations dues : " & curFamilyDues(intSub))
intSub = intSub + 1
Loop Until (intSub > 35)
End Sub
Private Sub varyNumb ()
' Reçoit puis affiche les noms et les sommes dues.
Dim strFamilyName(500) As String ' On vise large.
Dim curFamilyDues(500) As Currency
Dim intSub As Integer, intNumFam As Integer
Dim intMsg As Integer ' Valeur de renvoi de MsgBox().
intNumFam = 1
' La boucle demande les noms et les sommes dues
' jusqu'à ce que l'utilisateur appuie sur Entrée
' sans avoir saisi d'information. Dès qu'une chaîne
' nulle est entrée, la boucle Do-Loop s'arrête
' après avoir stocké la dernière entrée.
Do
strFamilyName(intNumFam) =
InputBox("Famille suivante ?")
If (strFamilyName(intNumFam) =
"") Then Exit Do '
Interruption.
curFamilyDues(intNumFam) = InputBox("Cotisations dues ?")
intNumFam = intNumFam + 1 ' Ajoute 1 Add à la variable indice.
Loop Until (intNumFam > 500)
' Lorsque la dernière boucle se termine, intNumFam contient
' 1 de plus que le nombre réel d'entrées.
' Affiche toutes les données.
For intSub = 1 To intNumFam - 1
intMsg = MsgBox("Famille numéro " & intSub & " : "
& strFamilyName(intSub))
intMsg = MsgBox("Cotisations dues :
" & curFamilyDues(intSub))
Next intSub
End Sub
Private Sub salary ()
' Stocke 12 mois de salaires, puis affiche les mois sélectionnés.
Dim curSal(1 To 12) As Currency ' Réserve des éléments pour 12 salaires.
Dim intSub As Integer ' Indice de boucle.
Dim intNum As Integer ' Mois sélectionné.
Dim intMsg As Integer ' Valeur de renvoi de MsgBox().
Dim strAns As String
For intSub = 1 To 12
curSal(intSub) = InputBox("Salaire pour le mois de " & Str(intSub) & " ?", 0.00)
Next intSub
' Demande le numero du mois.
Do
intNum = InputBox("Quel mois voulez-vous consulter ? (1-12) ")
intMsg = MsgBox("Salaires pour le mois de " & Str(intNum) & " : " & curSal(intNum))
strAns =
InputBox("Autre consultation ? (O/N)")
Loop While (strAns = "O" Or
strAns = "o")
End Sub
Private Sub tempAvg ()
' Demande une liste de températures puis calcule la moyenne.
Dim sngTemp(1 To 50) As Single ' Maximum = 50
Dim sngTotalTemp As Single ' Reçoit le total.
Dim sngAvgTemp As Single
Dim intSub As Integer ' Indice.
Dim intMsg As Integer ' Valeur de renvoi de MsgBox().
' Demande à l'utilisateur chaque température.
For intSub = 1 To 50 ' Maximum.
sngTemp(intSub) = InputBox("Température suivante ?(-99 pour terminer) ")
' Si l'utilisateur veut arrêter, décrémente de 1 et sort de la boucle.
If (sngTemp(intSub) = -99) Then
intSub = intSub - 1 ' Décrémente de 1.
Exit For
End If
sngTotalTemp = sngTotalTemp + sngTemp(intSub) ' Additionne le total.
Next intSub
' Calcule la moyenne.
sngAvgTemp = sngTotalTemp / intSub
intMsg = MsgBox("Température moyenne : " & sngAvgTemp)
End Sub
Private Sub Form_Load()
' S'exécute au chargement de la feuille.
lstFirstList.AddItem "Chicago"
lstFirstList.AddItem "Dallas"
lstFirstList.AddItem "Seattle"
lstFirstList.AddItem
"Washington"
lstFirstList.AddItem "Houston"
lstFirstList.AddItem "Dayton"
End Sub
Private Sub lstFirstList_Click()
' Met à jour les six zones de texte en fonction des .
' éléments sélectionnés dans la première zone de liste.
If lstFirstList.Selected(0) Then
txtChicago.Text = "Sélectionné"
Else
txtChicago.Text = "Non sélectionné"
End If
If lstFirstList.Selected(1) Then
txtDallas.Text = "Sélectionné"
Else
txtDallas.Text = "Non sélectionné"
End If
If lstFirstList.Selected(2) Then
txtSeattle.Text = "Sélectionné"
Else
txtSeattle.Text = "Non sélectionné"
End If
If lstFirstList.Selected(3) Then
txtWashington.Text = "Sélectionné"
Else
txtWashington.Text = "Non sélectionné"
End If
If lstFirstList.Selected(4) Then
txtHouston.Text = "Sélectionné"
Else
txtHouston.Text = "Non sélectionné"
End If
If lstFirstList.Selected(5) Then
txtDayton.Text = "Sélectionné"
Else
txtDayton.Text = "Non sélectionné"
End If
End Sub
Private Sub Form_Click()
txtMouse.Text = "Vous avez cliqué sur la feuille"
Beep ' Signale l'événement Click.
End Sub
Private Sub Form_DblClick()
txtMouse.Text = "Vous avez double-cliqué sur la feuille"
End Sub
Private Sub Form_MouseDown(intButton As
Integer, intShift As Integer, sngX As Single, sngY As Single)
' Clic sur la feuille.
txtMouse.Text = "Clic sur la feuille à la position " & sngX & "," & sngY
End Sub
' Arguments ignorés dans la procédure précédente.
Private Sub Form_MouseMove(intButton As
Integer, intShift As Integer, sngX As
Single, sngY As Single)
txtMouse.Text = "Déplacement de la souris..."
End Sub
' Arguments ignorés dans la procédure précédente.
Private Sub imgMouse_Click()
txtMouse.Text = "Vous avez cliqué sur l'image"
End Sub
Private Sub imgMouse_DblClick()
txtMouse.Text = "Vous avez double-cliqué sur l'image"
End Sub
Private Sub imgMouse_MouseDown(intButton As
Integer, intShift As Integer, sngX As Single, sngY As Single)
'
' Clic sur l'image.
txtMouse.Text = "Clic sur l'image à la position " & sngX & "," & sngY
End Sub
Private Sub imgMouse_MouseMove(intButton As
Integer, intShift As Integer, sngX As Single, sngY As Single)
txtMouse.Text = "Vous vous êtes déplacé sur l'image"
End Sub
Private Sub Form_Click()
' Exemple de méthode Print.
Dim strString As String
strString = "Visual Basic"
' Affiche trois fois la chaîne.
Form1.Print strString & " " &
strString & " " strString
End Sub
Private Sub Form_Click ()
Dim strString As String
strString = "Visual Basic"
Form1.Print "*"; Spc(5); strString; ' Remarquez le point-virgule.
Form1.Print Spc(2); strString
End Sub
Private Sub Form_Click()
Dim strString As String
strString = "Visual Basic"
Form1.Print "*"; Tab(5);
strString; Tab(20); strString
Form1.Print "*"; Spc(5);
strString; Spc(20); strString
End Sub
Private Sub Form_Click()
Dim strString As String
Dim CurLine As Integer
CurLine = 1
strString = "Visual Basic"
' Affiche la ligne.
Form1.Print strString & " est sur la ligne n°" & CurLine
For CurLine = 2 To 6
Form1.Print ' Insère des lignes vierges.
Next CurLine
' Affiche la ligne.
Form1.Print strString & " est sur la ligne n°" & CurLine
End Sub
Private Sub Form_Click()
' Définition de l'echelle
Form1.ScaleMode = VbCharacters
Form1.CurrentX = 20 ' Déplacement horizontal de 20 caractères.
Form1.CurrentY = 6 ' Déplacement vertical de 6 lignes.
Form1.Print "Vertical et horizontal "
Form1.CurrentX = 0 ' Retour vers la gauche.
Form1.CurrentY = 0 ' Retour vers le haut.
Form1.Print "Coin supérieur gauche"
End Sub
Public Property Get BottomTitle()
' Cette procédure renvoie la valeur
' de la propriété BottomTitle,
' valeur en fait contenue dans
' la variable publique strTitle.
BottomTitle = strTitle
End Property
Public Property Let
BottomTitle(strTitleEntered)
' Cette procédure affecte à la variable
' strTitle les valeurs que le programme
' est susceptible d'envoyer à BottomTitle.
'
' L'argument passé est la valeur que
' le programme stocke dans BottomTitle.
strTitle = strTitleEntered
'
' La sortie suivante s'affichera au bas de la feuille.
frmTitle.CurrentY = (frmTitle.Height - 600)
'
' Si la feuille est si petite que même une seule
' ligne ne rentre pas, ne rien faire.
If frmTitle.CurrentY < 600 Then
Exit Property
Else
' Affiche sur la feuille la valeur de propriété.
Print strTitle
End If
End Property
Private Sub LoadNewDoc()
Static lDocumentCount As Long
Dim frmD As frmDocument
lDocumentCount = lDocumentCount + 1
Set frmD = New frmDocument
frmD.Caption = "Document "
& lDocumentCount
frmD.Show
End Sub
Dim intReadFile As Integer, intWriteFile As
Integer
' Gère le fichier d'entrée.
intReadFile = FreeFile ' Obtient le numéro du premier fichier.
Open "AccPay.Dat" For Input As
intReadFile
' Gère le fichier de sortie.
intWriteFile = FreeFile ' Obtient le numéro du fichier suivant.
Open "AccPayOut.Dat" For Output As
intWriteFile
'
' Ici, le code chargé d'envoyer au fichier
' de sortie le contenu du fichier d'entrée
' (voir plus loin).
Close intReadFile
Close intWriteFile
Private Sub cmdFile_Click()
Dim intCtr As Integer ' Compteur de boucle.
Dim intFNum As Integer ' Numéro de fichier.
Dim intMsg As Integer ' Valeur de renvoi de MsgBox().
intFNum = FreeFile
' Vous pouvez changer le chemin.
Open "C:\Print.txt" For Output As
#intFNum
' Décrit la procédure.
intMsg = MsgBox("Fichier Print.txt ouvert !")
For intCtr = 1 To 5
Print # intFNum, intCtr ' Envoie le compteur de boucle.
intMsg = MsgBox("Ecriture du chiffre " & intCtr & " dans Print.txt")
Next intCtr
Close # intFNum
intMsg = MsgBox("Fichier Print.txt fermé !")
End Sub
Private Sub cmdFile_Click()
Dim intCtr As Integer ' Compteur de boucle.
Dim intFNum As Integer ' Numéro de fichier.
Dim intMsg As Integer ' Valeur de renvoi de MsgBox().
intFNum = FreeFile
' Vous pouvez changer le chemin.
Open "C:\Print.txt" For Output As
#intFNum
' Décrit la procédure.
intMsg = MsgBox("Fichier Print.txt ouvert")
For intCtr = 1 To 5
Print # intFNum, intCtr; ' Remarquez le point-virgule.
intMsg = MsgBox("Ecriture du chiffre " & intCtr & " dans Print.txt")
Next intCtr
Close # intFNum
intMsg = MsgBox("Fichier Print.txt fermé")
End Sub
Private Sub cmdFileOut_Click ()
' Crée le fichier séquentiel.
Dim intCtr As Integer ' Compteur de boucle.
Dim
intFNum As Integer ' Numéro de fichier.
intFNum = FreeFile
Open "Print.txt" For Output As #intFNum
For intCtr = 1 To 5
Print # intFNum, intCtr; ' Ecrit le compteur de boucle.
Next intCtr
Close # intFNum
End Sub
Private Sub cmdFileIn_Click ()
' Lit le fichier séquentiel.
Dim intCtr As Integer ' Compteur de boucle.
Dim intVal As Integer ' Valeur lue.
Dim intFNum As Integer ' Numéro de fichier.
Dim intMsg As Integer ' Valeur de renvoi de MsgBox().
intFNum = FreeFile
Open "Print.txt" For Input As #intFNum
For intCtr = 1 To 5
Input # intFNum, intVal
' Affiche les résultats dans la fenêtre Exécution.
intMsg = MsgBox("Lecture du chiffre " & intVal & " dans Print.txt")
Next intCtr
Close # intFNum
intMsg = MsgBox("Le fichier Print.txt file est maintenant fermé")
End Sub
Private cmdFile_Click ()
Dim intCtr As Integer ' Compteur de boucle.
Dim intFNum As Integer ' Numéro de fichier.
intFNum = FreeFile
Open "c:\Write.txt" For Output As #intFNum
For intCtr = 1 To 5
Write # intFNum, intCtr; ' Ecrit le compteur de boucle.
Next intCtr
Close # intFNum
End Sub
' Page module du projet.
Type UserType
strFName As String
strLName As String
End Type
Public Names As UserType
' Page module du projet.
Type UserType2
strFName As String * 8
strLName As String * 20
End Type
Public Names As UserType2
Private Sub cmdCreate_Click()
' Cette procédure crée le fichier.
Dim intFile As Integer ' Numéro de fichier disponible.
Dim intCtr As Integer ' Compteur de boucle.
intFile = FreeFile
Open "c:\Random.Txt" For Random
As #intFile Len = 5
' La boucle parcourt les numéros et écrit dans le fichier.
For intCtr = 1 To 5
Put # intFile, intCtr, intCtr ' Le numéro d'enregistrement correspond aux données.
Next intCtr
Close intFile
End Sub
Private Sub cmdChange_Click()
' Cette procédure modifie l'enregistrement n°3.
Dim intFile As Integer ' Numéro de fichier disponible.
intFile = FreeFile
Open "c:\Random.Txt" For Random
As #intFile Len = 5
' Ecrit un nouvel enregistrement n°3.
Put #intFile, 3, 9 ' Value = 9.
Close # intFile
End Sub
Private Sub cmdDisplay_Click()
' Cette procédure affiche le fichier
Dim intFile As Integer ' Numéro de fichier disponible.
Dim intVal As Integer ' Valeur lue.
Dim intCtr As Integer ' Compteur de boucle.
Dim intMsg As Integer ' Valeur de renvoi de MsgBox().
intFile = FreeFile
Open "c:\Random.Txt" For Random As
#intFile Len = 5
intMsg = MsgBox("Fichier Random.Txt ouvert...")
' La boucle parcourt les enregistrements et les affiche.
For intCtr = 1 To 5
Get # intFile, intCtr, intVal
intMsg = MsgBox("Lecture de " & intVal & " dans Random.Txt")
Next intCtr
Close # intFile
intMsg = MsgBox("Fichier Random.Txt fermé")
End Sub
' Dans la section de déclarations du module de code.
Type Address
strStreet As String
strCity As String
strZip As String
End Type
Type UserType3
strFName As String * 10
strLName As String * 25
typAddr As Address ' Autre type de données.
End Type
Public Names As UserType3 ' Déclare une variable d'application.
Names.strFName = "Serge"
Names.strLName = "Pichot"
Names.typAddr.strStreet =
"Clergeot"
Names.typAddr.strCity =
"Perrochonville"
Names.typAddr.strZip "99000"
' Traite les données.
lblFName.Caption = "Prénom : " & Names.strFName
lblLName.Caption = "Nom : " & Names.strLName
lblAddr.Caption = "rue : " & Names.strAddr.strStreet
lblCty.Caption = "Ville : " & Names.strAddr.strCity
lblZip.Caption = "Code postal : " & Names.strAddr.strZip
Private Sub cmdColor_Click()
' Pour changer le contrôle d'arrière-plan
' de la zone de liste, l'utilisateur
' se servira de la boîte de dialogue Couleur.
comFile.ShowColor
lstFile.BackColor = comFile.Color
End Sub
Private Sub Form_Resize()
Dim intMsg As Integer ' Valeur de renvoi de MsgBox().
' Si l'utilisateur redimensionne la feuille,
' ajuste la taille de la zone de liste.
'
' Cette procédure événementielle s'exécute
' au premier chargement de la feuille.
'
' S'assure que la feuille est assez grande
' pour afficher la zone de liste.
If (frmFile.Width < 400) Or
(frmFile.Height < 3500) Then
' Masque la zone de liste et
' avertit l'utilisateur.
lstFile.Visible = False
intMsg = MsgBox("La feuille est trop petite pour afficher le fichier", _ vbCritical)
Else
' Active l'affichage de la zone de liste,
' au cas où.
lstFile.Visible = True
' Ajuste la taille de la zone de liste.
' Ajuste la position du bouton de commande.
lstFile.Width = frmFile.Width - 1440
lstFile.Height = frmFile.Height -
2500
cmdColor.Left = (frmFile.Width / 2) -
500
End If
End Sub
Private Sub mnuFileExit_Click()
' Option de fermeture du programme.
End
End Sub
Private Sub mnuFileOpen_Click()
Dim strFileLine As String
' Gère le bouton Annuler.
On Error GoTo comErrorHandler
'
' Affiche la boîte de dialogue Ouvrir.
comFile.ShowOpen
' Continue si l'utilisateur clique sur OK,
' passe au gestionnaire d'erreurs s'il clique sur Annuler.
'
' Ouvre le fichier sélectionné par l'utilisateur.
Open comFile.FileName For Input As #1
' Vide la zone de liste pour faire de la place.
lstFile.Clear
'
' Lit une ligne complète du fichier.
Line Input #1, strFileLine
lstFile.AddItem strFileLine
'
' Poursuit la lecture et remplit la zone de liste
' jusqu'à ce que la fin du fichier soit atteinte.
Do Until (EOF(1))
Line Input #1, strFileLine
lstFile.AddItem strFileLine
Loop
' Ferme le fichier.
Close
comErrorHandler:
' Ne fait rien si l'utilisateur clique sur Annuler.
End Sub
Dim prnPrntr As Printer
For Each prnPrntr In Printers ' Boucle dans la collection.
frmMyForm.Print prnPrntr.DeviceName
Next
Dim prnPrntr As Printer
For Each prnPrntr In Printers
If prnPrntr.ColorMode = vbPRCMColor Then
' Définit l'imprimante couleur comme imprimante par défaut.
Set Printer = prnPrntr
Exit For ' Ne cherche pas plus loin.
End If
Next ' Continue la boucle si nécessaire.
Public Function IsColor() As Boolean
Dim blnIsColor As Boolean
Dim prnPrntr As Printer
'
' Présuppose qu'aucune imprimante couleur n'a été encore trouvée.
blnIsColor = False
'
' Parcourt les imprimantes.
For Each prnPrntr In Printers
If prnPrntr.ColorMode = vbPRCMColor Then
' Définit l'imprimante couleur comme imprimante par défaut.
Set Printer = prnPrntr
blnIsColor = True
Exit For ' Laisse tomber.
End If
Next ' Parcourt les imprimantes si nécessaire.
'
' blnIsColor reste False si aucune imprimante couleur
' n'est trouvée, et devient True dans le cas contraire.
' Définit en conséquence la valeur renvoyée par la fonction.
IsColor = blnIsColor
End Function
Sub PrintAnywhere (Src As Object, Dest As
Object)
Dest.PaintPicture Src.Picture, Dest.Width
/ 2, Dest.Height / 2
If TypeOf Dest Is Printer Then
Printer.EndDoc
End If
End Sub
Private Sub cmdPrint_Click()
' Envoie une sortie vers la feuille
' à l'aide de la méthode Print.
Dim intCtr As Integer
Dim intCurX As Integer
Dim intCurY As Integer
'
' Définit les attributs de police.
frmPrint.FontItalic = True
frmPrint.FontBold = True
frmPrint.FontSize = 36
'
' Spécifie des mesures en twips.
frmPrint.ScaleMode = vbTwips
'
' Enregistre les positions X et Y (en twips)
' à chaque itération de la boucle.
For intCtr = 1 To 10
intCurX = frmPrint.CurrentX
intCurY = frmPrint.CurrentY
' Texte noir et blanc en alternance.
If (intCtr Mod 2) = 1 Then ' Compteur de boucle.
frmPrint.ForeColor = vbWhite
Else
frmPrint.ForeColor = vbBlack
End If
' Affiche le texte.
frmPrint.Print "Visual
Basic"
'
' Change les positions X et Y.
frmPrint.CurrentX = intCurX + 350
frmPrint.CurrentY = intCurY + 300
Next intCtr
End Sub
Private Sub cmdExit_Click()
End
End Sub
Dim blnAutoRedraw As Boolean ' Contiendra la valeur de AutoRedraw.
'
frmBlank.Print "Répartition du matériel"
frmBlank.Print ' Blank line
frmBlank.Print "Zone"; Tab(20); "Machines"
frmBlank.Print "--------"; Tab(20); "--------"
frmBlank.Print "Nord"; Tab(20); "Fraises"
frmBlank.Print "Sud"; Tab(20); "Presses"
frmBlank.Print "Est"; Tab(20); "Broyeurs"
frmBlank.Print "Ouest"; Tab(20); "Giboliniseurs"
'
' Enregistre la valeur de AutoRedraw.
'
blnAutoRedraw = frmBlank.AutoRedraw
'
' Imprime la feuille.
'
frmBlank.AutoRedraw = True
frmBlank.PrintForm
'
' Restaure AutoRedraw.
'
frmBlank.AutoRedraw = blnAutoRedraw
Private Sub cmdPrintForm_Click ()
Dim intBtnClicked As Integer
On Error Goto ErrHandler ' Définit le gestionnaire d'erreur.
frmAccPayable.PrintForm ' Imprime la feuille.
Exit Sub
ErrHandler:
intBtnClicked = MsgBox("L'imprimante a un problème", vbExclamation, "Erreur d'impression")
End Sub
Public Function PrReady() As Boolean
' Laisse à l'utilisateur le temps de se préparer.
Dim intIsReady As Integer
'
' L'utilisateur répond à la boîte de message
' pour indiquer qu'il est prêt.
intIsReady = MsgBox("Veuillez préparer l'imprimante", vbOKCancel, "Impression")
'
If (intIsReady = vbCancel) Then
PrReady = False
Else
PrReady = True
End If
End Function
Private Sub cmdPrint_Click()
' Imprime seulement si l'utilisateur
' indique qu'il est prêt.
If PrReady() Then
' Appelle ReportPrint
End If
End Sub
Private Sub Form_Load()
' Initialise la liste déroulante Forme.
lstShape.AddItem "0 - Rectangle"
lstShape.AddItem "1 - Square"
lstShape.AddItem "2 - Oval"
lstShape.AddItem "3 - Circle"
lstShape.AddItem "4 - Rounded
Rectangle"
lstShape.AddItem "5 - Rounded
Square"
' Initialise la liste déroulante Motif.
lstPattern.AddItem "0 - Solid"
lstPattern.AddItem "1 -
Transparent"
lstPattern.AddItem "2 - Horizontal
Line"
lstPattern.AddItem "3 - Vertical
Line"
lstPattern.AddItem "4 - Upward
Diagonal"
lstPattern.AddItem "5 - Downward
Diagonal"
lstPattern.AddItem "6 - Cross"
lstPattern.AddItem "7 - Diagonal
Cross"
' Définit la première valeur de chaque liste comme valeur par défaut.
lstShape.ListIndex = 0
lstPattern.ListIndex = 0
End Sub
Private Sub lstPattern_Click()
' Change le motif en fonction de la sélection.
shpSample.FillStyle = lstPattern.ListIndex
End Sub
Private Sub lstShape_Click()
' Change la forme en fonction de la sélection.
shpSample.Shape = lstShape.ListIndex
End Sub
Private Sub mnuFileExit_Click()
End
End Sub
Private Sub cmdBoxes_Click()
Dim intStartX As Integer
Dim intStartY As Integer
Dim intLastX As Integer
Dim intLastY As Integer
Dim intCtr As Integer
intStartX = 0
intStartY = 0
intLastX = 1000
intLastY = 800
For intCtr = 1 To 20
frmBoxes.Line (intStartX,
intStartY)-(intLastX, intLastY), , B
' prépare la position des prochains cadres.
intStartX = intStartX + 400
intStartY = intStartY + 400
intLastX = intLastX + 400
intLastY = intLastY + 400
Next intCtr
End Sub
Private Sub Form_Load()
' Ouvre le CD.
mmcCD.Command = "Open"
End Sub
Private Sub Form_Unload(Cancel As Integer)
' Réinitialise le contrôle multimédia.
mmcCD.Command = "Close"
End Sub
Private Sub mmcCD_StatusUpdate()
' Met à jour le label de pistes.
lblTrackNum.Caption = mmcCD.Track
End Sub
Private Sub mciWAV_StatusUpdate()
' Affiche l'état.
If mmcWAV.Mode = mciModeNotOpen Then
lblStatusValue(0).Caption = "Non prêt"
ElseIf mmcWAV.Mode = mciModeStop Then
lblStatusValue(0).Caption = "Arrêt"
ElseIf mmcWAV.Mode = mciModePlay Then
lblStatusValue(0).Caption = "Lecture"
ElseIf mmcWAV.Mode = mciModeRecord Then
lblStatusValue(0).Caption =
"Enregistrement"
ElseIf mmcWAV.Mode = mciModePause Then
lblStatusValue(0).Caption =
"Pause"
ElseIf mmcWAV.Mode = mciModeReady Then
lblStatusValue(0).Caption = "Prêt"
End If
' Affiche le nom du fichier lu.
lblStatusValue(1).Caption = mmcWAV.FileName
End Sub
Private Sub Form_Load()
' Ouvre le lecteur vidéo.
mmcVideo.Command = "Open"
' Connecte le lecteur vidéo au contrôle PictureBox.
mmcVideo.hWndDisplay = picVideo.hWnd
End Sub
Private Sub hscScroll_Change()
' Change la largeur et la position horizontale de l'image.
picScroll.Width = hscScroll.Value
picScroll.Left = (frmScroll.Width / 2) -
(picScroll.Width / 2) - 300
End Sub
Private Sub vscScroll_Change()
' Change la hauteur et la position verticale de l'image.
picScroll.Height = vscScroll.Value
picScroll.Top = (frmScroll.Height / 2) -
(picScroll.Height / 2) -300
End Sub
Private Sub vscScroll_Scroll()
' Répond au curseur de défilement.
Call vscScroll_Change
End Sub
Private Sub hscScroll_Scroll()
' Répond au curseur de défilement.
Call hscScroll_Change
End Sub
Option Explicit
Public LoginSucceeded As Boolean
Private Sub cmdCancel_Click()
' Affecte la valeur False à la variable globale
' pour indiquer l'échec de la connexion.
LoginSucceeded = False
Me.Hide
End Sub
Private Sub cmdOK_Click()
' Vérifie si le mot de passe est correct.
If txtPassword =
"password" Then
' Placer le code ici pour signaler
' à la procédure appelante la réussite de la fonction.
' Définir une variable globale est plus facile.
LoginSucceeded = True
Me.Hide
Else
MsgBox "Mot de passe non valide, réessayez !", , "Connexion"
txtPassword.SetFocus
SendKeys "{Home}+{End}"
End If
End Sub
Dim intFileNum as Integer
' Obtenir le premier numéro de fichier disponible
intFileNum = FreeFile
' Ouvrir le fichier de sortie
Open "TEST.OLE" For Binary As
#intFileNum
' Enregistrer le fichier
oleObj1.SaveToFile intFileNum
' Fermer le fichier
Close
Dim intFileNum as Integer
' Obtenir le premier numéro de fichier disponible
intFileNum = FreeFile
' Ouvrir le fichier de sortie
Open "TEST.OLE" For Binary As
#intFileNum
' Lire le fichier dans l'objet
oleObj1.ReadFromFile intFileNum
' Fermer le fichier
Close
Dim Cities As New Collection
Dim intCtr As Integer
' Ajoute les éléments
Cities.Add "Tulsa"
Cities.Add "Miami"
Cities.Add "New York"
Cities.Add "Seattle"
' Montre qu'il y a quatre villes
frmMyForm.Print "Il y a "; Cities.Count; " villes :"
' Imprime chaque nom de ville
For intCtr = 1 To Cities.Count
frmMyForm.Print " "; Cities(intCtr)
Next
Private Sub cmdSendToExcel_Click()
Dim obExcelApp As Object ' Objet Appplication
Dim obWorkSheet As Object ' Objet Feuille de calcul
Dim blnRunning As Boolean ' Si Excel était en exécution
' Déroutement des erreurs
On Error Resume Next
'
' Référencer l'application Excel
Set obExcelApp = GetObject(,
"Excel.Application")
If Err.Number <> 0 Then
Set obExcelApp = CreateObject("Excel.Application")
blnRunning = False ' Excel n'était pas en exécution
Else
blnRunning = True
End If
' Ajouter un nouveau classeur
obExcelApp.Workbooks.Add
' Référencer la feuille de calcul active
Set obWorkSheet = obExcelApp.ActiveSheet
' Entrer des valeurs dans les cellules de la feuille active
obWorkSheet.Cells(1, 1).Value =
"Ventes"
obWorkSheet.Cells(1, 2).Value =
"Mois"
obWorkSheet.Cells(2, 1).Value = 21913.44
obWorkSheet.Cells(2, 2).Value =
"avril"
' Sélectionner la deuxième ligne pour formater
obWorkSheet.Rows("2:2").Select
obExcelApp.Selection.NumberFormat =
"$##,###.##"
' Enregistrer le classeur (changez ce nom s'il existe déjà)
obExcelApp.Save ("c:\VBCreated.XLS")
' Ne pas quitter si Excel était déjà lancé !
obExcelApp.ActiveWorkBook.Close False
If Not (blnRunning) Then ' S'il n'était pas lancé...
obExcelApp.Quit ' alors quitter Excel
End If
End Sub
'Valeurs de propriétés par défaut:
Const m_def_AutoTSize = 1
Const m_def_ULText = 0
'Variables de propriétés:
Dim m_AutoTSize As Variant
Dim m_ULText As Variant
Public Enum AutoTSizeEnum
NA = 1
Small = 2
Medium = 3
Large = 4
End Enum
Public Enum ULTextEnum
AsIs = 0
Uppercase = 1
Lowercase = 2
End Enum
Private Sub UserControl_Resize()
' Définit la hauteur et l'échelle à celle du contrôle sous-jacent
' Etend le contrôle aux bonnes largeur et hauteur
If UserControl.Height <> txtParent.Height
Then
txtParent.Height = UserControl.Height
End If
txtParent.Move 0, 0,
UserControl.ScaleWidth
End Sub
Public Property Get AutoTSize() As
AutoTSizeEnum
AutoTSize = m_AutoTSize
End Property
Public Property Get ULText() As ULTextEnum
ULText = m_ULText
End Property
Public Property Let AutoTSize(ByVal
New_AutoTSize As AutoTSizeEnum)
m_AutoTSize = New_AutoTSize
' Tester l'état de la propriété et en modifier la taille
' en fonction de sa valeur
'
Select Case New_AutoTSize
Case 1: ' Pas de modification nécessaire
Case 2: Font.Size = 72 * 0.25 *
(Height / 1440)
Case 3: Font.Size = 72 * 0.5 *
(Height / 1440)
Case 4: Font.Size = 72 * 0.75 *
(Height / 1440)
End Select
PropertyChanged "AutoTSize"
End Property
Public Property Let ULText(ByVal New_ULText
As ULTextEnum)
m_ULText = New_ULText
' Tester l'état du contrôle
' et modifier en fonction la zone de texte
' (ignorer ULText à 0 qui signifie tel quel)
If New_ULText = 1 Then
Text = UCase(txtParent.Text)
ElseIf New_ULText = 2 Then
Text = LCase(txtParent.Text)
End If
PropertyChanged "ULText"
End Property
Private Sub cmdSmall_Click()
' Test de la conversion Small
MyFirstCtl.AutoTSize = Small
End Sub
Private Sub cmdMedium_Click()
' Test de la conversion Medium
MyFirstCtl.AutoTSize = Medium
End Sub
Private Sub cmdLarge_Click()
' Test de la conversion Large
MyFirstCtl.AutoTSize = Large
End Sub
Private Sub cmdUpper_Click()
' Test de la conversion en majuscules
MyFirstCtl.ULText = Uppercase
End Sub
Private Sub cmdLower_Click()
' Test de la conversion en minuscules
MyFirstCtl.ULText = Lowercase
End Sub
Private Sub cmdAni_Click()
' Utilise le bouton pour commander l'animation
If cmdAni.Caption = "&Animer"
Then
cmdAni.Caption = "&Stop"
tmrAni.Enabled = True
Else
cmdAni.Caption = "&Animer"
tmrAni.Enabled = False
End If
End Sub
Private Sub mnuHelpAbout_Click()
mmcEnv.Command = "Open"
mmcEnv.Command = "Play"
frmAbout.Show
End Sub
Private Sub tmrAni_Timer()
' Determine le bon emplacement
' d'image à afficher
'
' La variable suivante part de zéro
' et conserve sa valeur à chaque exécution
' de la procédure.
Static intCounter As Integer
Select Case intCounter
Case 0:
picAni1.Picture = picAni2(1).Picture
picAni2(2).Visible = True
picAni2(2).Left = 3840
picAni2(2).Top = 1220
intCounter = 1
Case 1:
picAni1.Picture = picAni2(1).Picture
picAni2(2).Visible = True
picAni2(2).Left = 4040
picAni2(2).Top = 1120
intCounter = 2
Case 2:
picAni1.Picture = picAni2(1).Picture
picAni2(2).Visible = True
picAni2(2).Left = 4240
picAni2(2).Top = 1220
intCounter = 3
Case 3:
picAni1.Picture = picAni2(0).Picture
picAni2(2).Left = 4440
picAni2(2).Top = 1320
intCounter = 4
Case 4:
' Arrêter l'animation
picAni1.Visible = True
intCounter = 0
picAni2(2).Visible = False
End Select
End Sub
Private Sub cmdSave_Click()
' Assigne toutes les TextBox aux champs.
' N'assigne que les données non nulles
' (les lignes longues sont découpées)
adoBooks.Recordset!Title = _
IIf(txtTitle = "",
"N/A", txtTitle)
adoBooks.Recordset![Year Published] = _
IIf(txtPub = "",
"N/A", txtPub)
adoBooks.Recordset!ISBN = _
IIf(txtISBN = "",
"N/A", txtISBN)
adoBooks.Recordset!PubID = _
IIf(txtPubID = "",
"N/A", txtPubID)
adoBooks.Recordset!Subject = _
IIf(txtSubject = "",
"N/A", txtSubject)
' Effectue la mise à jour réelle du recordset
adoBooks.Recordset.Update
End Sub
<HTML>
<HEAD>
<TITLE>MSN.COM</TITLE>
<meta
http-equiv="Content-Type" content="text/html;
charset=iso-8859-1">
<META
http-equiv="PICS-Label" content=
'(PICS-1.0
"http://www.rsac.org/ratingsv01.html"
l comment "RSACi North America
Server" by
"Microsoft Network"'>
</HEAD>
<FRAMESET
rows="20,*" frameborder="0"
framespacing="0"
border="0">
<FRAME
src="/pilot.htm" name="pilot"
NORESIZE scrolling="no"
marginwidth="0"
marginheight="0"
frameborder="0" framespacing="0">
</FRAMESET>
</html>
<SCRIPT
Language="VBScript">
Call PrintWelcome
Call ModMessage
Sub
PrintWelcome
If Date() = "2/2/98"
Then
document.write ". . . .Anniversaire de Cathy !"
End If
If Date() = "2/5/98"
Then
document.write ". . . .Anniversaire d'Eric !"
End If
If Date() = "5/17/98" Then
document.write ". . . .Anniversaire de Michael !"
End If
If Date() = "7/25/98"
Then
document.write ". . . .Mon Anniversaire !"
End If
End Sub
Sub ModMessage
Document.Write "<BR>Dernière modification de cette page : "+Document.lastModified +"</FONT><BR>"
End Sub
</SCRIPT>
cdbHelp.HelpFile = "MDINote.hlp" ' Pointe sur le fichier d'aide
'
' Vous pouvez proposer une aide spécifique sur un sujet
' particulier en pointant sur le numéro de la section
' [MAP] du fichier .HPJ (vos ID de contexte textuelles)
cdbHelp.HelpContext = 3 ' Pointe sur la section
cdbHelp.HelpCommand = cdlHelpContext ' Demande contextuelle
cdbHelp.ShowHelp ' Affiche l'aide contextuelle
Private Sub ChangeSignal()
' Check to see what color the light is,
and then change
' it to the next color. The order is
green, yellow,
' and then red.
If imgGreen.Visible = True Then
imgGreen.Visible = False
imgYellow.Visible = True
ElseIf imgYellow.Visible = True Then
imgYellow.Visible = False
imgRed.Visible = True
Else
imgRed.Visible = False
imgGreen.Visible = True
End If
End Sub
For intRow = 1 To 2
For intCol = 1 To 3
MsgBox("Ligne : " & intRow & ", Colonne : " & intCol)
Next intCol
Next intRow
For intRow = 1 To 2
For intCol = 1 To 3
Form1.Print "Row: " &
intRow & ", Col: " & intCol
Next intCol
Form1.Print
Next intRow
Private Sub disks ()
' Assigne et imprime les prix des disquettes
Dim curDisks(1 To 2, 1 To 4) As Currency
Dim intRow As Integer, intCol As Integer
' Assigne le prix de chaque élément
curDisks(1, 1) = 2.30 ' Ligne 1, colonne 1
curDisks(1, 2) = 2.75 ' Ligne 1, colonne 2
curDisks(1, 3) = 3.20 ' Ligne 1, colonne 3
curDisks(1, 4) = 3.50 ' Ligne 1, colonne 4
curDisks(2, 1) = 1.75 ' Ligne 2, colonne 1
curDisks(2, 2) = 2.10 ' Ligne 2, colonne 2
curDisks(2, 3) = 2.60 ' Ligne 2, colonne 3
curDisks(2, 4) = 2.95 ' Ligne 2, colonne 4
' Imprime les prix sous forme de table
Form1.Print
Form1.Print Tab(12); "Simple face, Double face, ";
Form1.Print "Simple face, Double face"
Form1.Print Tab(12); "faible densité faible densité ";
Form1.Print "haute densité haute densité"
For intRow = 1 To 2
If (intRow = 1) Then
Form1.Print "3 pouces 1/2 ";
Tab(15);
Else
Form1.Print "5 pouces 1/4";
Tab(15);
End If
For intCol = 1 To 4
Form1.Print curDisks(intRow, intCol);
Spc(8);
Next intCol
Form1.Print ' Déplace le curseur à la ligne suivante
Next intRow
End Sub
Private Sub Form_Load()
' Définit la justification des cellules de la grille
' et assigne les titres des cellules à la ligne fixe et
' les en-têtes de colonnes. Initialise en outre la table
' des valeurs et l'envoie au contrôle grille.
'
Call InitScrolls ' Initialise les barres de défilement
Call CenterCells ' Centre les cellules
Call SizeCells ' Spécifie la largeur des cellules
Call Titles ' Place les titres de colonne et de ligne
Call FillCells ' Remplit les cellules
End Sub
Private Sub InitScrolls()
' Configure les deux barres de défilement
' à leur valeur maximale. Même si ces valeurs sont
' configurées dans la fenêtre Propriétés, cette procé-
' dure permet de modifier plus facilement les valeurs
' maximales des barres de défilement s'il en est besoin.
'
hscIncrease.Value = 15
hscDecrease.Value = 15
End Sub
Private Sub CenterCells()
' Configure la justification des cellules
' en alignement centré. Assurez-vous de centrer
' les en-têtes de ligne et de colonne.
'
Dim Column As Integer
'
' Commence par centrer les cellules d'en-têtes
For Column = 0 To 7
grdSales.Col = Column ' configure la colonne courante
' Centre les cellules fixes de cette colonne
grdSales.ColAlignment(Column) =
flexAlignCenterCenter
Next Column
End Sub
Private Sub SizeCells()
' Specifie la largeur de chaque cellule
Dim Column As Integer
For Column = 0 To 7
grdSales.ColWidth(Column) = 1100 ' En twips
Next Column
End Sub
Private Sub Titles()
' Remplissage des titres de colonnes
' Habituellement, ces données proviennent d'une table de base de données
grdSales.Row = 0 ' Tous les noms des vendeurs sont à la ligne 0
grdSales.Col = 1
grdSales.Text = "Smith"
grdSales.Col = 2
grdSales.Text = "Johnson"
grdSales.Col = 3
grdSales.Text = "Lake"
grdSales.Col = 4
grdSales.Text = "West"
grdSales.Col = 5
grdSales.Text = "Gates"
grdSales.Col = 6
grdSales.Text = "Kirk"
grdSales.Col = 7
grdSales.Text = "Taylor"
' Maintenant, remplir les produits
grdSales.Col = 0 ' Tous les noms de produits sont à la colonne 0
grdSales.Row = 1
grdSales.Text = "Gadget #1"
grdSales.Row = 2
grdSales.Text = "Gadget #2"
grdSales.Row = 3
grdSales.Text = "Tube long"
grdSales.Row = 4
grdSales.Text = "Tube court"
grdSales.Row = 5
grdSales.Text = "Règle métallique"
grdSales.Row = 5
grdSales.Text = "Règle en bois"
grdSales.Row = 6
grdSales.Text = "Règle en plastique"
grdSales.Row = 7
grdSales.Text = "Règle en caoutchouc"
grdSales.Row = 8
grdSales.Text = "Panier"
grdSales.Row = 9
grdSales.Text = "Boulon 3C"
grdSales.Row = 10
grdSales.Text = "Boulon 5A"
grdSales.Row = 11
grdSales.Text = "Ecrou 3C"
grdSales.Row = 12
grdSales.Text = "Ecrou 5A"
grdSales.Row = 13
grdSales.Text = "Clou #12"
grdSales.Row = 14
grdSales.Text = "Clou #15"
grdSales.Row = 15
grdSales.Text = "Clou #16"
grdSales.Row = 16
grdSales.Text = "Œillet #4"
grdSales.Row = 17
grdSales.Text = "Œillet #6"
grdSales.Row = 18
grdSales.Text = "Œillet #8"
grdSales.Row = 19
grdSales.Text = "Joint"
End Sub
Private Sub FillCells()
' Remplit les 160 cellules avec des valeurs
' calculées à partir des valeurs de ligne et de colonne
' Même si ces données n'ont aucun sens, elles permettent
' d'insérer rapidement des données dans le tableau et la grille.
'
' Ces données proviennent normalement d'une base de données.
'
' Déclarer un tableau de 20 lignes et 7 colonnes qui
' correspond à la grille sur la feuille. Les indices
' sont en base zéro, car la grille les utilise aussi.
Dim curData(19, 7) As Currency
Dim Row As Integer
Dim Column As Integer
'
' Remplir la table de données
For Row = 1 To 19
For Column = 1 To 7
curData(Row, Column) = ((Row + Column)
/ Row)
Next Column
Next Row
' Copier le contenu de la table dans la grille
For Row = 1 To 19
For Column = 1 To 7
grdSales.Row = Row
grdSales.Col = Column
grdSales.Text = Format(curData(Row,
Column), "###.00")
Next Column
Next Row
End Sub
Private Sub hscDecrease_Change()
' Modifie le titre du bouton de commande
cmdDecrease.Caption = "&Diminuer de
" & Str(hscDecrease.Value) & " %"
End Sub
Private Sub hscIncrease_Change()
' Modifie le titre du bouton de commande
cmdIncrease.Caption = "&Augmenter de
" & Str(hscIncrease.Value) & " %"
End Sub
Private Sub cmdIncrease_Click()
' Augmente les valeurs des cellules sélectionnées
' en augmentant le pourcentage de la barre de défilement
Dim SelRows As Integer
Dim SelCols As Integer
Dim SelStartRow As Integer
Dim SelStartCol As Integer
Dim RowBeg As Integer
Dim ColBeg As Integer
If (grdSales.HighLight) Then ' Si sélectionné...
' Enregistrer les valeurs de cellules sélectionnées
SelStartRow = grdSales.RowSel
SelStartCol = grdSales.ColSel
RowBeg = grdSales.Row
ColBeg = grdSales.Col
' Parcourir toutes les cellules sélectionnées
For SelRows = RowBeg To SelStartRow
For SelCols = ColBeg To SelStartCol
grdSales.Row = SelRows
grdSales.Col = SelCols
' Augmenter la cellule du montant de la barre de défilement
grdSales.Text = grdSales.Text +
(hscIncrease.Value / 100 * grdSales.Text)
grdSales.Text = Format(grdSales.Text,
"####.00")
Next SelCols
Next SelRows
' Restaurer la sélection en surbrillance
grdSales.Row = RowBeg
grdSales.Col = ColBeg
grdSales.RowSel = SelStartRow
grdSales.ColSel = SelStartCol
End If
End Sub
Private Sub cmdDecrease_Click()
' Diminue les valeurs des cellules sélectionnées
' en diminuant le pourcentage de la barre de défilement
Dim SelRows As Integer
Dim SelCols As Integer
Dim SelStartRow As Integer
Dim SelStartCol As Integer
Dim RowBeg As Integer
Dim ColBeg As Integer
If (grdSales.HighLight) Then ' Si sélectionné...
' Enregistrer les valeurs de cellules sélectionnées
SelStartRow = grdSales.RowSel
SelStartCol = grdSales.ColSel
RowBeg = grdSales.Row
ColBeg = grdSales.Col
' Parcourir toutes les cellules sélectionnées
For SelRows = RowBeg To SelStartRow
For SelCols = ColBeg To SelStartCol
grdSales.Row = SelRows
grdSales.Col = SelCols
' Diminuer la cellule du montant de la barre de défilement
grdSales.Text = grdSales.Text - (hscDecrease.Value / 100 * grdSales.Text)
grdSales.Text =
Format(grdSales.Text, "####.00")
Next SelCols
Next SelRows
' Restaurer la sélection en surbrillance
grdSales.Row = RowBeg
grdSales.Col = ColBeg
grdSales.RowSel = SelStartRow
grdSales.ColSel = SelStartCol
End If
End Sub
Private Sub cmdExit_Click()
' Terminer l'application
End
End Sub
Private Declare Function MessageBeep Lib
"user32" (ByVal wType As Long) As Long
Private Sub cmdBeep_Click()
Dim Beeper As Variant
Beeper = MessageBeep(1)
End Sub
Private Declare Function GetDriveType Lib
"kernel32.dll" Alias "GetDriveTypeA" (ByVal nDrive As
String) As Long
Private Sub cmdDrive_Click()
Dim lngDriveType As Long
' Transmettre le nom du disque qui vous intéresse
' à la fonction GetDriveType()
lngType = GetDriveType("c:\")
'
' Utiliser la valeur renvoyée pour déterminer
' le type de disque testé
Select Case lngType
Case 2
txtDrive.Text = "Disque
amovible"
Case 3
txtDrive.Text = "Disque dur fixe"
Case 4
txtDrive.Text = "Disque distant (réseau)"
Case Else
txtDrive.Text = "Inconnu"
End Select
End Sub
Private Declare Function GetWindowsDirectory
Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer
As String, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectory
Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer
As String, ByVal nSize As Long) As Long
Private Declare Function GetTempPath Lib
"kernel32" Alias "GetTempPathA" (ByVal nBufferLength As
Long, ByVal lpBuffer As String) As Long
Private Sub Form_Load()
' Initialise les labels des dossiers système au chargement
' Déclare une chaîne fixe assez longue pour contenir les informations
Dim strFolder As String * 255
Dim intLength As Integer
'
' Obtient les informations sur le répertoire Windows
intLength = GetWindowsDirectory(strFolder, 255)
lblWinD.Caption = Left(strFolder,
intLength)
'
' Obtient les informations sur le répertoire System
intLength = GetSystemDirectory(strFolder, 255)
lblWinS.Caption = Left(strFolder,
intLength)
'
' Obtient les informations sur le répertoire Temp
intLength = GetTempPath(255, strFolder)
lblWinT.Caption = Left(strFolder,
intLength)
End Sub
Private Sub cmdExit_Click()
End
End Sub
Annexe A
Public Property Let EmpCode(ByVal intletEmpCode
As Integer)
intEmpCode = intletECode
End Property
Public Property Get EmpCode() As Integer
EmpCode = intEmpCode
End Property
Public Property Let EmpName(ByVal
strletEmpName As String)
strEmpName = strletEName
End Property
Public Property Get EmpName() As Integer
EmpName = strEmpName
End Property
Sub OpenDoc()
Dim mydoc As Word.Document
Set mydoc =
GetObject("C:\test.doc", "Word.Document")
mydoc.Application.Visible = True
With mydoc
.Paragraphs(1).Range.InsertBefore "Ceci est un exemple de la méthode GetObject."
End With
Set mydoc = Nothing
End Sub
'Code de la feuille utilisateur frmOutlookAdresses
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub cmdInsertAll_Click()
Call AddtoDoc(True)
End Sub
Private Sub cmdInsertSelected_Click()
Call AddtoDoc(False)
End Sub
Private Sub cmdModify_Click()
Unload Me
frmModifContacts.Show
End Sub
'Cette procédure sert à initialiser l'application Outlook
Private Sub UserForm_Initialize()
Dim oApp As Outlook.Application
Dim oNspc As NameSpace
Dim oItm As ContactItem
Dim x As Integer
If Not DisplayStatusBar Then
DisplayStatusBar = True
End If
StatusBar = "Attendez s'il vous plaît..."
x = 0
'Créer une instance d'Outlook
'Référencer son interface MAPI
'Référencer le dossier Contact MAPI
Set oApp =
CreateObject("Outlook.Application")
Set oNspc =
oApp.GetNamespace("MAPI")
'Pour chaque élément du dossier Contacts,
'afficher ses informations spécifiques.
'Vous pouvez spécifier d'afficher un ou plusieurs champs d'information.
For Each oItm In
oNspc.GetDefaultFolder(olFolderContacts).Items
With Me.cboContactList
.AddItem (oItm.FullName)
.Column(1, x) = oItm.JobTitle
.Column(2, x) = oItm.CompanyName
.Column(3, x) = oItm.BusinessAddress
.Column(4, x) =
oItm.BusinessTelephoneNumber
.Column(5, x) = oItm.Email1address
End With
x = x + 1
Next oItm
StatusBar = "Ajouter des détails concernant un contact..."
Set oItm = Nothing
Set oNspc = Nothing
Set oApp = Nothing
End Sub
'Cette procédure sert à afficher les informations spécifiques
'de l'élément contact sélectionné dans la zone de liste modifiable.
Private Sub cboContactList_Change()
Dim x As Integer
With lstFieldList
If .ListCount > 0 Then
For x = 0 To .ListCount - 1
.RemoveItem (0)
Next x
End If
For x = 0 To cboContactList.ColumnCount
- 1
.AddItem (Me.cboContactList.Column(x))
Next x
End With
End Sub
'Cette procédure sert à insérer les champs sélectionnés
'dans un document Word à l'emplacement actuel du curseur.
Public Sub AddtoDoc(All As Boolean)
Dim itm As Variant
With lstFieldList
For x = 0 To .ListCount - 1
If All Then .Selected(x) = All
If .Selected(x) = True Then
With Selection
.InsertAfter (lstFieldList.List(x))
.Collapse (wdCollapseEnd)
.Paragraphs.Add
End With
End If
Next x
End With
End Sub
Private Sub cmdPrintLabels_Click()
Dim Msg, Style, Title, Help, Ctxt, Response,
MyString
Msg = "Les étiquettes vont être imprimées dans un nouveau document Word. Voulez-vous imprimer des étiquettes d'expédition pour les contacts ?" ' Message affiché dans la boîte de message
Style = vbYesNo + vbDefaultButton1 + vbQuestion ' Boutons affichés dans la boîte de message
Title = "impression des étiquettes" ' Titre de la boîte de message.
' Afficher le message.
Response = MsgBox(Msg, Style, Title, Help,
Ctxt)
If Response = vbYes Then ' Si l'utilisateur sélectionne Oui, imprimer les étiquettes.
Call PrintLabels
End If
End Sub
'Cette procédure sert à imprimer les informations concernant
' le contact dans un nouveau document Word.
Sub PrintLabels()
On Error GoTo ErrorHandler
Dim oApp As New Outlook.Application
Dim oNspc As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itms As Outlook.Items
Dim oItm As Outlook.ContactItem
Set oNspc =
oApp.GetNamespace("MAPI")
SelectContactFolder:
Set fld = oNspc.PickFolder
Debug.Print "Type d'élément par
défaut : " & fld.DefaultItemType
If fld.DefaultItemType <>
olContactItem Then
MsgBox "Sélectionnez un dossier Contacts.", vbExclamation, "Sélection de Contacts"
GoTo SelectContactFolder
End If
Dim appWord As New Word.Application
Dim docWord As New Word.Document
docWord.Activate
Set itms = fld.Items
For Each oItm In itms
With Selection
' Les étiquettes sont affichées en bleu et en gras
Selection.Font.Color = wdColorBlue
Selection.Font.Bold = True
.TypeParagraph
.TypeText
Text:="------------------------------------"
.TypeParagraph
.TypeText Text:=oItm.FullName
.TypeParagraph
.TypeText Text:=oItm.JobTitle
.TypeParagraph
.TypeText Text:=oItm.CompanyName
.TypeParagraph
.TypeText
Text:=oItm.BusinessAddress
.TypeParagraph
.TypeText Text:=oItm.BusinessTelephoneNumber
.TypeParagraph
.TypeText
Text:="------------------------------------"
End With
Next
ErrorHandlerExit:
Exit Sub
ErrorHandler:
MsgBox "Erreur numéro : " & Err.Number & "; Description : " & Err.Description, vbExclamation, "Imprimer les étiquettes"
Resume ErrorHandlerExit
frmOutlookAdresses.Show
End Sub
' Code de la feuille utilisateur frmModifContacts.
Private Sub cmdClose_Click()
Unload Me
frmOutlookAdresses.Show
End Sub
Private Sub UserForm_Initialize()
Dim oApp As Outlook.Application
Dim oNspc As NameSpace
Dim oItm As ContactItem
Dim x As Integer
If Not DisplayStatusBar Then
DisplayStatusBar = True
End If
StatusBar = "Attendez s'il vous plaît..."
x = 0
'Créer une instance d'Outlook
'Référencer son interface MAPI
'Référencer le dossier Contact MAPI
Set oApp =
CreateObject("Outlook.Application")
Set oNspc =
oApp.GetNamespace("MAPI")
'Pour chaque élément du dossier Contacts
'afficher ses informations spécifiques
For Each oItm In
oNspc.GetDefaultFolder(olFolderContacts).Items
With Me.cboContactList
.AddItem (oItm.FullName)
.Column(1, x) = oItm.JobTitle
.Column(2, x) = oItm.CompanyName
.Column(3, x) = oItm.BusinessAddress
.Column(4, x) =
oItm.BusinessTelephoneNumber
.Column(5, x) = oItm.Email1address
End With
x = x + 1
Next oItm
StatusBar = "Ajouter des détails concernant un contact..."
Set oItm = Nothing
Set oNspc = Nothing
Set oApp = Nothing
End Sub
Private Sub cmdModify_Click()
Call ModifyContact
Call Refresh
End Sub
'Cette procédure sert à ouvrir la feuille Contact Outlook
'd'un contact existant afin de pouvoir le mettre à jour.
Sub ModifyContact()
strFullName = cboContactList.Text
Dim oApp As Outlook.Application
Dim oNspc As NameSpace
Dim itms As Items
Dim oItm As ContactItem
'Créer une instance d'Outlook
'Référencer son interface MAPI
'Référencer le dossier Contact MAPI
Set oApp =
CreateObject("Outlook.Application")
Set oNspc =
oApp.GetNamespace("MAPI")
Set itms = _
oNspc.GetDefaultFolder(olFolderContacts).Items
'Rechercher les éléments à modifier.
For Each oItm In itms
If oItm.FullName = strFullName Then
oItm.Display
MsgBox "L'élément contact a été modifié.", vbInformation, "Modification des contacts"
Exit Sub
End If
Next
'Si aucune entrée n'est identifiée pour le contact spécifié
MsgBox "Sélectionnez un contact.", vbExclamation, "Modification des contacts"
End Sub
Private Sub cmdDelete_Click()
Call DeleteContact
Call Refresh
End Sub
'Cette procédure sert à rafraîchir la zone de liste modifiable du contenu
'après modification/suppression/ajout d'un contact.
Sub Refresh()
cboContactList.Clear
x = 0
Set oApp =
CreateObject("Outlook.Application")
Set oNspc =
oApp.GetNamespace("MAPI")
For Each oItm In
oNspc.GetDefaultFolder(olFolderContacts).Items
With Me.cboContactList
.AddItem (oItm.FullName)
End With
x = x + 1
Next oItm
Set oItm = Nothing
Set oNspc = Nothing
Set oApp = Nothing
End Sub
'Cette procédure sert à supprimer un élément contact Outlook spécifique.
Sub DeleteContact()
strFullName = cboContactList.Text
Dim oApp As Outlook.Application
Dim oNspc As NameSpace
Dim itms As Items
Dim oItm As ContactItem
'Créer une instance de Outlook
'Référencer son interface MAPI
'Référencer le dossier Contact MAPI
Set oApp =
CreateObject("Outlook.Application")
Set oNspc =
oApp.GetNamespace("MAPI")
Set itms = _
oNspc.GetDefaultFolder(olFolderContacts).Items
'Rechercher les éléments à supprimer.
For Each oItm In itms
If oItm.FullName = strFullName Then
oItm.Delete
MsgBox "L'élément contact a été supprimé !", vbInformation, "Modification des contacts"
Exit Sub
End If
Next
'Si aucune entrée n'est identifiée pour le contact spécifié
MsgBox "Sélectionnez un contact.", vbExclamation, "Modification des contacts"
End Sub
Private Sub cmdAdd_Click()
Call AddContact
Call Refresh
End Sub
'Cette procédure sert à ouvrir une nouvelle feuille d'élément contact Outlook
'lorsque l'utilisateur clique sur le bouton Ajouter un nouveau contact.
Public Sub AddContact()
On Error GoTo AddContact_Error
Dim spObj As Object, oItm As Object
' Créer une instance d'objet OutLook
Set spObj =
CreateObject("Outlook.Application")
' Créer et afficher une nouvelle feuille de contact
Set oItm =
spObj.CreateItem(olContactItem)
oItm.Display
' Quitter Outlook.
Set spObj = Nothing
MsgBox "L'élément contact a été ajouté.", vbInformation, "Modification des contacts"
Exit Sub
AddContact_Error:
MsgBox "Erreur : " & Err & " " & Error, vbExclamation, "Ajout d'un contact"
Exit Sub
End Sub
'Code de Module1
Sub ShowContacts()
frmOutlookAdresses.Show
End Sub
'Cette procédure sert à initialiser l'application Outlook
Private Sub UserForm_Initialize()
Dim oApp As Outlook.Application
Dim oNspc As NameSpace
Dim oItm As ContactItem
Dim x As Integer
If Not DisplayStatusBar Then
DisplayStatusBar = True
End If
StatusBar = "Attendez s'il vous plaît..."
x = 0
'Créer une instance d'Outlook
'Référencer son interface MAPI
'Référencer le dossier Contact MAPI
Set oApp =
CreateObject("Outlook.Application")
Set oNspc =
oApp.GetNamespace("MAPI")
'Pour chaque élément du dossier Contacts
'afficher ses informations spécifiques
'Vous pouvez spécifier d'afficher un ou plusieurs champs d'information.
For Each oItm In
oNspc.GetDefaultFolder(olFolderContacts).Items
With Me.cboContactList
.AddItem (oItm.FullName)
.Column(1, x) = oItm.JobTitle
.Column(2, x) = oItm.CompanyName
.Column(3, x) = oItm.BusinessAddress
.Column(4, x) =
oItm.BusinessTelephoneNumber
.Column(5, x) = oItm.Email1address
End With
x = x + 1
Next oItm
StatusBar = "Ajouter des détails concernant un contact..."
Set oItm = Nothing
Set oNspc = Nothing
Set oApp = Nothing
End Sub
'Cette procédure sert à afficher les informations spécifiques
'de l'élément contact sélectionné dans la zone de liste modifiable.
Private Sub cboContactList_Change()
Dim x As Integer
With lstFieldList
If .ListCount > 0 Then
For x = 0 To .ListCount - 1
.RemoveItem (0)
Next x
End If
For x = 0 To cboContactList.ColumnCount - 1
.AddItem (Me.cboContactList.Column(x))
Next x
End With
End Sub
'Cette procédure sert à insérer les champs sélectionnés
'dans un document Word à l'emplacement actuel du curseur.
Public Sub AddtoDoc(All As Boolean)
Dim itm As Variant
With lstFieldList
For x = 0 To .ListCount - 1
If All Then .Selected(x) = All
If .Selected(x) = True Then
With Selection
.InsertAfter (lstFieldList.List(x))
.Collapse (wdCollapseEnd)
.Paragraphs.Add
End With
End If
Next x
End With
End Sub
'Cette procédure sert à imprimer les informations concernant
' le contact dans un nouveau document Word.
Sub PrintLabels()
On Error GoTo ErrorHandler
Dim oApp As New Outlook.Application
Dim oNspc As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itms As Outlook.Items
Dim oItm As Outlook.ContactItem
Set oNspc =
oApp.GetNamespace("MAPI")
SelectContactFolder:
Set fld = oNspc.PickFolder
Debug.Print "Type d'élément par
défaut : " & fld.DefaultItemType
If fld.DefaultItemType <>
olContactItem Then
MsgBox "Sélectionnez un dossier Contacts.", vbExclamation, "Sélection de Contacts"
GoTo SelectContactFolder
End If
Dim appWord As New Word.Application
Dim docWord As New Word.Document
docWord.Activate
Set itms = fld.Items
For Each oItm In itms
With Selection
' Les étiquettes sont affichées en bleu et en gras
Selection.Font.Color = wdColorBlue
Selection.Font.Bold = True
.TypeParagraph
.TypeText
Text:="------------------------------------"
.TypeParagraph
.TypeText Text:=oItm.FullName
.TypeParagraph
.TypeText Text:=oItm.JobTitle
.TypeParagraph
.TypeText Text:=oItm.CompanyName
.TypeParagraph
.TypeText
Text:=oItm.BusinessAddress
.TypeParagraph
.TypeText
Text:=oItm.BusinessTelephoneNumber
.TypeParagraph
.TypeText
Text:="------------------------------------"
End With
Next
ErrorHandlerExit:
Exit Sub
ErrorHandler:
MsgBox "Erreur numéro : " & Err.Number & "; Description : " & Err.Description, vbExclamation, "Imprimer les étiquettes"
Resume ErrorHandlerExit
frmOutlookAdresses.Show
End Sub
'Cette procédure sert à ouvrir une nouvelle feuille d'élément contact Outlook
'lorsque l'utilisateur clique sur le bouton Ajouter un nouveau contact.
Public Sub AddContact()
On Error GoTo AddContact_Error
Dim spObj As Object, oItm As Object
' Créer une instance d'objet OutLook
Set spObj =
CreateObject("Outlook.Application")
' Créer et afficher une nouvelle feuille de contact
Set oItm =
spObj.CreateItem(olContactItem)
oItm.Display
' Quitter Outlook.
Set spObj = Nothing
MsgBox "L'élément contact a été ajouté.", vbInformation, "Modification des contacts"
Exit Sub
AddContact_Error:
MsgBox "Erreur : " & Err & " " & Error, vbExclamation, "Ajout d'un contact"
Exit Sub
End Sub
'Cette procédure sert à ouvrir la feuille contact Outlook
'd'un contact existant afin de pouvoir le mettre à jour.
Sub ModifyContact()
strFullName = cboContactList.Text
Dim oApp As Outlook.Application
Dim oNspc As NameSpace
Dim itms As Items
Dim oItm As ContactItem
'Créer une instance de Outlook
'Référencer son interface MAPI
'Référencer le dossier Contact MAPI
Set oApp =
CreateObject("Outlook.Application")
Set oNspc =
oApp.GetNamespace("MAPI")
Set itms = _
oNspc.GetDefaultFolder(olFolderContacts).Items
'Rechercher les éléments à modifier.
For Each oItm In itms
If oItm.FullName = strFullName Then
oItm.Display
MsgBox "L'élément contact a été modifié.", vbInformation, "Modification des contacts"
Exit Sub
End If
Next
'Si aucune entrée n'est identifiée pour le contact spécifié
MsgBox "Sélectionnez un contact.", vbExclamation, "Modification des contacts"
End Sub
'Cette procédure sert à supprimer un élément contact Outlook spécifique.
Sub DeleteContact()
strFullName = cboContactList.Text
Dim oApp As Outlook.Application
Dim oNspc As NameSpace
Dim itms As Items
Dim oItm As ContactItem
'Créer une instance d'Outlook
'Référencer son interface MAPI
'Référencer le dossier Contact MAPI
Set oApp =
CreateObject("Outlook.Application")
Set oNspc =
oApp.GetNamespace("MAPI")
Set itms = _
oNspc.GetDefaultFolder(olFolderContacts).Items
'Rechercher les éléments à supprimer.
For Each oItm In itms
If oItm.FullName = strFullName Then
oItm.Delete
MsgBox "L'élément contact a été supprimé !", vbInformation, "Modification des contacts"
Exit Sub
End If
Next
'Si aucune entrée n'est identifiée pour le contact spécifié
MsgBox "Sélectionnez un contact.", vbExclamation, "Modification des contacts"
End Sub
'Cette procédure sert à rafraîchir la zone de liste modifiable du contenu
'après modification/suppression/ajout d'un contact.
Sub Refresh()
cboContactList.Clear
x = 0
Set oApp =
CreateObject("Outlook.Application")
Set oNspc =
oApp.GetNamespace("MAPI")
For Each oItm In
oNspc.GetDefaultFolder(olFolderContacts).Items
With Me.cboContactList
.AddItem (oItm.FullName)
End With
x = x + 1
Next oItm
Set oItm = Nothing
Set oNspc = Nothing
Set oApp = Nothing
End Sub
Dim FirstEntry As Boolean
Private Sub frmSplash_Click(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles
MyBase.Click
Call DoTask()
End Sub
Private Sub frmSplash_DoubleClick(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles
MyBase.DoubleClick
Call DoTask()
End Sub
Private Sub frmSplash_KeyPress(ByVal
eventSender As System.Object, ByVal eventArgs As
System.Windows.Forms.KeyPressEventArgs) Handles MyBase.KeyPress
Dim KeyAscii As Short =
Asc(eventArgs.KeyChar)
Call DoTask()
If KeyAscii = 0 Then
eventArgs.Handled = True
End If
End Sub
Private Sub imgLogo_Click(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs)
Call DoTask()
End Sub
Private Sub imgLogo_DoubleClick(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs)
Call DoTask()
End Sub
Private Sub lblCompanyProduct_Click(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs)
Call DoTask()
End Sub
Private Sub
lblCompanyProduct_DoubleClick(ByVal eventSender As System.Object, ByVal
eventArgs As System.EventArgs)
Call DoTask()
End Sub
Private Sub lblProductName_Click(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs)
Call DoTask()
End Sub
Private Sub
lblProductName_DoubleClick(ByVal eventSender As System.Object, ByVal eventArgs
As System.EventArgs)
Call DoTask()
End Sub
Private Sub lblWarning_Click(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs)
Call DoTask()
End Sub
Private Sub lblWarning_DoubleClick(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs)
Call DoTask()
End Sub
Private Sub Timer1_Tick(ByVal eventSender
As System.Object, ByVal eventArgs As System.EventArgs) Handles Timer1.Tick
Call DoTask()
End Sub
Private Sub DoTask()
If (FirstEntry = False) Then
Me.Hide()
Dim FirstScreen As New frmMain()
FirstScreen.Show()
FirstScreen.Visible = True
FirstEntry = True
End If
End Sub
End Class
Private Sub cmdSubject_Click(ByVal
sender As System.Object, ByVal e As System.EventArgs) Handles cmdSubject.Click
' Cette fonction est invoquée suite à un clic sur le bouton 'Subject'
Dim ValidateMDBExistence As String
If Len(Trim(Application.StartupPath))
> 3 Then
ValidateMDBExistence =
Dir(Application.StartupPath & "\" & "Skills.mdb")
Else
ValidateMDBExistence =
Dir(Application.StartupPath & "Skills.mdb")
End If
If UCase(ValidateMDBExistence)
<> UCase("Skills.mdb") Then
MsgBox("Impossible de trouver la base de données 'Skills.mdb' dans le dossier bin de l'application. Vérifiez s'il vous plaît.", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
Exit Sub
End If
Call InitiateConnection()
Me.Hide()
Dim SubjSearchForm As New
frmSubjectSearch()
' Créer une instance du formulaire 'frmSubjectSearch'
SubjSearchForm.Show()
End Sub
Private Sub cmdSMEName_Click(ByVal sender
As System.Object, ByVal e As System.EventArgs) Handles cmdSMEName.Click
' Cette fonction est invoquée suite à un clic sur le bouton 'SME Name'
Dim ValidateMDBExistence As String
If Len(Trim(Application.StartupPath))
> 3 Then
ValidateMDBExistence =
Dir(Application.StartupPath & "\" & "Skills.mdb")
Else
ValidateMDBExistence =
Dir(Application.StartupPath & "Skills.mdb")
End If
If UCase(ValidateMDBExistence)
<> UCase("Skills.mdb") Then
MsgBox("Impossible de trouver la base de données 'Skills.mdb' dans le dossier bin de l'application. Vérifiez s'il vous plaît.", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
Exit Sub
End If
Call InitiateConnection()
Me.Hide()
Dim NameSearchForm As New
frmNameSearch()
' Créer une instance du formulaire 'frmNameSearch'
NameSearchForm.Show()
End Sub
Private Sub cmdExit_Click(ByVal sender As
System.Object, ByVal e As System.EventArgs) Handles cmdExit.Click
' Cette fonction est invoquée suite à un clic sur le bouton 'Quitter'
If Len(LTrim(RTrim(StoreVal)))
<> 0 Then
MastDBConn_Obj.Close()
' Fermer la connexion à la base de données
End If
End
End Sub
Function InitiateConnection()
If Len(LTrim(RTrim(StoreVal))) = 0
Then
' Ouvrir la connexion à la base de données suite à Form Load en fournissant les paramètres de la chaîne de connexion
If
Len(Trim(Application.StartupPath)) > 3 Then
MastDBConn_Obj.Open(("Provider=Microsoft.Jet.OLEDB.4.0;" &
"Data Source=" & Application.StartupPath &
"\Skills.mdb"))
StoreVal =
"ConnectionOpened"
Else
MastDBConn_Obj.Open(("Provider=Microsoft.Jet.OLEDB.4.0;" &
"Data Source=" & Application.StartupPath &
"Skills.mdb"))
StoreVal =
"ConnectionOpened"
End If
End If
End Function
End Class
Dim ResumeArray(500, 3) As String
Private Sub cmdBack_Click(ByVal sender As
System.Object, ByVal e As System.EventArgs) Handles cmdBack.Click
Me.Hide()
Dim MainForm As New frmMain()
' Créer une instance du formulaire 'frmMain'
MainForm.Show()
End Sub
Private Sub cmdSearch_Click(ByVal sender
As System.Object, ByVal e As System.EventArgs) Handles cmdSearch.Click
On Error GoTo ErrHandler
Dim checkreturnvalue As Boolean
If (lstSkills.SelectedIndex() = -1)
And Len(Trim(txtSkillName.Text)) = 0 And Len(Trim(txtYears.Text)) = 0 Then
'Vérifier si les champs 'Compétence' et 'Expérience' ont bien été renseignés par l'utilisateur
Call
StepsToPerform("FALSE")
'Cette fonction est appelée avec comme paramètre 'FALSE' si les entrées sont vierges
MsgBox("Les champs des zones de listes 'Compétence :', 'Expérience (en mois) :' et 'Choix du domaine' ne peuvent être vierges", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
txtSkillName.Focus()
txtSkillName.SelectionStart = 0
txtSkillName.SelectionLength = Len(Trim(txtSkillName.Text))
End If
If Len(Trim(txtSkillName.Text))
<> 0 Or (lstSkills.SelectedIndex() <> -1) Then
If Len(Trim(txtYears.Text))
<> 0 Then
If
Len(Trim(txtSkillName.Text)) <> 0 Then
checkreturnvalue = ValidateSkill()
' Cette fonction valide le champ 'Compétence'
If (checkreturnvalue = False) Then
GoTo MoveOut
End If
End If
checkreturnvalue =
ValidateYrsofExp()
' Cette fonction valide le champ 'Expérience'
If (checkreturnvalue = False) Then
GoTo MoveOut
End If
If
Len(Trim(txtSkillName.Text)) <> 0 Then
QueryPattern =
"BOTHFROMTEXT"
Call
ProcessonBasisOfQuery(QueryPattern)
' Cette fonction est appelée avec comme paramètre "BOTHFROMTEXT" s'il existe des entrées valides à la fois pour les champs 'Compétence' et 'Expérience'
GoTo MoveOut
End If
If (lstSkills.SelectedIndex()
<> -1) Then
QueryPattern =
"BOTHFROMLIST"
Call
ProcessonBasisOfQuery(QueryPattern)
' Cette fonction est appelée avec comme paramètre "BOTHFROMLIST" s'il existe des entrées valides pour les champs 'Compétence' & 'Expérience'
GoTo MoveOut
End If
End If
End If
If Len(Trim(txtYears.Text)) = 0 Then
If Len(Trim(txtSkillName.Text))
<> 0 Then
checkreturnvalue = ValidateSkill()
' Cette fonction valide le champ 'Compétence'
If (checkreturnvalue = False) Then
GoTo MoveOut
Else
QueryPattern =
"SUBJECT_TEXT"
Call
ProcessonBasisOfQuery(QueryPattern)
' Cette fonction est appelée avec comme paramètre 'SUBJECT_TEXT' si une entrée valide n'existe que pour la zone de texte 'Compétence'
GoTo MoveOut
End If
End If
If (lstSkills.SelectedIndex()
<> -1) Then
QueryPattern =
"SUBJECT_LIST"
Call
ProcessonBasisOfQuery(QueryPattern)
' Cette fonction est appelée avec comme paramètre "SUBJECT_LIST" si une entrée valide n'existe que pour la zone de liste 'Choix du domaine'
GoTo MoveOut
End If
End If
If Len(Trim(txtSkillName.Text)) = 0
And (lstSkills.SelectedIndex() = -1) Then
If Len(Trim(txtYears.Text))
<> 0 Then
checkreturnvalue = ValidateYrsofExp()
' Cette fonction valide le champ 'Expérience'
If (checkreturnvalue = False) Then
GoTo MoveOut
End If
QueryPattern =
"YEARS"
Call
ProcessonBasisOfQuery(QueryPattern)
' Cette fonction est appelée avec comme paramètre "YEARS" si une entrée valide a été entrée uniquement pour le champ 'Expérience'.
End If
End If
Exit Sub
ErrHandler:
MsgBox("L'erreur suivante (" & CStr(Err.Number) & ") s'est produite :" & Chr(13) & Err.Description, MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
MoveOut:
End Sub
Function ValidateSkill() As Boolean
' Cette fonction valide le champ 'Compétence'
Dim testSubjectContents As String
testSubjectContents =
Trim(txtSkillName.Text)
If (Len(Trim(testSubjectContents)) =
0) Then
' Validation d'une entrée vierge
Call
StepsToPerform("FALSE")
MsgBox("Entrée vierge trouvée dans le champ 'Compétence :' !", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
txtSkillName.Focus()
txtSkillName.SelectionStart = 0
txtSkillName.SelectionLength =
Len(Trim(txtSkillName.Text))
ValidateSkill = False
Exit Function
End If
ValidateSkill = True
End Function
Function ValidateYrsofExp() As Boolean
' Fonction de validation du champ 'Expérience'
Dim testYrsofExpContents As String
testYrsofExpContents =
Trim(txtYears.Text)
If (Len(Trim(testYrsofExpContents)) =
0) Then
' Validation d'une entrée vierge
Call
StepsToPerform("FALSE")
MsgBox("Entrée vierge trouvée dans le champ 'Expérience (en mois) :' !", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
txtYears.Focus()
txtYears.SelectionStart = 0
txtYears.SelectionLength =
Len(Trim(txtYears.Text))
ValidateYrsofExp = False
Exit Function
End If
If (IsNumeric(testYrsofExpContents) =
False) Then
' Validation d'une entrée non numérique
Call
StepsToPerform("FALSE")
MsgBox("Entrée non numérique trouvée dans le champ 'Expérience (en mois):' field !", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
txtYears.Focus()
txtYears.SelectionStart = 0
txtYears.SelectionLength =
Len(Trim(txtYears.Text))
ValidateYrsofExp = False
Exit Function
End If
ValidateYrsofExp = True
End Function
Function ProcessonBasisOfQuery(ByVal
Pattern As String)
' Cette fonction génère la requête SQL selon la sélection faite par l'utilisateur.
On Error GoTo ErrHandler
Dim temprecset As New
ADODB.Recordset()
Dim jctr As Short
Dim ictr As Short
For ictr = 0 To 499
For jctr = 0 To 3
ResumeArray(ictr, jctr) =
""
Next jctr
Next ictr
temprecset.CursorType =
ADODB.CursorTypeEnum.adOpenKeyset
temprecset.LockType =
ADODB.LockTypeEnum.adLockOptimistic
temprecset.let_ActiveConnection(MastDBConn_Obj)
If Pattern = "BOTHFROMTEXT"
Then
' Si les champs 'Compétence' & 'Expérience' sont tous deux renseignés par l'utilisateur
temprecset.Open("Select
File_Name, Total_Exp, Skill1_Exp from Skill_Info where Skill1_Name like
'%" & Trim(txtSkillName.Text) & "%'")
ElseIf Pattern =
"BOTHFROMLIST" Then
' Si les champs des zones de listes 'Compétence' et 'Expérience' sont renseignés par l'utilisateur
temprecset.Open("Select
File_Name, Total_Exp, Skill1_Exp from Skill_Info where Skill1_Name like
'%" & lstSkills.Items.Item(lstSkills.SelectedIndex()) &
"%'")
ElseIf Pattern =
"SUBJECT_TEXT" Then
' Si seule la zone de texte 'Compétence' est renseignée par l'utilisateur
temprecset.Open("Select
File_Name, Total_Exp, Skill1_Exp from Skill_Info where Skill1_Name like
'%" & Trim(txtSkillName.Text) & "%'")
ElseIf Pattern =
"SUBJECT_LIST" Then
' Si seule la zone de liste 'Compétence' est renseignée par l'utilisateur
temprecset.Open("Select
File_Name, Total_Exp, Skill1_Exp from Skill_Info where Skill1_Name like
'%" & lstSkills.Items.Item(lstSkills.SelectedIndex()) &
"%'")
ElseIf Pattern = "YEARS"
Then
' Si seul le champ 'Expérience' est renseigné par l'utilisateur
temprecset.Open("Select
File_Name, Total_Exp, Skill1_Exp from Skill_Info where Total_Exp = " &
CShort(Trim(txtYears.Text)))
Else
End If
If (temprecset.RecordCount = 0) Then
' Valider la condition si la requête SQL ne renvoie aucun enregistrement
Call
StepsToPerform("FALSE")
MsgBox("Désolé, votre requête n'a généré aucun résultat !", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de cCompétences")
txtSkillName.Focus()
txtSkillName.SelectionStart = 0
txtSkillName.SelectionLength =
Len(Trim(txtSkillName.Text))
GoTo MoveOut
Else
Call
StepsToPerform("TRUE")
' Stocker sinon les valeurs des champs renvoyés dans le tableau nommé 'ResumeArray'
Dim ValueEntered As Boolean
Dim Counter As Short
temprecset.MoveFirst()
Counter = 0
While Not (temprecset.EOF)
ValueEntered = False
For ictr = 0 To 499
For jctr = 0 To 2
If (ResumeArray(ictr,
0) = "") Then
ResumeArray(ictr,
0) = temprecset.Fields("File_Name").Value
ResumeArray(ictr,
1) = temprecset.Fields("Total_Exp").Value
ResumeArray(ictr,
2) = temprecset.Fields("Skill1_Exp").Value
ValueEntered =
True
Counter = Counter
+ 1
End If
If (ValueEntered =
True) Then
Exit For
End If
Next jctr
If (ValueEntered = True)
Then
Exit For
End If
Next ictr
temprecset.MoveNext()
End While
temprecset.Close()
Dim CheckForBoth As Boolean
CheckForBoth = False
lstResumes.Items.Clear()
For ictr = 0 To Counter
For jctr = 0 To 2
If ResumeArray(ictr, 0)
<> "" Then
If (Pattern <>
"YEARS") Then
If Pattern = "BOTHFROMTEXT" Or Pattern =
"BOTHFROMLIST" Then
If
CInt(ResumeArray(ictr, 2)) >= CInt(txtYears.Text) Then
CheckForBoth = True
Dim
objListItem As ListViewItem
objListItem = lstResumes.Items.Add(ResumeArray(ictr, 0))
objListItem.SubItems.Add(CStr(ResumeArray(ictr, 2)))
objListItem.SubItems.Add(CStr(ResumeArray(ictr, 1)))
Exit For
Else
End If
Else
Dim
objListItem As ListViewItem
objListItem =
lstResumes.Items.Add(ResumeArray(ictr, 0))
objListItem.SubItems.Add(CStr(ResumeArray(ictr, 2)))
objListItem.SubItems.Add(CStr(ResumeArray(ictr, 1)))
Exit For
End If
End If
If (Pattern =
"YEARS") Then
Dim objListItem
As ListViewItem
objListItem =
lstResumes.Items.Add(ResumeArray(ictr, 0))
objListItem.SubItems.Add("")
objListItem.SubItems.Add(CStr(ResumeArray(ictr,
1)))
Exit For
End If
End If
Next jctr
Next ictr
If (Pattern =
"BOTHFROMTEXT" Or Pattern = "BOTHFROMLIST") And
(CheckForBoth = False) Then
Call
StepsToPerform("FALSE")
MsgBox("Désolé, votre requête n'a généré aucun résultat !", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
txtSkillName.Focus()
txtSkillName.SelectionStart =
0
txtSkillName.SelectionLength =
Len(Trim(txtSkillName.Text))
End If
End If
Exit Function
ErrHandler:
MsgBox("L'erreur suivante
(" & CStr(Err.Number) & ") s'est produite :" &
Chr(13) & Err.Description, MsgBoxStyle.Information + MsgBoxStyle.OKOnly,
"Outil Recherche de compétences")
MoveOut:
End Function
Private Sub frmSubjectSearch_Load(ByVal
sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Call PopulateSkillListBox()
Call
StepsToPerform("FALSE")
End Sub
Function StepsToPerform(ByVal CheckValue
As String)
If CheckValue = "FALSE"
Then
' Ajuster la hauteur d'affichage du formulaire et des autres contrôles en fonction des conditions présentes
Me.Height = 112
Else
Me.Height = 488
End If
lstResumes.Visible = CheckValue
lblInfo.Visible = CheckValue
End Function
Private Sub lstResumes_DoubleClick(ByVal
sender As Object, ByVal e As System.EventArgs) Handles lstResumes.DoubleClick
On Error GoTo HandleErr
' Cette fonction est invoquée lorsque l'utilisateur double-clique dans la zone de liste Profils
Dim CheckFileExistence1 As String
Dim CheckFileExistence2 As String
Dim tempStoreStr As String
Dim FilePos As Short
If lstResumes.SelectedItems.Count
> 0 Then
tempStoreStr =
lstResumes.SelectedItems(0).Text
FilePos = InStr(1, tempStoreStr,
".doc", CompareMethod.Text)
End If
Dim myWord1 As New Word.Application()
Dim Word1 As New Word.Application()
If (FilePos <> 0) Then
tempStoreStr = Mid(tempStoreStr,
1, FilePos + 3)
If
Len(Trim(Application.StartupPath)) > 3 Then
CheckFileExistence2 =
Dir(Application.StartupPath & "\files\" & tempStoreStr)
Else
CheckFileExistence2 =
Dir(Application.StartupPath & "files\" & tempStoreStr)
End If
If UCase(CheckFileExistence2)
<> UCase(tempStoreStr) Then
MsgBox("Impossible de localiser le document '" & tempStoreStr & "'.", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
Exit Sub
End If
On Error Resume Next
If Err.Number <> 0 Then
Word1.Application.Visible =
True
Word1.Application.WindowState
= Word.WdWindowState.wdWindowStateMaximize
If Len(Trim(Application.StartupPath)) > 3 Then
Word1.Documents.Open(FileName:=Application.StartupPath &
"\files\" & tempStoreStr)
Else
Word1.Documents.Open(FileName:=Application.StartupPath &
"files\" & tempStoreStr)
End If
Else
myWord1.Parent.Windows(1).Visible = True
myWord1.Application.WindowState =
Word.WdWindowState.wdWindowStateMaximize
If Len(Trim(Application.StartupPath))
> 3 Then
myWord1.Documents.Open(FileName:=Application.StartupPath &
"\files\" & tempStoreStr)
Else
myWord1.Documents.Open(FileName:=Application.StartupPath &
"files\" & tempStoreStr)
End If
End If
Err.Clear()
End If
Dim myWord2 As New Word.Application()
Dim Word2 As New Word.Application()
If (FilePos = 0) Then
FilePos = InStr(1, tempStoreStr,
".DOC", CompareMethod.Text)
tempStoreStr = Mid(tempStoreStr,
1, FilePos + 3)
If
Len(Trim(Application.StartupPath)) > 3 Then
CheckFileExistence1 =
Dir(Application.StartupPath & "\files\" & tempStoreStr)
Else
CheckFileExistence1 =
Dir(Application.StartupPath & "files\" & tempStoreStr)
End If
If UCase(CheckFileExistence1)
<> UCase(tempStoreStr) Then
MsgBox("Impossible de localiser le document '" & tempStoreStr & "'.", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
Exit Sub
End If
On Error Resume Next
If Err.Number <> 0 Then
Word2.Application.Visible =
True
Word2.Application.WindowState
= Word.WdWindowState.wdWindowStateMaximize
If
Len(Trim(Application.StartupPath)) > 3 Then
Word2.Documents.Open(FileName:=Application.StartupPath &
"\files\" & tempStoreStr)
Else
Word2.Documents.Open(FileName:=Application.StartupPath &
"files\" & tempStoreStr)
End If
Else
myWord2.Parent.Windows(1).Visible = True
myWord2.Application.WindowState =
Word.WdWindowState.wdWindowStateMaximize
If
Len(Trim(Application.StartupPath)) > 3 Then
myWord2.Documents.Open(FileName:=Application.StartupPath &
"\files\" & tempStoreStr)
Else
myWord2.Documents.Open(FileName:=Application.StartupPath &
"files\" & tempStoreStr)
End If
End If
Err.Clear()
End If
HandleErr:
If Err.Number = 52 Then
MsgBox("Vérifiez que le dossier contenant les fichiers apparentés aux compétences est bien partagé.", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
End If
End Sub
Function PopulateSkillListBox()
Dim Conn_Object As New ADODB.Connection()
' Fonction d'ajout des compétences primaires à la zone de liste Compétence
Dim recset_Object As New
ADODB.Recordset()
If Len(Trim(Application.StartupPath))
> 3 Then
Conn_Object.Open(("Provider=Microsoft.Jet.OLEDB.4.0;" &
"Data Source=" & Application.StartupPath &
"\Skills.mdb"))
Else
Conn_Object.Open(("Provider=Microsoft.Jet.OLEDB.4.0;" &
"Data Source=" & Application.StartupPath &
"Skills.mdb"))
End If
recset_Object.CursorType =
ADODB.CursorTypeEnum.adOpenKeyset
recset_Object.LockType =
ADODB.LockTypeEnum.adLockOptimistic
recset_Object.let_ActiveConnection(Conn_Object)
recset_Object.Open("Select
Distinct Skill1_Name from Skill_Info")
If (recset_Object.RecordCount = 0)
Then
recset_Object.Close()
Conn_Object.Close()
MsgBox("Désolé, aucune entrée Compétence n'a été identifiée dans la base de données Skills !", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
lstSkills.Focus()
GoTo MoveOut
Else
recset_Object.MoveFirst()
While Not recset_Object.EOF()
lstSkills.Items.Add((recset_Object.Fields("Skill1_Name").Value))
recset_Object.MoveNext()
End While
recset_Object.Close()
Conn_Object.Close()
End If
MoveOut:
End Function
Private Sub lstSkills_SelectedValueChanged(ByVal
sender As Object, ByVal e As System.EventArgs) Handles
lstSkills.SelectedValueChanged
txtSkillName.Text =
CStr("")
End Sub
Private Sub
lstSkills_SelectedIndexChanged(ByVal sender As Object, ByVal e As
System.EventArgs) Handles lstSkills.SelectedIndexChanged
txtSkillName.Text =
CStr("")
End Sub
End Class
Dim ProfileName As String
Private Sub
cmbNames_SelectedIndexChanged(ByVal sender As Object, ByVal e As
System.EventArgs) Handles cmbNames.SelectedIndexChanged
On Error GoTo ErrHandler
' Cette fonction est invoquée lors d'une modification de la zone de liste
' modifiable Nom du salarié
Dim checkreturnvalue As Boolean
checkreturnvalue = ValidateEmpName()
If (checkreturnvalue = False) Then
GoTo MoveOut
End If
Dim temprecset As New
ADODB.Recordset()
temprecset.CursorType =
ADODB.CursorTypeEnum.adOpenKeyset
temprecset.LockType =
ADODB.LockTypeEnum.adLockOptimistic
temprecset.ActiveConnection =
MastDBConn_Obj
temprecset.Open("Select Name,
EmpCode, Location, Work_Phone, Mobile_Phone, Email_Id, File_Name from
Skill_Info where Name like '%" & Trim(cmbNames.Text) &
"%'")
If (temprecset.RecordCount = 0) Then
temprecset.Close()
Dim Pattern As String
Pattern = "FALSE"
Call DoTasks(Pattern)
MsgBox("Désolé, votre requête n'a généré aucun résultat !", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
cmbNames.Focus()
cmbNames.SelectionStart = 0
cmbNames.SelectionLength =
Len(Trim(cmbNames.Text))
GoTo MoveOut
Else
Dim Pattern As String
Pattern = "TRUE"
Call DoTasks(Pattern)
cmbNames.Text =
temprecset.Fields("Name").Value
txtAddress.Text =
temprecset("Location").Value
txtPhoneNo.Text =
temprecset("Work_Phone").Value
txtEmailId.Text =
temprecset("Email_Id").Value
txtEmpCode.Text =
temprecset("EmpCode").Value
txtMobile.Text =
temprecset("Mobile_Phone").Value
ProfileName =
temprecset("File_Name").Value
temprecset.Close()
End If
Exit Sub
ErrHandler:
MsgBox("L'erreur suivante (" & CStr(Err.Number) & ") s'est produite :" & Chr(13) & Err.Description, MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de Compétences")
MoveOut:
End Sub
Private Sub cmdBack_Click(ByVal sender As
System.Object, ByVal e As System.EventArgs) Handles cmdBack.Click
Me.Hide()
Dim MainForm As New frmMain()
' Créer une instance du formulaire 'frmMain'
MainForm.Show()
End Sub
Private Sub cmdNameSearch_Click(ByVal
sender As System.Object, ByVal e As System.EventArgs)
Handles cmdNameSearch.Click
On Error GoTo ErrHandler
' Cette fonction est invoquée lorsque l'utilisateur clique sur
' le bouton Rechercher
Dim checkreturnvalue As Boolean
checkreturnvalue = ValidateEmpName()
' Valide le nom de salarié entré par l'utilisateur
If (checkreturnvalue = False) Then
GoTo MoveOut
End If
Dim temprecset As New
ADODB.Recordset()
temprecset.CursorType =
ADODB.CursorTypeEnum.adOpenKeyset
temprecset.LockType =
ADODB.LockTypeEnum.adLockOptimistic
temprecset.let_ActiveConnection(MastDBConn_Obj)
temprecset.Open("Select Name,
Location, Work_Phone, EmpCode,_Mobile_Phone, File_Name, Email_Id from
Skill_Info where Name like '%" & Trim(cmbNames.Text) &
"%'")
If (temprecset.RecordCount = 0) Then
temprecset.Close()
Dim Pattern As String
Pattern = "FALSE"
Call DoTasks(Pattern)
MsgBox("Désolé, votre requête n'a généré aucun résultat !", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
cmbNames.Focus()
cmbNames.SelectionStart = 0
cmbNames.SelectionLength =
Len(Trim(cmbNames.Text))
GoTo MoveOut
Else
Dim Pattern As String
Pattern = "TRUE"
Call DoTasks(Pattern)
cmbNames.Text =
temprecset("Name").Value
txtAddress.Text =
temprecset("Location").Value
txtPhoneNo.Text =
temprecset("Work_Phone").Value
txtEmailId.Text = temprecset("Email_Id").Value
txtEmpCode.Text =
temprecset("EmpCode").Value
txtMobile.Text =
temprecset("Mobile_Phone").Value
ProfileName =
temprecset("File_Name").Value
temprecset.Close()
End If
Exit Sub
ErrHandler:
MsgBox("L'erreur suivante (" & CStr(Err.Number) & ") s'est produite :" & Chr(13) & Err.Description, MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
MoveOut:
End Sub
Private Sub frmNameSearch_Load(ByVal
sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Call PopulateNamesCombo()
' Cette fonction renseigne la zone de liste modifiable Employee Names
' avec les noms récupérés dans la base de données
'
Dim firstvalue As String
'
firstvalue = cmbNames.Items.Item(0)
cmbNames.Text = ""
Call DoTasks(False)
cmdNameSearch.Focus()
'
Call cmdNameSearch_Click(Me, New System.EventArgs())
End Sub
Function ValidateEmpName() As Boolean
Dim testSMENameContents As String
testSMENameContents =
Trim(cmbNames.Text)
If (Len(Trim(testSMENameContents)) =
0) Then
' Validation pour une entrée vierge
MsgBox("Entrée vierge trouvée dans le champ 'Nom du salarié' !", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
cmbNames.Focus()
cmbNames.SelectionStart = 0
cmbNames.SelectionLength =
Len(Trim(cmbNames.Text))
ValidateEmpName = False
Exit Function
End If
ValidateEmpName = True
End Function
Function PopulateNamesCombo() As Object
Dim Conn_Object As New
ADODB.Connection()
' Fonction d'ajout des entrées Nom du salarié dans la zone de liste modifiable 'Nom du salarié'
Dim recset_Object As New
ADODB.Recordset()
If Len(Trim(Application.StartupPath))
> 3 Then
Conn_Object.Open(("Provider=Microsoft.Jet.OLEDB.4.0;"
& "Data Source=" & Application.StartupPath &
"\Skills.mdb"))
Else
Conn_Object.Open(("Provider=Microsoft.Jet.OLEDB.4.0;" &
"Data Source=" & Application.StartupPath &
"Skills.mdb"))
End If
recset_Object.CursorType =
ADODB.CursorTypeEnum.adOpenKeyset
recset_Object.LockType =
ADODB.LockTypeEnum.adLockOptimistic
recset_Object.let_ActiveConnection(Conn_Object)
recset_Object.Open("Select Name
from Skill_Info")
If (recset_Object.RecordCount = 0)
Then
recset_Object.Close()
Conn_Object.Close()
Call frmNameSearch_Load(Me, New
System.EventArgs())
MsgBox("Désolé, aucun nom de salarié n'a été trouvé dans la base de données Skills !", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de Compétences")
cmbNames.Focus()
GoTo MoveOut
Else
recset_Object.MoveFirst()
While Not recset_Object.EOF()
cmbNames.Items.Add((recset_Object.Fields("Name").Value))
recset_Object.MoveNext()
End While
recset_Object.Close()
Conn_Object.Close()
End If
MoveOut:
End Function
Function DoTasks(ByVal PatternEntered As
String)
If PatternEntered = "TRUE"
Then
' Fonction d'ajustement de la hauteur d'affichage du formulaire et
' des contrôles en fonction de la condition actuelle.
Me.Height = 312
Else
Me.Height = 120
End If
lblEmpCode.Visible = PatternEntered
txtEmpCode.Visible = PatternEntered
lblMobile.Visible = PatternEntered
txtMobile.Visible = PatternEntered
lblLink.Visible = PatternEntered
cmdLink.Visible = PatternEntered
lblAddress.Visible = PatternEntered
txtAddress.Visible = PatternEntered
lblPhone.Visible = PatternEntered
txtPhoneNo.Visible = PatternEntered
lblEmail.Visible = PatternEntered
txtEmailId.Visible = PatternEntered
End Function
Private Sub cmdLink_Click(ByVal sender As
System.Object, ByVal e As System.EventArgs) Handles cmdLink.Click
On Error GoTo HandleErr
' Cette fonction est invoquée lorsque l'utilisateur clique sur le bouton Profil
Dim CheckFileExistence As String
Dim Word1 As New Word.Application()
If Len(Trim(Application.StartupPath))
> 3 Then
CheckFileExistence = Dir(Application.StartupPath
& "\files\" & ProfileName)
Else
CheckFileExistence =
Dir(Application.StartupPath & "files\" & ProfileName)
End If
If UCase(CheckFileExistence) <>
UCase(ProfileName) Then
MsgBox("impossible de localiser le document '"& ProfileName & "'.", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
Exit Sub
End If
On Error Resume Next
If Err.Number = 0 Then
Word1.Parent.Windows(1).Visible =
True
Word1.Application.WindowState =
Word.WdWindowState.wdWindowStateMaximize
If
Len(Trim(Application.StartupPath)) > 3 Then
Word1.Documents.Open(FileName:=Application.StartupPath &
"\files\" & ProfileName)
Else
Word1.Documents.Open(FileName:=Application.StartupPath &
"files\" & ProfileName)
End If
End If
Err.Clear()
HandleErr:
If Err.Number = 52 Then
MsgBox("Vérifiez que le dossier contenant les fichiers apparentés à l'application Compétences est bien partagé.", MsgBoxStyle.Information + MsgBoxStyle.OKOnly, "Outil Recherche de compétences")
End If
End Sub
End Class
Module SearchMod
Public StoreVal As String
Public MastDBConn_Obj As New
ADODB.Connection()
Public QueryPattern As String
End Module
function listChange()
{
var skillname=document.frmSkills.lstSkills.options[document.frmSkills.lstSkills.selectedIndex].text
var noOfMonths=document.frmSkills.txtnoOfMonths.value;
if (skillname != "<Sélectionnez une entrée dans la liste>") {
var noOfMonthsLength=(document.frmSkills.txtnoOfMonths.value.length);
if (noOfMonths=="") {
noOfMonths=0;
location.href =
"Skillsearch.aspx" + "?skill=" + skillname +
"&months=" + noOfMonths;
}
if (noOfMonths!="") {
checkyear =0;
for( j=0; j<noOfMonthsLength ;
j++) {
if
(noOfMonths.charAt(j)==" ") {
continue;
}
else {
checkyear =1;
break;
}
}
if (checkyear == 0 ) {
alert("Le champ 'Expérience (en mois) :' doit être renseigné.");
document.frmSkills.txtnoOfMonths.value= "";
document.frmSkills.txtnoOfMonths.focus();
return;
}
if(isNaN(noOfMonths)) {
alert("Entrée non numérique trouvée dans le champ 'Expérience (en mois' :'");
document.frmSkills.txtnoOfMonths.value= "";
document.frmSkills.txtnoOfMonths.focus();
return;
}
location.href =
"Skillsearch.aspx" + "?skill=" + skillname +
"&months=" + noOfMonths;
}
} else {
alert("Sélectionnez une compétence valide dans la liste des compétences.");
document.frmSkills.lstSkills.focus();
return;
}
}
function validateskill()
{
var skillname=document.frmSkills.txtSkill.value;
var noOfMonths=document.frmSkills.txtnoOfMonths.value;
var skillnameLength=document.frmSkills.txtSkill.value.length;
var noOfMonthsLength=document.frmSkills.txtnoOfMonths.value.length;
if (noOfMonths=="")
{
if (skillname == "")
{
alert("Le champ 'Entrez une compétence' doit être renseigné.");
document.frmSkills.txtSkill.value= "";
document.frmSkills.txtSkill.focus();
return;
}
checkskill = 0;
for( j=0; j<skillnameLength ; j++) {
if (skillname.charAt(j)=="
") {
continue;
}
else {
checkskill=1;
break;
}
}
if (checkskill == 0 ) {
alert("Le champ 'Entrez une compétence' doit être renseigné.");
document.frmSkills.txtSkill.value= "";
document.frmSkills.txtSkill.focus();
return;
}
noOfMonths=0;
location.href =
"Skillsearch.aspx" + "?skill=" + skillname +
"&months=" + noOfMonths;
return;
}
if ((noOfMonths!="") && (skillname == ""))
{
alert("Le champ 'Entrez une compétence' doit être renseigné.");
document.frmSkills.txtSkill.value= "";
document.frmSkills.txtSkill.focus();
return;
}
if (noOfMonths!="")
{
checkyear =0;
for( j=0; j<noOfMonthsLength ; j++)
{
if (noOfMonths.charAt(j)=="
") {
continue;
}
else {
checkyear =1;
break;
}
}
if (checkyear == 0 ) {
alert("Le champ 'Expérience (en mois) :' doit être renseigné.");
document.frmSkills.txtnoOfMonths.value= "";
document.frmSkills.txtnoOfMonths.focus();
return;
}
if(isNaN(noOfMonths)) {
alert("Entrée non numérique trouvée dans le champ 'Expérience (en mois' :'");
document.frmSkills.txtnoOfMonths.value= "";
document.frmSkills.txtnoOfMonths.focus();
return;
}
if (skillname == "")
{
alert("Le champ 'Entrez une compétence' doit être renseigné.");
document.frmSkills.txtSkill.value= "";
document.frmSkills.txtSkill.focus();
return;
}
checkskill = 0;
for( j=0; j<skillnameLength ; j++) {
if (skillname.charAt(j)=="
") {
continue;
}
else {
checkskill=1;
break;
}
}
if (checkskill == 0 ) {
alert("Le champ 'Entrez une compétence' doit être renseigné.");
document.frmSkills.txtSkill.value= "";
document.frmSkills.txtSkill.focus();
return;
}
location.href =
"Skillsearch.aspx" + "?skill=" + skillname +
"&months=" + noOfMonths;
return;
}
}
function moveback()
{
location.href= "main.aspx";
}
'Cette fonction est invoquée lorsque l'utilisateur clique sur le bouton OK
Private Sub cmdOK_Click(ByVal eventSender As
System.Object, ByVal eventArgs As System.EventArgs) Handles cmdOk.Click
Dim IsUnconventionalErrorFound As Boolean
Dim IsDriveExist As Boolean
Dim CheckDrive As String
Dim LastPos As Integer
Dim res As Object
Dim OutputPath As String
Dim ControlFilePath As String
Dim ScriptPath As String
' Le code suivant valide les informations de chemins d'accès entrées pour les fichiers de script, de contrôle et de sortie
If Trim(txtScriptFilePath.Text) =
Trim(txtOutputPath.Text) Then
MsgBox("Les informations de chemin d'accès du fichier de script et du fichier de sortie sont identiques. Vérifiez s'il vous plaît !", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
End If
PunctuationErr = ""
Dim HasWritePermission As Boolean
HasWritePermission = True
ScriptPath =
LTrim(RTrim(txtScriptFilePath.Text))
'Code de validation des informations du chemin d'accès au fichier de Script
If Len(ScriptPath) = 0 Then
MsgBox("Saisissez s'il vous plaît un chemin d'accès au fichier de script", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtScriptFilePath.Focus()
GoTo OutOfHere
End If
ControlFilePath =
LTrim(RTrim(txtControlFilePath.Text))
'Code de validation du chemin d'accès au fichier de contrôle
If Len(ControlFilePath) = 0 Then
MsgBox("Saisissez s'il vous plaît un chemin d'accès au fichier de contrôle standard", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtControlFilePath.Focus()
GoTo OutOfHere
End If
OutputPath =
LTrim(RTrim(txtOutputPath.Text))
' Code de validation du chemin d'accès au fichier de sortie
If Len(OutputPath) = 0 Then
MsgBox("Saisissez s'il vous plaît un chemin d'accès au fichier de sortie", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
End If
If Mid(ScriptPath, 2, 2) <>
":\" Then
MsgBox("Informations de chemin d'accès invalides pour le fichier de script. Si le fichier est situé sur un réseau, vérifiez que le chemin d'accès existe.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtScriptFilePath.Focus()
GoTo OutOfHere
End If
If Mid(ControlFilePath, 2, 2) <>
":\" Then
MsgBox("Informations de chemin d'accès invalides pour le fichier de contrôle standard. Si le fichier est situé sur un réseau, vérifiez que le chemin d'accès existe.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation,
"Vérification de document")
txtControlFilePath.Focus()
GoTo OutOfHere
End If
If Mid(OutputPath, 2, 2) <>
":\" Then
MsgBox("Informations de chemin d'accès invalides pour le fichier de contrôle standard. Si le fichier est situé sur un réseau, vérifiez que le chemin d'accès existe.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
End If
Dim testdir1 As String
testdir1 = Dir(ScriptPath,
FileAttribute.Normal)
If (testdir1 = "") Then
MsgBox("Informations de chemin d'accès au fichier de script " + ScriptPath + " inexistantes.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtScriptFilePath.Focus()
GoTo OutOfHere
Else
If
UCase(Microsoft.VisualBasic.Right(ScriptPath, 4)) <>
UCase(".doc") Then
MsgBox("Format de fichier invalide sélectionné dans les informations de chemin du fichier de script." & Chr(13) & Chr(13) & "Le fichier sélectionné n'est pas un fichier .rtf ou .doc.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtScriptFilePath.Focus()
GoTo OutOfHere
End If
End If
testdir1 = Dir(ControlFilePath,
FileAttribute.Normal)
If (testdir1 = "") Then
MsgBox("Informations de chemin d'accès au fichier de contrôle standard " + ControlFilePath + " inexistantes.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtControlFilePath.Focus()
GoTo OutOfHere
ElseIf
UCase(Microsoft.VisualBasic.Right(ControlFilePath, 4)) <>
UCase(".doc") Then
MsgBox("Format de fichier invalide sélectionné dans les informations de chemin du fichier de contrôle standard." & Chr(13) & Chr(13) & "Le fichier sélectionné n'est pas un fichier .doc.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document ")
txtControlFilePath.Focus()
GoTo OutOfHere
End If
If UCase(Microsoft.VisualBasic.Right(OutputPath,
4)) <> UCase(".doc") Then
MsgBox("Format de fichier invalide sélectionné dans les informations de chemin du fichier de sortie." & Chr(13) & Chr(13) & " Le fichier sélectionné n'est pas un fichier .doc.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
ElseIf
UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) = UCase("\.doc") Or
UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) = UCase("/.doc")
Or
UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) =
UCase(":.doc") Or
UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) =
UCase("*.doc") Or
UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) =
UCase("?.doc") Or
UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) =
UCase(""".doc") Or
UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) =
UCase(">.doc") Or
UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) =
UCase("<.doc") Or
UCase(Microsoft.VisualBasic.Right(OutputPath,
5)) = UCase("|.doc") Then
MsgBox("Nom de fichier invalide sélectionné dans les informations du chemin d'accès au fichier de sortie.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
Else
End If
LastPos = InStrRev(OutputPath,
"\")
CheckDrive = ""
If LastPos > 3 Then
CheckDrive =
Microsoft.VisualBasic.Left(OutputPath, LastPos - 1)
Else
CheckDrive = Microsoft.VisualBasic.Left(OutputPath,
LastPos)
End If
Dim drv As Object
'Code de validation de la lettre du lecteur entrée pour le chemin du fichier de sortie
drv =
CreateObject("Scripting.FileSystemObject")
IsDriveExist =
drv.DriveExists(Microsoft.VisualBasic.Left(OutputPath, 3))
If IsDriveExist = False Then
MsgBox("Le lecteur " & Microsoft.VisualBasic.Left(OutputPath, 3) & "spécifié dans les informations du chemin d'accès au fichier de sortie est inexistant. Si le chemin est situé sur un réseau, vérifiez son existence.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
End If
HasWritePermission = False
On Error GoTo OutOfHere
If
Microsoft.VisualBasic.Right(CheckDrive, 1) <> "\" Then
'Code de vérification de l'autorisation en écriture pour le chemin d'accès au fichier de sortie
MkDir(CheckDrive +
"\CheckWritePermission")
RmDir(CheckDrive +
"\CheckWritePermission")
Else
MkDir(CheckDrive +
"CheckWritePermission")
RmDir(CheckDrive +
"CheckWritePermission") Listing
End If
HasWritePermission = True
If Trim(txtScriptFilePath.Text) =
Trim(txtControlFilePath.Text) Then
MsgBox("Les informations de chemins d'accès du fichier de script et du fichier de contrôle sont identiques. Vérifiez s'il vous plaît !", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtControlFilePath.Focus()
GoTo OutOfHere
ElseIf Trim(txtScriptFilePath.Text) =
Trim(txtOutputPath.Text) Then
MsgBox("Les informations de chemins d'accès du fichier de script et du fichier de sortie sont identiques. Vérifiez s'il vous plaît !", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
ElseIf Trim(txtControlFilePath.Text) =
Trim(txtOutputPath.Text) Then
MsgBox("Les informations de chemins d'accès du fichier de contrôle et du fichier de sortie sont identiques. Vérifiez s'il vous plaît !", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
End If
' Fin du code de validation des chemins d'accès aux fichiers de script, de contrôle et de sortie
control and output file
Word1 = New Word.Application()
Word1.Application.Visible = True
Word1.Activate()
IsUnconventionalErrorFound = False
OpenStandardControlFileAndStoreErrWords(ControlFilePath, ScriptPath,
OutputPath)
' Fonction d'ouverture du fichier de contrôle et de stockage des mots erronés
Call cmdExit_Click(cmdExit, New
System.EventArgs())
OutOfHere:
If HasWritePermission = False Then
MsgBox("Informations de chemin d'accès de sortie invalides. Vérifiez que vous disposez des autorisations d'écriture sur le chemin de sortie.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
End If
End Sub
' Cette sous-routine ouvre le fichier de contrôle et stocke les mots erronés
Sub
OpenStandardControlFileAndStoreErrWords(ByRef ControlFilePath As Object, ByRef
ScriptPath As Object, ByRef OutputPath As Object)
Dim IsUnconventionalErrorFound As
Boolean
Dim res As Object
Dim LastRowOfInputFile As Integer
CounterErrorWordsAndSuggestions = 0
Word1.WordBasic.FileOpen(Name:=ControlFilePath, ConfirmConversions:=0,
ReadOnly:=0, AddToMru:=0, PasswordDoc:="", PasswordDot:="",
Revert:=0, WritePasswordDoc:="", WritePasswordDot:="")
LastRowOfInputFile = 0
Word1.WordBasic.EndOfDocument()
If
Word1.WordBasic.CmpBookmarks("\Sel", "\StartOfDoc") = 0
Then
Word1.WordBasic.MsgBox("Le fichier de contrôle standard '" + ControlFilePath + "' a été altéré et ne contient aucun texte.", "Vérification de document")
GoTo EnoughStoringFromControlFile
End If
ReadString =
Word1.WordBasic.Selection()
res = Trimmer(ReadString)
While Len(Trim(ReadString)) <= 1
Word1.WordBasic.CharLeft(1)
ReadString =
Word1.WordBasic.Selection()
res = Trimmer(ReadString)
If Len(ReadString) > 1 Then
If Word1.WordBasic.SelInfo(12) <>
-1 Then
IsUnconventionalErrorFound = True
Word1.WordBasic.MsgBox("Une entrée a été trouvée dans le tableau de '" + ControlFilePath + "'.", "Vérification de document")
GoTo EnoughStoringFromControlFile
End If
LastRowOfInputFile =
Word1.WordBasic.SelInfo(13)
GoTo LastRowStored
End If
If LastRowOfInputFile > 1150 Then
Word1.WordBasic.MsgBox("Le fichier de contrôle standard '" + ControlFilePath + "' contient plus de 1150 lignes.", "Vérification de document")
GoTo EnoughStoringFromControlFile
End If
If
Word1.WordBasic.CmpBookmarks("\Sel", "\StartOfDoc") = 0
Then
Word1.WordBasic.MsgBox("Le fichier de contrôle standard '" + ControlFilePath + "' a été altéré et ne contient aucun texte.", "Vérification de document")
GoTo EnoughStoringFromControlFile
End If
End While
LastRowStored:
Var(0) = Chr(45)
Var(1) = Chr(150)
Var(2) = Chr(151)
Var(3) = Chr(173)
Var(4) = Chr(40)
Var(5) = Chr(123)
Var(6) = Chr(91)
Var(7) = Chr(41)
Var(8) = Chr(125)
Var(9) = Chr(93)
Var(10) = " "
Var(11) = Chr(13)
Word1.WordBasic.StartOfDocument()
While Word1.WordBasic.SelInfo(12) <> -1
Word1.WordBasic.CharRight(1)
If
Word1.WordBasic.CmpBookmarks("\Sel", "\EndOfDoc") = 0 Then
IsUnconventionalErrorFound = True
Word1.WordBasic.MsgBox("Le fichier '" + ControlFilePath + "' ne contient aucun tableau.", "Vérification de document")
GoTo EnoughStoringFromControlFile
End If
End While
Word1.WordBasic.NextCell()
Word1.WordBasic.PrevCell()
While Word1.WordBasic.SelInfo(13) <= LastRowOfInputFile
If Word1.WordBasic.SelInfo(16) <>
1 Then
Word1.WordBasic.MsgBox("La première entrée du fichier '" + ControlFilePath + "' n'est pas dans la première colonne.", "Vérification de document")
GoTo EnoughStoringFromControlFile
Else
ReadString =
Word1.WordBasic.Selection()
res = Trimmer(ReadString)
If Len(ReadString) > 0 Then
ErrorWordsAndSuggestions(CounterErrorWordsAndSuggestions, 0) =
ReadString
Word1.WordBasic.NextCell()
If Word1.WordBasic.SelInfo(16) <>
2 Then
Word1.WordBasic.MsgBox("La deuxième entrée du fichier '" + ControlFilePath + "' n'est pas dans la deuxième colonne.", "Vérification de document")
GoTo EnoughStoringFromControlFile
Else
ReadString =
Word1.WordBasic.Selection()
res = Trimmer(ReadString)
If Len(ReadString) > 0 Then
ErrorWordsAndSuggestions(CounterErrorWordsAndSuggestions, 1) =
ReadString
End If
If Word1.WordBasic.SelInfo(13) <>
LastRowOfInputFile Then
Word1.WordBasic.NextCell()
Else
GoTo OutOfStoring
End If
End If
CounterErrorWordsAndSuggestions =
CounterErrorWordsAndSuggestions + 1
Else
If Word1.WordBasic.SelInfo(13) <>
LastRowOfInputFile Then
Word1.WordBasic.NextCell()
Word1.WordBasic.NextCell()
Else
GoTo OutOfStoring
End If
End If
End If
End While
OutOfStoring:
OpenScriptAndStartProcessing(ScriptPath,
OutputPath)
' Fonction d'ouverture du fichier de script et début du traitement
EnoughStoringFromControlFile:
End Sub
Sub OpenScriptAndStartProcessing(ByRef
ScriptPath As Object, ByRef OutputPath As Object)
Dim i As Integer
Dim DoNotCheck As Boolean
Dim res As Object
Dim IsBlank As Boolean
Dim ScriptWindow As String
Dim Flagstr As Object
Dim ErrFileWindow As String
NumberOfErrors = 0
PartialFound = False
Word1.WordBasic.FileNewDefault()
ErrFileWindow =
Word1.WordBasic.WindowName()
CreateErrlogTable((Flagstr))
Word1.WordBasic.Fileopen
(Name:=ScriptPath, ConfirmConversions:=0, ReadOnly:=0, AddToMru:=0,
PasswordDoc:="", PasswordDot:="", Revert:=0,
WritePasswordDoc:="", WritePasswordDot:="")
Word1.WordBasic.ViewNormal()
ScriptWindow =
Word1.WordBasic.WindowName()
Word1.WordBasic.StartOfDocument()
Word1.WordBasic.ParaDown(1, 1)
If
Word1.WordBasic.CmpBookmarks("\Sel", "\StartOfDoc") = 0
Then
Word1.WordBasic.MsgBox("Fichier de script '" + ScriptPath + "' vierge.", "Vérification de document")
GoTo
EnoughOpenScriptAndStartProcessing
End If
IsBlank = True
While
Word1.WordBasic.CmpBookmarks("\Sel", "\EndOfDoc")
Word1.WordBasic.CharRight(1)
If Word1.WordBasic.SelInfo(12) = -1
Then
Word1.WordBasic.MsgBox("Fichier de script '" + ScriptPath + "' sous forme de tableau." + Chr(13) + Chr(13) + "Exécutez à nouveau l'outil en sélectionnant les options adéquates.", "Vérification de document")
GoTo
EnoughOpenScriptAndStartProcessing
End If
Word1.WordBasic.ParaDown(1, 1)
ReadString =
Word1.WordBasic.Selection()
res = Trimmer(ReadString)
If Len(ReadString) > 0 Then
IsBlank = False
DoNotCheck = False
CheckForErrWordsPresent(ReadString,
ScriptWindow, ErrFileWindow)
' Fonction de recherche des mots erronés dans la sélection actuelle
' du fichier de script
End If
End While
If ErrorWordsFoundCtr > 0 Then
' Boucle vers le début du document et modification de la couleur des mots erronés dans le fichier de script
Word1.WordBasic.StartOfDocument()
For i = 0 To ErrorWordsFoundCtr - 1
Word1.WordBasic.EditFind(Find:=ErrorWordsFound(i), WholeWord:=1)
Word1.WordBasic.HighlightColor(3)
Word1.WordBasic.CharRight(1)
Next
Word1.WordBasic.Filesave()
End If
If IsBlank = True Then
Word1.WordBasic.MsgBox("Fichier de script '" + ScriptPath + "' vierge.", "Vérification de document")
GoTo
EnoughOpenScriptAndStartProcessing
End If
' Fonction appelée pour activer le fichier de sortie
ActivateWindow((ErrFileWindow))
If NumberOfErrors = 0 Then
Word1.WordBasic.NextCell()
Word1.WordBasic.ParaDown(3, 1)
Word1.WordBasic.TableMergeCells()
Word1.WordBasic.CharLeft(1)
Word1.WordBasic.Insert("Aucune erreur identifiée.")
Else
Word1.WordBasic.EndOfDocument()
Word1.WordBasic.InsertPara()
' Mise en journal du nombre total des mots erronés identifiés dans le fichier de script
Word1.WordBasic.Insert("Nombre de mots erronés identifiés : " & Str(NumberOfErrors)
If NumberOfErrors >= 1000 Then
Word1.WordBasic.Insert
("L'outil est incapable de mettre en bleu tous les mots erronés car leur nombre est trop élevé.")
End If
End If
Word1.WordBasic.FileSaveAs(Name:=OutputPath, Format:=0, LockAnnot:=0,
Password:="", AddToMru:=1, WritePassword:="",
RecommendReadOnly:=0, EmbedFonts:=0, NativePictureFormat:=0, FormsData:=0,
SaveAsAOCELetter:=0)
Word1.WordBasic.FileClose(1)
Word1.WordBasic.Fileopen(Name:=OutputPath, ConfirmConversions:=0,
ReadOnly:=0, AddToMru:=0, PasswordDoc:="", PasswordDot:="",
Revert:=0, WritePasswordDoc:="", WritePasswordDot:="")
EnoughOpenScriptAndStartProcessing:
End Sub
' Fonction de mise en journal de l'erreur dans le fichier de sortie
Sub LogErr(ByRef ScriptWindow As
Object, ByRef ErrFileWindow As Object, ByRef ChkCtr As Object, ByRef PageNo As
Object, ByRef LineNo As Object)
ActivateWindow((ErrFileWindow))
' Pour activer la fenêtre du fichier de sortie
NumberOfErrors = NumberOfErrors + 1
Word1.WordBasic.Insert(ErrorWordsAndSuggestions(ChkCtr, 0))
If ErrorWordsFoundCtr < 1000 Then
ErrorWordsFound(ErrorWordsFoundCtr) =
ErrorWordsAndSuggestions(ChkCtr, 0)
ErrorWordsFoundCtr =
ErrorWordsFoundCtr + 1
End If
Word1.WordBasic.NextCell()
Word1.WordBasic.Insert("Page" & Str(PageNo) & "
Ligne " & Str(LineNo))
Word1.WordBasic.NextCell()
Word1.WordBasic.Insert(ErrorWordsAndSuggestions(ChkCtr, 1))
Word1.WordBasic.NextCell()
ActivateWindow((ScriptWindow))
' Pour activer la fenêtre du fichier de script
End Sub
Dim FirstEntry As Boolean
Private Sub frmSplash_KeyPress(ByVal
eventSender As System.Object, ByVal eventArgs As
System.Windows.Forms.KeyPressEventArgs) Handles MyBase.KeyPress
Call DoTasks()
End Sub
Private Sub Image1_Click(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles
Image1.Click
Call DoTasks()
End Sub
Private Sub lblProductName_Click(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles
lblProductName.Click
Call DoTasks()
End Sub
Private Sub lblWarning_Click(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles
lblWarning.Click
Call DoTasks()
End Sub
Function DoTasks()
If FirstEntry = False Then
Dim MainForm As New frmMainScreen()
Me.Hide()
MainForm.Show()
FirstEntry = True
End If
End Function
Private Sub Timer1_Tick(ByVal sender As
Object, ByVal e As System.EventArgs) Handles Timer1.Tick
Call DoTasks()
End Sub
Dim Word1 As New Word.Application
Dim OpenFileDialog1 As New
OpenFileDialog()
Dim SaveFileDialog1 As New
OpenFileDialog()
Dim ErrorWordsAndSuggestions(1150, 1) As Object
' Variable Array stockant les mots erronés et les suggestions
Dim ErrorWordsFound(1000) As String
Dim ErrorWordsFoundCtr As Short
Dim ReadString As String
Dim CounterErrorWordsAndSuggestions As
Short
Dim NumberOfErrors As Short
Dim Var(11) As String
Dim PunctuationErr As String
Dim LoggedWords(20) As String
Dim LoggedWordsctr As Short
Dim PartialFound As Boolean
Private Sub cmdBrowse1_Click(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles
cmdBrowseScript.Click
OpenFileDialog1.InitialDirectory =
Application.ExecutablePath
' Cette fonction est invoquée suite à un clic sur le bouton Parcourir
' pour sélectionner le fichier de script
OpenFileDialog1.Title = "Sélectionnez le fichier de Script"
OpenFileDialog1.Filter = "MS-Word Documents|*.doc"
OpenFileDialog1.FilterIndex = 1
If OpenFileDialog1.ShowDialog() <> DialogResult.Cancel Then
txtScriptFilePath.Text =
OpenFileDialog1.FileName
Else
txtScriptFilePath.Text = ""
End If
End Sub
Private Sub cmdBrowse2_Click(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles
cmdBrowseControlFile.Click
OpenFileDialog1.InitialDirectory =
Application.ExecutablePath
' Cette fonction est invoquée suite à un clic sur le bouton Parcourir
' pour sélectionner le fichier de contrôle
OpenFileDialog1.Title = "Sélectionnez le fichier de Contrôle"
OpenFileDialog1.Filter = "MS-Word Documents|*.doc"
OpenFileDialog1.FilterIndex = 1
If OpenFileDialog1.ShowDialog() <> DialogResult.Cancel Then
txtControlFilePath.Text =
OpenFileDialog1.FileName
Else
txtControlFilePath.Text = ""
End If
End Sub
Private Sub cmdBrowse3_Click(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles
cmdBrowseOutput.Click
SaveFileDialog1.Title = "Spécifiez le fichier de sortie"
' Cette fonction est invoquée suite à un clic sur le bouton Parcourir
' pour sélectionner le fichier de sortie
SaveFileDialog1.Filter = "MS-Word Documents|*.doc"
SaveFileDialog1.FilterIndex = 1
' SaveFileDialog1.OverwritePrompt = True
If SaveFileDialog1.ShowDialog()
<> DialogResult.Cancel Then
txtOutputPath.Text =
SaveFileDialog1.FileName
Else
txtOutputPath.Text = ""
End If
End Sub
Private Sub cmdCancel_Click(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles
cmdCancel.Click
txtControlFilePath.Text =
"C:\"
' Cette fonction est invoquée suite à un clic sur le bouton Annuler
txtScriptFilePath.Text =
"C:\"
txtOutputPath.Text = "C:\"
End Sub
Private Sub cmdExit_Click(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles
cmdExit.Click
End
End Sub
' Cette fonction est invoquée lorsque l'utilisateur clique sur le bouton OK
Private Sub cmdOK_Click(ByVal
eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles
cmdOk.Click
Dim IsUnconventionalErrorFound As Boolean
Dim IsDriveExist As Boolean
Dim CheckDrive As String
Dim LastPos As Integer
Dim res As Object
Dim OutputPath As String
Dim ControlFilePath As String
Dim ScriptPath As String
' Le code suivant valide les informations de chemins d'accès entrées pour les fichiers de script, de contrôle et de sortie
If Trim(txtScriptFilePath.Text) =
Trim(txtOutputPath.Text) Then
MsgBox("Les informations de chemin d'accès du fichier de script et du fichier de sortie sont identiques. Vérifiez s'il vous plaît !", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
End If
PunctuationErr = ""
Dim HasWritePermission As Boolean
HasWritePermission = True
ScriptPath =
LTrim(RTrim(txtScriptFilePath.Text))
'Code de validation des informations du chemin d'accès au fichier de Script
If Len(ScriptPath) = 0 Then
MsgBox("Saisissez s'il vous plaît un chemin d'accès au fichier de script", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtScriptFilePath.Focus()
GoTo OutOfHere
End If
ControlFilePath =
LTrim(RTrim(txtControlFilePath.Text))
'Code de validation du chemin d'accès au fichier de contrôle
If Len(ControlFilePath) = 0 Then
MsgBox("Saisissez s'il vous plaît un chemin d'accès au fichier de contrôle standard", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtControlFilePath.Focus()
GoTo OutOfHere
End If
OutputPath =
LTrim(RTrim(txtOutputPath.Text))
'Code de validation du chemin d'accès au fichier de sortie
If Len(OutputPath) = 0 Then
MsgBox("Saisissez s'il vous plaît un chemin d'accès au fichier de sortie", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
End If
If Mid(ScriptPath, 2, 2) <>
":\" Then
MsgBox("Informations de chemin d'accès invalides pour le fichier de script. Si le fichier est situé sur un réseau, vérifiez que le chemin d'accès existe.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtScriptFilePath.Focus()
GoTo OutOfHere
End If
If Mid(ControlFilePath, 2, 2) <>
":\" Then
MsgBox("Informations de chemin d'accès invalide pour le fichier de contrôle standard. Si le fichier est sur un réseau, vérifiez que le chemin d'accès existe.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation,
"Vérification de document")
txtControlFilePath.Focus()
GoTo OutOfHere
End If
If Mid(OutputPath, 2, 2) <>
":\" Then
MsgBox("Informations de chemin d'accès invalides pour le fichier de contrôle standard. Si le fichier est situé sur un réseau, vérifiez que le chemin d'accès existe.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
End If
Dim testdir1 As String
testdir1 = Dir(ScriptPath, FileAttribute.Normal)
If (testdir1 = "") Then
MsgBox("Informations de chemin d'accès au fichier de script " + ScriptPath + " inexistantes.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtScriptFilePath.Focus()
GoTo OutOfHere
Else
If
UCase(Microsoft.VisualBasic.Right(ScriptPath, 4)) <>
UCase(".doc") Then
MsgBox("Format de fichier invalide sélectionné dans les informations de chemin du fichier de script." & Chr(13) & Chr(13) & "Le fichier sélectionné n'est pas un fichier .rtf ou .doc.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtScriptFilePath.Focus()
GoTo OutOfHere
End If
End If
testdir1 = Dir(ControlFilePath,
FileAttribute.Normal)
If (testdir1 = "") Then
MsgBox("Informations de chemin d'accès au fichier de contrôle standard " + ControlFilePath + " inexistantes.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtControlFilePath.Focus()
GoTo OutOfHere
ElseIf
UCase(Microsoft.VisualBasic.Right(ControlFilePath, 4)) <>
UCase(".doc") Then
MsgBox("Format de fichier invalide sélectionné dans les informations de chemin du fichier de contrôle standard." & Chr(13) & Chr(13) & "Le fichier sélectionné n'est pas un fichier .doc.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document ")
txtControlFilePath.Focus()
GoTo OutOfHere
End If
If
UCase(Microsoft.VisualBasic.Right(OutputPath, 4)) <>
UCase(".doc") Then
MsgBox("Format de fichier invalide sélectionné dans les informations de chemin du fichier de sortie." & Chr(13) & Chr(13) & " Le fichier sélectionné n'est pas un fichier .doc.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
ElseIf
UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) = UCase("\.doc") Or
UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) = UCase("/.doc") Or
UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) = UCase(":.doc") Or
UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) = UCase("*.doc") Or
UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) = UCase("?.doc") Or
UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) =
UCase(""".doc") Or
UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) = UCase(">.doc")
Or UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) = UCase("<.doc")
Or UCase(Microsoft.VisualBasic.Right(OutputPath, 5)) = UCase("|.doc")
Then
MsgBox("Nom de fichier invalide sélectionné dans les informations de chemin d'accès au fichier de sortie.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
Else
End If
LastPos = InStrRev(OutputPath,
"\")
CheckDrive = ""
If LastPos > 3 Then
CheckDrive =
Microsoft.VisualBasic.Left(OutputPath, LastPos - 1)
Else
CheckDrive =
Microsoft.VisualBasic.Left(OutputPath, LastPos)
End If
Dim drv As Object
'Code de validation de la lettre du lecteur entrée pour le chemin du fichier de sortie
drv =
CreateObject("Scripting.FileSystemObject")
IsDriveExist =
drv.DriveExists(Microsoft.VisualBasic.Left(OutputPath, 3))
If IsDriveExist = False Then
MsgBox("Le lecteur " & Microsoft.VisualBasic.Left(OutputPath, 3) & "spécifié dans les informations de chemin d'accès au fichier de sortie est inexistant. Si le chemin est situé sur un réseau, vérifiez son existence.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
End If
HasWritePermission = False
On Error GoTo OutOfHere
If
Microsoft.VisualBasic.Right(CheckDrive, 1) <> "\" Then
'Code de vérification de l'autorisation en écriture pour le chemin d'accès au fichier de sortie
MkDir(CheckDrive +
"\CheckWritePermission")
RmDir(CheckDrive +
"\CheckWritePermission")
Else
MkDir(CheckDrive +
"CheckWritePermission")
RmDir(CheckDrive +
"CheckWritePermission")
End If
HasWritePermission = True
If Trim(txtScriptFilePath.Text) =
Trim(txtControlFilePath.Text) Then
MsgBox("Les informations de chemins d'accès du fichier de script et du fichier de contrôle sont identiques. Vérifiez s'il vous plaît !", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtControlFilePath.Focus()
GoTo OutOfHere
ElseIf Trim(txtScriptFilePath.Text) =
Trim(txtOutputPath.Text) Then
MsgBox("Les informations de chemins d'accès du fichier de script et du fichier de sortie sont identiques. Vérifiez s'il vous plaît !", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
ElseIf Trim(txtControlFilePath.Text) =
Trim(txtOutputPath.Text) Then
MsgBox("Les informations de chemins d'accès du fichier de contrôle et du fichier de sortie sont identiques. Vérifiez s'il vous plaît !", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
GoTo OutOfHere
End If
' Fin du code de validation des chemins d'accès aux fichiers de script, de contrôle et de sortie
Word1 = New Word.Application()
Word1.Application.Visible = True
Word1.Activate()
IsUnconventionalErrorFound = False
OpenStandardControlFileAndStoreErrWords(ControlFilePath, ScriptPath,
OutputPath)
' Fonction d'ouverture du fichier de contrôle et de stockage des mots erronés
Call cmdExit_Click(cmdExit, New
System.EventArgs())
OutOfHere:
If HasWritePermission = False Then
MsgBox("Information de chemin d'accès de sortie invalides. Vérifiez que vous disposez des autorisations d'écriture sur le chemin de sortie.", MsgBoxStyle.OKOnly + MsgBoxStyle.Exclamation, "Vérification de document")
txtOutputPath.Focus()
End If
End Sub
' Cette sous-routine ouvre le fichier de contrôle et stocke les mots erronés
Sub
OpenStandardControlFileAndStoreErrWords(ByRef ControlFilePath As Object, ByRef
ScriptPath As Object, ByRef OutputPath As Object)
Dim IsUnconventionalErrorFound As
Boolean
Dim res As Object
Dim LastRowOfInputFile As Integer
CounterErrorWordsAndSuggestions = 0
Word1.WordBasic.FileOpen(Name:=ControlFilePath, ConfirmConversions:=0,
ReadOnly:=0, AddToMru:=0, PasswordDoc:="", PasswordDot:="",
Revert:=0, WritePasswordDoc:="", WritePasswordDot:="")
LastRowOfInputFile = 0
Word1.WordBasic.EndOfDocument()
If
Word1.WordBasic.CmpBookmarks("\Sel", "\StartOfDoc") = 0
Then
Word1.WordBasic.MsgBox("Le fichier de contrôle standard '" + ControlFilePath + "' a été altéré et ne contient aucun texte.", "Vérification de document")
GoTo EnoughStoringFromControlFile
End If
ReadString =
Word1.WordBasic.Selection()
res = Trimmer(ReadString)
While Len(Trim(ReadString)) <= 1
Word1.WordBasic.CharLeft(1)
ReadString =
Word1.WordBasic.Selection()
res = Trimmer(ReadString)
If Len(ReadString) > 1 Then
If Word1.WordBasic.SelInfo(12) <>
-1 Then
IsUnconventionalErrorFound = True
Word1.WordBasic.MsgBox("Une entrée a été trouvée dans le tableau de '" + ControlFilePath +"'.", "Vérification de document")
GoTo EnoughStoringFromControlFile
End If
LastRowOfInputFile =
Word1.WordBasic.SelInfo(13)
GoTo LastRowStored
End If
If LastRowOfInputFile > 1150 Then
Word1.WordBasic.MsgBox("Le fichier de contrôle standard '" + ControlFilePath + "' contient plus de 1150 lignes.", "Vérification de document")
GoTo EnoughStoringFromControlFile
End If
If
Word1.WordBasic.CmpBookmarks("\Sel", "\StartOfDoc") = 0
Then
Word1.WordBasic.MsgBox("Le fichier de contrôle standard '" + ControlFilePath + "' a été altéré et ne contient aucun texte.", "Vérification de document")
GoTo EnoughStoringFromControlFile
End If
End While
LastRowStored:
Var(0) = Chr(45)
Var(1) = Chr(150)
Var(2) = Chr(151)
Var(3) = Chr(173)
Var(4) = Chr(40)
Var(5) = Chr(123)
Var(6) = Chr(91)
Var(7) = Chr(41)
Var(8) = Chr(125)
Var(9) = Chr(93)
Var(10) = " "
Var(11) = Chr(13)
Word1.WordBasic.StartOfDocument()
While Word1.WordBasic.SelInfo(12) <> -1
Word1.WordBasic.CharRight(1)
If Word1.WordBasic.CmpBookmarks("\Sel",
"\EndOfDoc") = 0 Then
IsUnconventionalErrorFound = True
Word1.WordBasic.MsgBox("Le fichier '" + ControlFilePath + "' ne contient aucun tableau.", "Vérification de document")
GoTo EnoughStoringFromControlFile
End If
End While
Word1.WordBasic.NextCell()
Word1.WordBasic.PrevCell()
While Word1.WordBasic.SelInfo(13) <=
LastRowOfInputFile
If Word1.WordBasic.SelInfo(16) <>
1 Then
Word1.WordBasic.MsgBox("La première entrée du fichier '" + ControlFilePath + "' n'est pas dans la première colonne.", "Vérification de document")
GoTo EnoughStoringFromControlFile
Else
ReadString =
Word1.WordBasic.Selection()
res = Trimmer(ReadString)
If Len(ReadString) > 0 Then
ErrorWordsAndSuggestions(CounterErrorWordsAndSuggestions, 0) =
ReadString
Word1.WordBasic.NextCell()
If Word1.WordBasic.SelInfo(16) <>
2 Then
Word1.WordBasic.MsgBox("La deuxième entrée du fichier '" + ControlFilePath + "' n'est pas dans la deuxième colonne.", "Vérification de document")
GoTo EnoughStoringFromControlFile
Else
ReadString =
Word1.WordBasic.Selection()
res = Trimmer(ReadString)
If Len(ReadString) > 0 Then
ErrorWordsAndSuggestions(CounterErrorWordsAndSuggestions, 1) =
ReadString
End If
If Word1.WordBasic.SelInfo(13) <>
LastRowOfInputFile Then
Word1.WordBasic.NextCell()
Else
GoTo OutOfStoring
End If
End If
CounterErrorWordsAndSuggestions =
CounterErrorWordsAndSuggestions + 1
Else
If Word1.WordBasic.SelInfo(13) <>
LastRowOfInputFile Then
Word1.WordBasic.NextCell()
Word1.WordBasic.NextCell()
Else
GoTo OutOfStoring
End If
End If
End If
End While
OutOfStoring:
OpenScriptAndStartProcessing(ScriptPath, OutputPath)
' Fonction d'ouverture du fichier de script et début du traitement
EnoughStoringFromControlFile:
End Sub
Function Trimmer(ByRef RString As
Object) As Object
ReadString = RString
While
(Microsoft.VisualBasic.Right(ReadString, 1) = Chr(7) Or
Microsoft.VisualBasic.Right(ReadString, 1) = Chr(11) Or
Microsoft.VisualBasic.Right(ReadString, 1) = Chr(13) Or
Microsoft.VisualBasic.Right(ReadString, 1) = Chr(9) Or
Microsoft.VisualBasic.Right(ReadString, 1) = Chr(32) Or
Microsoft.VisualBasic.Right(ReadString, 1) = Chr(160) Or
Microsoft.VisualBasic.Right(ReadString, 1) = Chr(10) Or Microsoft.VisualBasic.Right(ReadString,
1) = Chr(12) Or Microsoft.VisualBasic.Right(ReadString, 1) = (Chr(13) &
Chr(10)))
ReadString =
Microsoft.VisualBasic.Left(ReadString, Len(ReadString) - 1)
End While
While
(Microsoft.VisualBasic.Left(ReadString, 1) = Chr(7) Or
Microsoft.VisualBasic.Left(ReadString, 1) = Chr(11) Or
Microsoft.VisualBasic.Left(ReadString, 1) = Chr(13) Or
Microsoft.VisualBasic.Left(ReadString, 1) = Chr(9) Or
Microsoft.VisualBasic.Left(ReadString, 1) = Chr(32) Or Microsoft.VisualBasic.Left(ReadString,
1) = Chr(160) Or Microsoft.VisualBasic.Left(ReadString, 1) = Chr(10) Or
Microsoft.VisualBasic.Left(ReadString, 1) = (Chr(13) & Chr(10)) Or
Microsoft.VisualBasic.Left(ReadString, 1) = Chr(12))
ReadString =
Microsoft.VisualBasic.Right(ReadString, Len(ReadString) - 1)
End While
End Function
Sub OpenScriptAndStartProcessing(ByRef
ScriptPath As Object, ByRef OutputPath As Object)
Dim i As Integer
Dim DoNotCheck As Boolean
Dim res As Object
Dim IsBlank As Boolean
Dim ScriptWindow As String
Dim Flagstr As Object
Dim ErrFileWindow As String
NumberOfErrors = 0
PartialFound = False
Word1.WordBasic.FileNewDefault()
ErrFileWindow =
Word1.WordBasic.WindowName()
CreateErrlogTable((Flagstr))
Word1.WordBasic.Fileopen
(Name:=ScriptPath,
ConfirmConversions:=0, ReadOnly:=0,
AddToMru:=0, PasswordDoc:="", PasswordDot:="", Revert:=0,
WritePasswordDoc:="", WritePasswordDot:="")
Word1.WordBasic.ViewNormal()
ScriptWindow =
Word1.WordBasic.WindowName()
Word1.WordBasic.StartOfDocument()
Word1.WordBasic.ParaDown(1, 1)
If
Word1.WordBasic.CmpBookmarks("\Sel", "\StartOfDoc") = 0
Then
Word1.WordBasic.MsgBox("Fichier de script '" + ScriptPath + "' vierge.", "Vérification de document")
GoTo
EnoughOpenScriptAndStartProcessing
End If
IsBlank = True
While
Word1.WordBasic.CmpBookmarks("\Sel", "\EndOfDoc")
Word1.WordBasic.CharRight(1)
If Word1.WordBasic.SelInfo(12) = -1
Then
Word1.WordBasic.MsgBox("Fichier de script '" + ScriptPath + "' sous forme de tableau." + Chr(13) + Chr(13) + "Exécutez à nouveau l'outil en sélectionnant les options adéquates.", "Vérification de document")
GoTo
EnoughOpenScriptAndStartProcessing
End If
Word1.WordBasic.ParaDown(1, 1)
ReadString =
Word1.WordBasic.Selection()
res = Trimmer(ReadString)
If Len(ReadString) > 0 Then
IsBlank = False
DoNotCheck = False
CheckForErrWordsPresent(ReadString,
ScriptWindow, ErrFileWindow)
' Fonction de recherche des mots erronés dans la sélection actuelle
' du fichier de script
End If
End While
If ErrorWordsFoundCtr > 0 Then
' Boucle vers le début du document et modification de la couleur des mots erronés dans le fichier de script
Word1.WordBasic.StartOfDocument()
For i = 0 To ErrorWordsFoundCtr - 1
Word1.WordBasic.EditFind(Find:=ErrorWordsFound(i),
WholeWord:=1)
Word1.WordBasic.HighlightColor(3)
Word1.WordBasic.CharRight(1)
Next
Word1.WordBasic.Filesave()
End If
If IsBlank = True Then
Word1.WordBasic.MsgBox("Fichier de script '" + ScriptPath + "' vierge.", "Vérification de document")
GoTo
EnoughOpenScriptAndStartProcessing
End If
' Fonction appelée pour activer le fichier de sortie
ActivateWindow((ErrFileWindow))
If NumberOfErrors = 0 Then
Word1.WordBasic.NextCell()
Word1.WordBasic.ParaDown(3, 1)
Word1.WordBasic.TableMergeCells()
Word1.WordBasic.CharLeft(1)
Word1.WordBasic.Insert("Aucune erreur identifiée.")
Else
Word1.WordBasic.EndOfDocument()
Word1.WordBasic.InsertPara()
' Mise en journal du nombre total de mots erronés identifiés dans le fichier de script
Word1.WordBasic.Insert("Nombre de mots erronés identifiés : " & Str(NumberOfErrors))
If NumberOfErrors >= 1000 Then
Word1.WordBasic.Insert("L'outil est incapable de mettre en bleu tous les mots erronés car leur nombre est trop élevé.")
End If
End If
Word1.WordBasic.FileSaveAs(Name:=OutputPath, Format:=0, LockAnnot:=0,
Password:="", AddToMru:=1, WritePassword:="",
RecommendReadOnly:=0, EmbedFonts:=0, NativePictureFormat:=0, FormsData:=0,
SaveAsAOCELetter:=0)
Word1.WordBasic.FileClose(1)
Word1.WordBasic.Fileopen(Name:=OutputPath, ConfirmConversions:=0,
ReadOnly:=0, AddToMru:=0, PasswordDoc:="", PasswordDot:="",
Revert:=0, WritePasswordDoc:="", WritePasswordDot:="")
EnoughOpenScriptAndStartProcessing:
End Sub
Sub CheckForErrWordsPresent(ByRef
ReadString As Object, ByRef ScriptWindow As Object, ByRef ErrFileWindow As
Object)
Dim RightSide As Integer
Dim LeftSide As Integer
Dim ChkOfRightPlus As String
Dim CtrRight As Integer
Dim ChkOfRight As String
Dim VarCtr As Integer
Dim ChkOfLeft As String
Dim LineNo As Integer
Dim PageNo As Integer
Dim ErrorWordFound As Integer
Dim ChkCtr As Integer
Dim LeftChkErrReported As Integer
Dim RightChkErrReported As Integer
Dim RightPlusErrReported As Integer
Dim RightPlusChecked As Integer
Dim IsRightAnyOfTheVar As Integer
IsRightAnyOfTheVar = 0
RightPlusChecked = 0
RightPlusErrReported = 0
RightChkErrReported = 0
LeftChkErrReported = 0
For ChkCtr = 0 To
CounterErrorWordsAndSuggestions
ErrorWordFound = 0
If
UCase(ErrorWordsAndSuggestions(ChkCtr, 0)) = "(S)" Then
ErrorWordFound =
InStr(UCase(ReadString), UCase(ErrorWordsAndSuggestions(ChkCtr, 0)))
If ErrorWordFound <> 0 Then
PageNo = Word1.WordBasic.SelInfo(1)
LineNo = Word1.WordBasic.SelInfo(10)
LogErr(ScriptWindow, ErrFileWindow,
ChkCtr, PageNo, LineNo)
' Fonction de mise en journal de l'erreur dans le fichier de sortie
If LoggedWordsctr < 20 Then
LoggedWords(LoggedWordsctr) = ErrorWordsAndSuggestions(ChkCtr, 0)
LoggedWordsctr = LoggedWordsctr + 1
End If
End If
Else
If LeftChkErrReported = 0 Then
ErrorWordFound = 0
ChkOfLeft =
UCase(Microsoft.VisualBasic.Left(ReadString,
Len(ErrorWordsAndSuggestions(ChkCtr, 0))))
If UCase(ChkOfLeft) =
UCase(ErrorWordsAndSuggestions(ChkCtr, 0)) Then
For VarCtr = 0 To 11
If Mid(ReadString, Len(ChkOfLeft) + 1,
1) = Var(VarCtr) Then
ErrorWordFound = 1
Exit For
End If
Next
End If
If ErrorWordFound <> 0 Then
LeftChkErrReported = 1
PageNo = Word1.WordBasic.SelInfo(1)
LineNo = Word1.WordBasic.SelInfo(10)
' Fonction de mise en journal des erreurs dans le fichier de sortie
LogErr(ScriptWindow, ErrFileWindow,
ChkCtr, PageNo, LineNo)
If LoggedWordsctr < 20 Then
LoggedWords(LoggedWordsctr) = ErrorWordsAndSuggestions(ChkCtr,
0)
LoggedWordsctr = LoggedWordsctr + 1
End If
End If
End If
If RightChkErrReported = 0 Then
ErrorWordFound = 0
ChkOfRight =
UCase(Microsoft.VisualBasic.Right(ReadString,
Len(ErrorWordsAndSuggestions(ChkCtr, 0))))
If UCase(ChkOfRight) =
UCase(ErrorWordsAndSuggestions(ChkCtr, 0)) Then
For VarCtr = 0 To 11
If Mid(ReadString, Len(ReadString) -
Len(ChkOfRight), 1) = Var(VarCtr) Then
ErrorWordFound = 1
Exit For
End If
Next
End If
If ErrorWordFound <> 0 Then
RightChkErrReported = 1
PageNo = Word1.WordBasic.SelInfo(1)
LineNo = Word1.WordBasic.SelInfo(10)
LogErr(ScriptWindow, ErrFileWindow,
ChkCtr, PageNo, LineNo)
' Fonction de mise en journal de l'erreur dans le fichier de sortie
If LoggedWordsctr < 20 Then
LoggedWords(LoggedWordsctr) = ErrorWordsAndSuggestions(ChkCtr, 0)
LoggedWordsctr = LoggedWordsctr + 1
End If
End If
End If
If RightPlusChecked = 0 Then
For CtrRight = 0 To 11
If
Microsoft.VisualBasic.Right(ReadString, 1) = Var(CtrRight) Then
IsRightAnyOfTheVar = 1
Exit For
End If
Next
RightPlusChecked = 1
End If
If RightPlusErrReported = 0 Then
ErrorWordFound = 0
If IsRightAnyOfTheVar = 0 Then
ChkOfRightPlus =
UCase(Microsoft.VisualBasic.Right(ReadString,
Len(ErrorWordsAndSuggestions(ChkCtr, 0)) + 1))
If
UCase(Microsoft.VisualBasic.Left(ChkOfRightPlus,
Len(ErrorWordsAndSuggestions(ChkCtr, 0)))) =
UCase(ErrorWordsAndSuggestions(ChkCtr, 0)) Then
For VarCtr = 0 To 11
If Mid(ReadString, Len(ReadString) -
Len(ChkOfRightPlus), 1) = Var(VarCtr) Then
ErrorWordFound = 1
Exit For
End If
Next
End If
If ErrorWordFound <> 0 Then
RightPlusErrReported = 1
PageNo = Word1.WordBasic.SelInfo(1)
LineNo = Word1.WordBasic.SelInfo(10)
LogErr(ScriptWindow, ErrFileWindow,
ChkCtr, PageNo, LineNo)
' Fonction de mise en journal de l'erreur dans le fichier de sortie
If LoggedWordsctr < 20 Then
LoggedWords(LoggedWordsctr) = ErrorWordsAndSuggestions(ChkCtr, 0)
LoggedWordsctr = LoggedWordsctr + 1
End If
End If
End If
End If
For LeftSide = 0 To 11
For RightSide = 0 To 11
ErrorWordFound =
InStr(UCase(ReadString), Var(LeftSide) &
UCase(ErrorWordsAndSuggestions(ChkCtr, 0)) & Var(RightSide))
If ErrorWordFound <> 0 Then
PageNo = Word1.WordBasic.SelInfo(1)
LineNo = Word1.WordBasic.SelInfo(10)
LogErr(ScriptWindow, ErrFileWindow,
ChkCtr, PageNo, LineNo)
' Fonction de mise en journal de l'erreur dans le fichier de sortie
If LoggedWordsctr < 20 Then
LoggedWords(LoggedWordsctr) = ErrorWordsAndSuggestions(ChkCtr, 0)
LoggedWordsctr = LoggedWordsctr + 1
End If
End If
Next
Next
End If
Next
EOFCheckForErrWordsPresent:
End Sub
Sub LogErr(ByRef ScriptWindow As
Object, ByRef ErrFileWindow As Object, ByRef ChkCtr As Object, ByRef PageNo As
Object, ByRef LineNo As Object)
ActivateWindow((ErrFileWindow))
' Pour activer la fenêtre du fichier de sortie
NumberOfErrors = NumberOfErrors + 1
Word1.WordBasic.Insert(ErrorWordsAndSuggestions(ChkCtr,
0))
If ErrorWordsFoundCtr < 1000 Then
ErrorWordsFound(ErrorWordsFoundCtr) =
ErrorWordsAndSuggestions(ChkCtr, 0)
ErrorWordsFoundCtr =
ErrorWordsFoundCtr + 1
End If
Word1.WordBasic.NextCell()
Word1.WordBasic.Insert("Page" & Str(PageNo) & "
Ligne " & Str(LineNo))
Word1.WordBasic.NextCell()
Word1.WordBasic.Insert(ErrorWordsAndSuggestions(ChkCtr, 1))
Word1.WordBasic.NextCell()
ActivateWindow((ScriptWindow))
' Pour activer la fenêtre du fichier de script
End Sub
Sub CreateErrlogTable(ByRef Flagstr As
Object)
Word1.WordBasic.TableInsertTable(ConvertFrom:="",
NumColumns:="3", NumRows:="2",
InitialColWidth:="Auto", Format:="0",
Apply:="167")
Word1.WordBasic.FormatBordersAndShading(ApplyTo:=3, Shadow:=0,
TopBorder:=2, LeftBorder:=2, BottomBorder:=2, RightBorder:=2, HorizBorder:=1,
VertBorder:=1, TopColor:=0, LeftColor:=0, BottomColor:=0, RightColor:=0,
HorizColor:=0, VertColor:=0, FromText:="0 pt", Shading:=0,
Foreground:=0, Background:=0, TAB:="0", FineShading:=-1)
Word1.WordBasic.ParaDown(6, 1)
Word1.WordBasic.CenterPara()
Word1.WordBasic.CharLeft(1)
Word1.WordBasic.ParaDown(4, 1)
Word1.WordBasic.Bold()
Word1.WordBasic.CharLeft(1)
Word1.WordBasic.Insert("Mots
incorrects")
Word1.WordBasic.TableColumnWidth(ColumnWidth:="1.5" &
Chr(34), SpaceBetweenCols:="0.15" & Chr(34),
RulerStyle:="0")
Word1.WordBasic.NextCell()
Word1.WordBasic.Insert("Pg#
Ln#.")
Word1.WordBasic.TableColumnWidth(ColumnWidth:="1.2" &
Chr(34), SpaceBetweenCols:="0.15" & Chr(34),
RulerStyle:="0")
Word1.WordBasic.NextCell()
Word1.WordBasic.Insert("Suggestion.")
Word1.WordBasic.TableColumnWidth(ColumnWidth:="3.3" &
Chr(34), SpaceBetweenCols:="0.15" & Chr(34),
RulerStyle:="0")
Word1.WordBasic.LineDown(1)
Word1.WordBasic.ParaDown(1, 1)
Word1.WordBasic.LeftPara()
Word1.WordBasic.LineUp(1)
Word1.WordBasic.NextCell()
End Sub
' Pour que cette sous-routine fonctionne, la fenêtre doit déjà être ouverte.
' Cela va juste l'amener au premier plan.
Private Sub ActivateWindow(ByRef
WindowToOpen As Object)
Dim numwin As Integer
Dim i As Integer
Dim leave_Renamed As Integer
Dim winname As String
numwin =
Word1.WordBasic.CountWindows()
If numwin <> 0 Then
i = 1
While i <= numwin And leave_Renamed
<> 1
winname =
Word1.WordBasic.WindowName(i)
If InStr(winname, WindowToOpen) Then
leave_Renamed = 1
If leave_Renamed <> 1 Then i = i
+ 1
End While
End If
If InStr(winname, WindowToOpen) Then
Word1.WordBasic.WindowList(i)
Else
Word1.WordBasic.MsgBox("Aucune
fenêtre ne contient ", WindowToOpen)
End If
End Sub
<?xml version="1.0"?>
<Inventaire>
<Produit>Carte réseau</Produit>
<Quantité>100</Quantité>
<Produit>Carte mère</Produit>
<Quantité>10</Quantité>
</Inventaire>