| | auteur : SilkyRoad |
Cet exemple montre comment gérer l'évènement Clic sur toutes les images contenues dans un WebBrowser, en passant par un module
de classe.
La procédure permet de renvoyer des informations sur chaque image:
*URL
*Nom
*Dates de création et de modification
*Type
*Dimensions
*Taille
La procédure nécessite d'activer la référence "Microsoft HTML Object Library".
| Vba |
Option Explicit
Public Collect As Collection
|
| Vba |
Option Explicit
Dim maPageHtml As HTMLDocument
Private Sub UserForm_Initialize()
WebBrowser1.Navigate "http://www.developpez.com"
End Sub
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
Dim Cl As Classe1
Dim i As Integer
Dim imgHtml As HTMLImg
Set Collect = New Collection
Set maPageHtml = WebBrowser1.Document
For i = 0 To maPageHtml.images.Length - 1
Set imgHtml = maPageHtml.images.Item(i)
Set Cl = New Classe1
Set Cl.Img = imgHtml
Collect.Add Cl
Next i
End Sub
Private Sub WebBrowser1_BeforeNavigate2(ByVal pDisp As Object, _
URL As Variant, Flags As Variant, TargetFrameName As Variant, _
PostData As Variant, Headers As Variant, Cancel As Boolean)
Set Collect = Nothing
Set maPageHtml = Nothing
End Sub
Private Sub WebBrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)
Cancel = True
End Sub
|
| Vba |
Option Explicit
Public WithEvents Img As MSHTML.HTMLImg
Private Function Img_onclick() As Boolean
MsgBox "Adresse (URL): " & Img.src & vbCrLf & vbCrLf & _
"Nom: " & Img.nameProp & vbCrLf & _
"Créé le: " & Img.fileCreatedDate & vbCrLf & _
"Modifié: " & Img.fileModifiedDate & vbCrLf & _
"Type: " & Img.mimeType & vbCrLf & _
"Dimensions: " & Img.Width & " x " & Img.Height & " pixels" & vbCrLf & _
"Taille: " & Img.fileSize & " octets."
End Function
|
|
| | auteur : SilkyRoad | | Vba |
Private Sub UserForm_Initialize()
Dim AjoutFonction As String
Dim Fichier As String
Fichier = "http://vb.developpez.com/cours/images/cours_vb.gif"
WebBrowser1.Navigate "about:<html><body></body></html>"
AjoutFonction = "<html><body><B>Bienvenue sur cette page.</B>" & vbCrLf
AjoutFonction = AjoutFonction & "<BODY background='" & Fichier & "'</BODY>"
AjoutFonction = AjoutFonction & "<FORM>" & _
"<INPUT type=button name='Bouton1' value='Cliquez ici.' " & _
"onClick=(alert('Bonjour!'))></FORM>"
AjoutFonction = _
AjoutFonction & "<script language=""javascript"">" & vbCrLf
AjoutFonction = AjoutFonction & "function maFonction(){" & vbCrLf
AjoutFonction = AjoutFonction & "alert(""Coucou"");" & vbCrLf
AjoutFonction = AjoutFonction & "}" & vbCrLf
AjoutFonction = AjoutFonction & "</script></body></html>"
WebBrowser1.Document.writeln AjoutFonction
End Sub
|
Si vous souhaitez ajouter un bouton qui déclenche la fonction JavaScript par macro, utilisez:
| Vba |
Private Sub CommandButton1_Click()
Dim s As String
Dim maPageHtml As HTMLDocument
Set maPageHtml = WebBrowser1.Document
maPageHtml.parentWindow.execScript "maFonction();", "javascript"
End Sub
|
Utilisez la synthaxe suivante si la fonction JavaScript contient des arguments:
| Vba |
Private Sub CommandButton1_Click()
Dim s As String
Dim maPageHtml As MSHTML.HTMLDocument
Set maPageHtml = WebBrowser1.Document
maPageHtml.parentWindow.execScript _
"ChangeBackGround('http://NomDuSite.com/NouvelleImage.gif');", "javascript"
End Sub
|
|
| | auteur : SilkyRoad |
Un exemple en utilisant un WebBrowser ("Navigateur Web Microsoft" dans la liste des contrôles supplémentaires).
| Vba |
Option Explicit
Private Sub UserForm_Initialize()
ParametresHtml "Le forum DVP: Un texte qui défile.", "#000099"
End Sub
Private Sub ParametresHtml(LeTexte As String, LaCouleur As String)
Me.WebBrowser1.Navigate _
"about:<html><body BGCOLOR ='#CCCCCC' scroll='no'><font color= " _
& LaCouleur & " size='5' face='Arial'>" & _
"<marquee scrollAmount=3>" & LeTexte & "</marquee></font></body></html>"
End Sub
|
|
| | auteur : SilkyRoad |
Le contrôle DataGrid permet d'afficher le résultat de requêtes effectuées dans des bases de données.
L'ocx MSDATGRD.ocx doit être installé sur votre poste pour que vous puissiez l'utiliser.
Vous pouvez utiliser cet objet pour afficher le contenu de feuilles de calcul Excel. Dans ce cas il est préférable
(mais pas obligatoire) que celles-ci soient structurées comme une base de données : La première ligne servant à indiquer
le nom des champs, à partir de la première.
Ce premier exemple effectue une requête dans la Feuil1 d'un classeur fermé et transfert le résultat dans le DataGrid.
| Vba |
Private Sub CommandButton1_Click()
Dim Cn As ADODB.Connection
Dim Rs As ADODB.Recordset
Set Cn = New ADODB.Connection
With Cn
.Provider = "MSDASQL"
.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & _
"DBQ=C:\monClasseurBase.xls; ReadOnly=False;"
.Open
End With
Set Rs = New ADODB.Recordset
Rs.Open "SELECT * FROM [Feuil1$]", Cn, adOpenKeyset, adLockOptimistic
Set DataGrid1.DataSource = Rs
End Sub
|
Cette deuxième procédure effectue la requête dans un classeur ouvert (dans la Feuil1 du classeur contenant la macro).
Remarque : Le classeur doit être préalablement sauvegardé sur le disque dur.
| Vba |
Private Sub CommandButton1_Click()
Dim Cn As ADODB.Connection
Dim Rs As ADODB.Recordset
Set Cn = New ADODB.Connection
With Cn
.Provider = "MSDASQL"
.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & _
"DBQ=" & ThisWorkbook.FullName & "; ReadOnly=False;"
.Open
End With
Set Rs = New ADODB.Recordset
Rs.Open "SELECT * FROM [Feuil1$]", Cn, adOpenKeyset, adLockOptimistic
Set DataGrid1.DataSource = Rs
End Sub
|
|
lien : Consultez le tutoriel pour lire et écrire dans des classeurs fermés
|
| | auteur : SilkyRoad |
Lorsque vous fermez un UserForm, il est parfois utile de sauvegarder les paramètres
d'un contrôle (par exemple le dernier contenu d'un TextBox) afin de réutiliser ces informations
ultérieurement, lors de la prochaine ouverture de la boîte de dialogue.
Le moyen le plus simple consiste à enregistrer ces données dans les cellules d'une feuille masquée.
Il est aussi possible d'utiliser l'instruction SaveSetting pour sauvegarder les paramètres
des contrôles (contenu, position ...) en créant une entrée dans la base de registres et ensuite
d'utiliser GetSetting pour lire la valeur de la clé dans la base de registres.
Dans cet exemple, la procédure sauvegarde automatiquement le contenu des TextBox1 et 2 lors de
la fermeture du UserForm.
Fermez votre classeur puis ré-ouvrez le. Les dernières données des TextBox apparaissent.
| Vba |
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
SaveSetting "Mes parametres", "TextBox1", "Valeur TextBox1", TextBox1.Value
SaveSetting "Mes parametres", "Textbox2", "Valeur TextBox2", TextBox2.Value
End Sub
|
| Vba |
Private Sub UserForm_Initialize()
TextBox1.Value = GetSetting("Mes parametres", "TextBox1", "Valeur TextBox1")
TextBox2.Value = GetSetting("Mes parametres", "TextBox2", "Valeur TextBox2")
End Sub
|
Pour supprimer une entrée, utilisez:
| Vba |
DeleteSetting "Mes parametres", "TextBox2"
|
|
| | auteur : SilkyRoad |
Cet exemple ajoute 5 Textbox dans un Frame nommé Frame1:
| Vba |
Dim i As Integer
Dim TxtB As Control
For i = 1 To 5
Set TxtB = Frame1.Add("forms.Textbox.1")
With TxtB
.Left = 5
.Top = 10 + ((i - 1) * 30)
.Width = 75
.Height = 20
End With
Next i
|
|
| | auteur : SilkyRoad |
Cette syntaxe fonctionne aussi pour les ListBox.
| Vba |
Private Sub UserForm_Initialize()
Dim Cell As Range
Dim Tableau()
Dim TempTab As Variant
Dim i As Integer, j As Integer
Dim boolVerif As Boolean
ReDim Tableau(1 To 1)
Tableau(1) = Cells(1, 1)
For Each Cell In Worksheets("Feuil1").Range("A1:A" & _
Worksheets("Feuil1").Range("A65536").End(xlUp).Row)
boolVerif = False
For i = 1 To UBound(Tableau)
If Tableau(i) = Cell Then
boolVerif = True
Exit For
End If
Next i
If boolVerif = False Then
ReDim Preserve Tableau(1 To UBound(Tableau) + 1)
Tableau(UBound(Tableau)) = Cell
End If
For i = 1 To UBound(Tableau)
For j = 1 To UBound(Tableau)
If Tableau(i) < Tableau(j) Then
TempTab = Tableau(i)
Tableau(i) = Tableau(j)
Tableau(j) = TempTab
End If
Next j
Next i
Next Cell
ComboBox1.List = Tableau
End Sub
|
|
| | auteur : Ouskelnor | | Vba |
Private Sub UserForm_Initialize()
Dim Tableau As Variant
Tableau = Range("A1:Z1").Value
ComboBox1.Column() = Tableau
End Sub
|
|
| | auteur : SilkyRoad |
Cet exemple permet de forcer un format de type 00/00:0000
| Vba |
Private Sub TextBox1_Change()
Dim strFormat As String
Dim x As Integer
x = Len(TextBox1)
strFormat = "##/##:####"
strFormat = Left(strFormat, x)
If Not TextBox1 Like strFormat Then _
TextBox1 = Left(TextBox1, x - 1)
End Sub
|
|
| | auteur : SilkyRoad |
ListBox1.ListIndex = -1 est utilisé pour désélectionner une ligne de la ListBox ou pour vérifier si une ligne est sélectionnée.
ListBox1.ListIndex renvoie 0 si la 1ere ligne est sélectionnée.
ListBox1.ListIndex renvoie 1 si la deuxieme ligne est sélectionnée.
ListBox1.ListIndex renvoie 2 si la troisième ligne est sélectionnée.
...etc...
ListBox1.ListIndex renvoie -1 si aucune ligne n'est sélectionnée.
Cette option peut par exemple être utilisée pour éviter les doublons lors de l'alimentation d'un ComboBox:
Cette procédure boucle sur les cellules de la colonne A.
Chaque donnée est placée dans la zone d'édition du contrôle.
Si la donnée n'existe pas encore dans la liste, la valeur -1 est renvoyée.
Dans ce cas on peut alimenter le ComboBox en utilisant la méthode AddItem.
| Vba |
Private Sub UserForm_Initialize()
Dim j As Integer
For j = 1 To Range("A65536").End(xlUp).Row
ComboBox1 = Range("A" & j)
If ComboBox1.ListIndex = -1 Then ComboBox1.AddItem Range("A" & j)
Next j
End Sub
|
|
| | auteur : SilkyRoad |
Il est possible d'indiquer les contrôles dans une fonction Array, puis de boucler sur les éléments
du tableau:
| Vba |
Private Sub CommandButton1_Click()
Dim Ctrl As Variant
Dim j As Byte
For Each Ctrl In Array(TextBox1, TextBox3, TextBox5)
j = j + 1
Ctrl.Object.Value = "Champ" & j
Next
End Sub
|
|
| | auteur : SilkyRoad |
Les données sont dans les colonnes A à D, d'un onglet nommé "Base".
La procédure effectue un remplissage conditionnel des ComboBox en fonction de ce qui est sélectionné dans le contrôle précédent:
La sélection du ComboBox1 (données colonne A) définit le contenu du ComboBox2 (données colonne B),
la sélection dans ComboBox2 définit le contenu du ComboBox3 (données colonne C) …etc...
| Vba |
Option Explicit
Dim Ws As Worksheet
Dim NbLignes As Integer
Private Sub UserForm_Initialize()
Set Ws = Worksheets("Base")
NbLignes = Ws.Range("A65536").End(xlUp).Row
Alim_Combo 1
End Sub
Private Sub ComboBox1_Change()
Alim_Combo 2, ComboBox1.Value
End Sub
Private Sub ComboBox2_Change()
Alim_Combo 3, ComboBox2.Value
End Sub
Private Sub ComboBox3_Change()
Alim_Combo 4, ComboBox3.Value
End Sub
Private Sub Alim_Combo(CbxIndex As Integer, Optional Cible As Variant)
Dim j As Integer
Dim Obj As Control
Set Obj = Me.Controls("ComboBox" & CbxIndex)
Obj.Clear
If CbxIndex = 1 Then
For j = 2 To NbLignes
Obj = Ws.Range("A" & j)
If Obj.ListIndex = -1 Then Obj.AddItem Ws.Range("A" & j)
Next j
Else
For j = 2 To NbLignes
If Ws.Range("A" & j).Offset(0, CbxIndex - 2) = Cible Then
Obj = Ws.Range("A" & j).Offset(0, CbxIndex - 1)
If Obj.ListIndex = -1 Then Obj.AddItem Ws.Range("A" & j).Offset(0, CbxIndex - 1)
End If
Next j
End If
Obj.ListIndex = -1
End Sub
|
|
| | auteur : SilkyRoad |
La largeur de la ListBox et la largeur de chaque colonne s'ajustent en fonction du contenu des cellules à afficher dans l'UserForm.
| Vba |
Private Sub UserForm_Initialize()
Dim Plage As Range
Dim Largeur As String
Dim i As Integer
Set Plage = Range("A1:C10")
Plage.Columns.AutoFit
With ListBox1
.Width = Plage.Width + 20
.ColumnCount = Plage.Columns.Count
.List() = Plage.Value
For i = 1 To .ColumnCount
Largeur = Largeur & Plage.Columns(i).Width & ";"
Next
.ColumnWidths = Largeur
End With
End Sub
|
|
| | auteur : SilkyRoad |
Normalement, il n'y a que la propriété RowSource qui permet d'afficher des étiquette mais il est possible de tricher
en plaçant des Labels au dessus de chaque colonne du contrôle ListBox.
Cet exemple redimensionne et repositionne la listbox afin d'ajouter des labels au dessus de chaque colonne.
Vous pourrez bien entendu adapter la procédure en fonction de votre projet.
| Vba |
Option Explicit
Option Base 1
Private Sub UserForm_Initialize()
Dim Plage As Range
Dim Tableau As Variant
Dim i As Integer
Dim Lbl As Control
Set Plage = Range("A1:C10")
Tableau = ScindePlage(Plage)
With ListBox1
.ColumnCount = UBound(Tableau, 2)
.Top = 20
.Width = 92 * UBound(Tableau, 2)
DoEvents
.List() = Tableau
End With
For i = 1 To UBound(Tableau, 2)
Set Lbl = Me.Controls.Add("Forms.Label.1")
With Lbl
.Left = ListBox1.Left + 7 + ((i - 1) * 92)
.Top = ListBox1.Top - 10
.Width = 92
.Height = 10
.Caption = Plage.Cells(1, i)
End With
Next i
End Sub
Function ScindePlage(Cible As Range) As Variant
Dim Pl As Range
Set Pl = Cible.Offset(1, 0).Resize(Cible.Rows.Count - 1)
ScindePlage = Pl.Value
End Function
|
|
| | auteur : SilkyRoad |
Vous utilisez habituellement la syntaxe NomObject.Font.Name ="Arial" pour définir une police classique.
Ajoutez Font.Charset pour valider les polices type Symbole (Wingdings, Webdings ...).
| Vba |
NomObject.Font.Name ="Wingdings"
NomObject.Font.Charset = 2
|
|
| | auteur : SilkyRoad | | Vba |
Option Explicit
Option Base 1
Private Declare Function OpenClipboard& Lib "user32" (ByVal hwnd As Long)
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData& Lib "user32" (ByVal wFormat&, ByVal hMem&)
Private Declare Function CloseClipboard& Lib "user32" ()
Private Declare Function DestroyIcon& Lib "user32" (ByVal hIcon&)
Private Const ImgTemp1 As String = "C:\ImgTemp1.jpg"
Private Const ImgTemp2 As String = "C:\ImgTemp2.jpg"
Private Sub CommandButton1_Click()
Dim iPic As StdPicture
Dim hCopy&
Dim Img As ImageFile
Dim Tableau1 As Variant, Tableau2 As Variant
Set iPic = Me.Image1.Picture
OpenClipboard 0&: EmptyClipboard
hCopy = SetClipboardData(2, iPic.Handle)
CloseClipboard
If hCopy Then SavePicture iPic, ImgTemp1
DestroyIcon iPic.Handle
Set iPic = Me.Image2.Picture
OpenClipboard 0&: EmptyClipboard
hCopy = SetClipboardData(2, iPic.Handle)
CloseClipboard
If hCopy Then SavePicture iPic, ImgTemp2
DestroyIcon iPic.Handle
Set Img = New ImageFile
Img.LoadFile "C:\ImgTemp1.jpg"
Tableau1 = Img.FileData.BinaryData
Set Img = Nothing
Set Img = New ImageFile
Img.LoadFile "C:\ImgTemp2.jpg"
Tableau2 = Img.FileData.BinaryData
Set Img = Nothing
MsgBox "Identiques: " & TableauxIdentiques(Tableau1, Tableau2)
Kill ImgTemp1
Kill ImgTemp2
End Sub
Function TableauxIdentiques(Tab1, Tab2) As Boolean
Dim i As Double
If UBound(Tab1) <> UBound(Tab2) Then
TableauxIdentiques = False
Exit Function
Else
For i = 1 To UBound(Tab1)
If Tab1(i) <> Tab2(i) Then
TableauxIdentiques = False
Exit Function
End If
Next i
End If
TableauxIdentiques = True
End Function
|
|
Consultez les autres F.A.Q's
Les sources présentés sur cette pages sont libre de droits,
et vous pouvez les utiliser à votre convenance. Par contre cette page de présentation de ces sources constitue une oeuvre intellectuelle protégée par les droits d'auteurs.
Copyright ©2008
Developpez LLC. Tout droits réservés Developpez LLC.
Aucune reproduction, même partielle, ne peut être faite de ce site et de
l'ensemble de son contenu : textes, documents et images sans l'autorisation
expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à 3 ans
de prison et jusqu'à 300 000 E de dommages et intérets.
Cette page est déposée à la SACD.
|
