FAQ Visual Basic
FAQ Visual Basic Consultez toutes les FAQ
Nombre d'auteurs : 50, nombre de questions : 300, dernière mise à jour : 15 juin 2021
Sommaire→Interface→Contrôles- Comment choisir entre une MSFlexgrid et une Datagrid ?
- Comment permettre à l'utilisateur de taper du texte dans une flexgrid ?
- Comment avoir une case à cocher dans une flexgrid (2 méthodes)?
- Comment n'autoriser la sélection que d'une seule ligne dans une MSFlexgrid ?
- Comment exporter le contenu d'une msflexgrid dans un fichier ?
- Comment modifier la largeur des colonnes d'une MSFlexgrid en fonction de la longueur du texte ?
- Comment adapter les dimensions d'une image à celle d'un PictureBox ?
- Comment contrôler les caractères qui peuvent être saisis dans un textbox ?
- Comment annuler la dernière modification du contenu d'un textbox (undo) ?
- Comment récupérer une par une les lignes d'un textbox multilignes ?
- Comment afficher son propre menu popup dans un textbox ?
- Comment utilise-t-on le contrôle TabStrip ?
- Comment se connecter à une base Access 2000 avec un contrôle Data ?
- Comment imprimer le contenu d'un RichTextBox ?
- Comment concaténer le contenu de deux contrôles RTF ?
- Comment mettre plusieurs colonnes dans une ComboBox ?
- Comment dérouler une ComboBox ?
- Comment modifier la largeur de la zone de déroulement d'une ComboBox ?
- Comment modifier la hauteur de la zone de déroulement d'une ComboBox ?
- Comment ajouter une fonctionnalité de correspondance à une ComboBox ?
- Comment ajouter un ascenseur horizontal à une ListBox ?
- Comment aligner des entrées multicolonnes dans une ListBox ?
- Comment lier une DataCombo ou une DataList à un champ d'une base de données ?
- Comment tester l'existence d'un noeud dans un contrôle TreeView ?
- Comment définir la couleur d'arrière-plan d'un TreeView ?
- Comment donner un effet d'ombre à un contrôle ?
- Comment savoir s'il y a une image dans un contrôle ?
- Comment savoir si une propriété existe pour un contrôle ?
- Comment dérouler un bouton DropDown dans une ToolBar en cliquant sur l'ensemble du bouton ?
- Comment donner le style de Windows XP à mes contrôles VB6 ?
- Comment faire évoluer un ProgressBar en fonction d'un FileCopy?
- Utilise le contrôle Common Dialog pour récupérer le chemin d'un fichier
- Comment sélectionner plusieurs extensions dans le filtre d'un CommonDialog ?
- Comment copier une image dans un RichTextBox ?
- Comment faire de l'auto complétion avec une Combobox standard ?
La datagrid est réservée à l'utilisation d'une grille liée à une source de données. Vous pouvez modifier le format d'affichage de chaque colonne. L'utilisateur peut saisir les valeurs au clavier, ajouter et supprimer des lignes. Toutes ces modifications sont prises en compte dans la base de données, avec très peu voire aucune programmation. Cependant, les choses se compliquent très vite dès que vous voulez modifier des données portant sur plusieurs tables de la base.
Quant à la MSFlexgrid, son inconvénient majeur est la non prise en charge de saisie de données. Il reste cependant plusieurs façons de combler ce manque avec quelques lignes de code. Elle peut être liée à une source de données comme la datagrid, mais le format d'affichage n'est pas modifiable. Vous pouvez aussi remplir la grille par programmation, ligne par ligne, ce qui vous permet d'afficher exactement ce que vous voulez; par contre cela peut être moins rapide à l'exécution sur un très grand nombre de lignes. A cela, il faut ajouter les possibilités de modifier la police, la couleur du texte, la couleur de fond d'une cellule, d'afficher une image dans une cellule, et de fusionner plusieurs cellules adjacentes qui contiennent la même valeur. La MSFlexgrid est donc à mon avis préférable dans la plupart des cas.
Ce programme ajoute dans la cellule courante les caractères au fur et à mesure qu'ils sont tapés. Une autre manière de faire consiste à placer un textbox qui recouvre la cellule courante, et de transférer le texte du textbox dans la cellule chaque fois que l'on quitte le textbox (évènement lostfocus).
Dim strTexte
strTexte = MSFlexGrid1.Text
If KeyAscii = 8 Then
'Touche d'effacement
If Len(strTexte) > 0 Then MSFlexGrid1.Text = Left(strTexte, Len(strTexte) - 1)
ElseIf KeyAscii <> 13 Then
MSFlexGrid1.Text = strTexte & Chr(KeyAscii)
End IfLa méthode la plus simple consiste à utiliser des images représentant chacune un des états possibles de la case à cocher.
Ici nous aurons deux images: une pour représenter une case non cochée et une autre pour la case cochée. Ces images sont stockées dans
deux simples contrôles images.
Dans toutes les cellules qui doivent contenir une case à cocher, nous insérons l'image correspondant à l'état courant de la case à cocher.
Les deux procédures du code source ci-dessous montrent comment afficher la case à cocher. La procédure InitCelluleAvecCase() initialise une cellule pour qu'elle puisse contenir une case à cocher. Elle appelle la procédure AfficheCelluleAvecCase() qui elle se contente d'afficher la bonne image.
Private Sub InitCelluleAvecCase(ligne As Long, colonne As Long, Optional valeur As Boolean = False)
MSFlexGrid1.Col = colonne
MSFlexGrid1.Row = ligne
MSFlexGrid1.CellPictureAlignment = flexAlignCenterCenter
AfficheCelluleAvecCase ligne, colonne, valeur
End Sub
Private Sub AfficheCelluleAvecCase(ligne As Long, colonne As Long, Optional valeur As Boolean = False)
Set MSFlexGrid1.CellPicture = IIf(valeur, imgCaseCochee.Picture, imgCase.Picture)
End SubVoici un exemple complet qui utilise nos deux procédures. Au chargement de la form, la msflexgrid est initialisée pour afficher un tableau de commandes. Dans la troisième colonne de la grille, une case à cocher indique si la commande a été envoyée.
Private Type commande
reference As String
montant As Single
envoyee As Boolean
End Type
Dim commandes(0 To 2) As commande
Private Sub Form_Load()
Dim i As Long
'tableau de commandes
commandes(0).reference = "cmd0001": commandes(0).montant = 80: commandes(0).envoyee = True
commandes(1).reference = "cmd0002": commandes(1).montant = 150.2: commandes(1).envoyee = False
commandes(2).reference = "cmd0003": commandes(2).montant = 95.5: commandes(2).envoyee = True
'initialisation de la msflexgrid
MSFlexGrid1.Cols = 3
MSFlexGrid1.Rows = 4
MSFlexGrid1.FixedCols = 0
For i = 0 To 2
MSFlexGrid1.TextMatrix(i + 1, 0) = commandes(i).reference
MSFlexGrid1.TextMatrix(i + 1, 1) = commandes(i).montant
InitCelluleAvecCase i + 1, 2, commandes(i).envoyee
Next
End Sub
Private Sub MSFlexGrid1_Click()
If MSFlexGrid1.Col = 2 And MSFlexGrid1.MouseRow > 0 Then
commandes(MSFlexGrid1.Row - 1).envoyee = Not commandes(MSFlexGrid1.Row - 1).envoyee
AfficheCelluleAvecCase MSFlexGrid1.Row, 2, commandes(MSFlexGrid1.Row - 1).envoyee
End If
End SubMéthode testée sous Win XP :
Private Const Checked As Byte = 253
Private Const UnChecked As Byte = 168
Private Sub Form_Load()
Dim CCol, CRow As Integer
With MSFlexGrid1
.FixedCols = 0
.FixedRows = 1
.Cols = 8
.Rows = 8
.ColAlignment(2) = flexAlignCenterCenter
For CRow = .FixedRows To .Rows - 1
For CCol = 0 To .Cols - 1
.TextMatrix(CRow, CCol) = "Cel " & CRow & ", " & CCol
Next CCol
.Col = 2
.Row = CRow
.CellFontName = "Wingdings"
.CellFontSize = 12
.CellFontBold = False
.Text = Chr(UnChecked)
Next CRow
End With
End Sub
Private Sub MSFlexGrid1_Click()
With MSFlexGrid1
If .Col = 2 Then
If .Text = Chr(UnChecked) Then
.Text = Chr(Checked)
ElseIf .Text = Chr(Checked) Then
.Text = Chr(UnChecked)
End If
End If
End With
End SubIl n'existe pas de propriété pour le faire mais voici une astuce possible :
Private Sub MSFlexGrid1_SelChange()
MSFlexGrid1.RowSel = MSFlexGrid1.Row
End SubSi vous essayez de sélectionner plusieurs lignes à la souris, vous verrez un clignotement que vous pouvez éviter en empêchant le rafraîchissement automatique de la grille tant que le bouton de la souris est enfoncé :
Private Sub MSFlexGrid1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
MSFlexGrid1.Redraw = False
End Sub
Private Sub MSFlexGrid1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
MSFlexGrid1.Redraw = True
End SubCette fonction exporte le contenu de la msflexgrid passée en paramètre dans le fichier strFileName. Les colonnes sont séparées par le caractère passé dans le troisième paramètre.
Public Function ExportGridToFile(Mygrid As MSFlexGrid, Byval strFileName as string, _
Optional ByVal strSep As String = vbTab) As Boolean
Dim intFreeFile As Integer 'Numéro du fichier
Dim intCol As Integer, intRow As Integer 'Indices de ligne et colonne de W
Dim ligne As String 'La ligne à écrire dans le fichier
On Error GoTo ExportGridToFile_ERR
'Prend le prochain numéro de fichier
intFreeFile = FreeFile
'Ouvre le fichier en bloquant son accès aux autres applications
Open strFileName For Output Access Write Lock Read Write As #intFreeFile
With Mygrid
'Pour chaque ligne
For intRow = .FixedRows To .Rows - 1
ligne = ""
'Pour chaque colonne
For intCol = .FixedCols To .Cols - 1
'Ajoute la valeur de la cellule
ligne = ligne & .TextMatrix(intRow, intCol) & strSep
Next intCol
'Enlève le séparateur final
If strSep <> "" Then ligne = Left(ligne, Len(ligne) - 1)
Print #intFreeFile, ligne
Next intRow
End With
'Valide le bon fonctionnement de la fonction
ExportGridToFile = True
ExportGridToFile_FIN:
Close #intFreeFile + 1
Exit Function
ExportGridToFile_ERR:
ExportGridToFile = False
Resume ExportGridToFile_FIN
End FunctionCopiez ce code dans un module standard :
Private Type Size
cx As Long
cy As Long
End Type
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" _
(ByVal hdc As Long, ByVal lpsz As String, _
ByVal cbString As Long, lpSize As Size) As Long
Public Sub ResizeColumns(hdc As Long, flexgrid As MSFlexGrid)
Dim idxRow As Long, idxCol As Long, lngMax As Long
Dim texte As String, taille As Size
With flexgrid
'Parcoure les colonnes
For idxCol = 0 To .Cols - 1
lngMax = 0
'Parcoure les lignes
For idxRow = 0 To .Rows - 1
texte = .TextMatrix(idxRow, idxCol)
'met la taille du texte de la cellule en pixels dans taille
GetTextExtentPoint32 hdc, texte, Len(texte), taille
'lngMax est la longueur du texte le plus long dans cette colonne
If taille.cx > lngMax Then lngMax = taille.cx
Next
'met lngMax en twips en ajoutant 10 pixels pour les marges
If lngMax > 0 Then lngMax = (lngMax + 10) * Screen.TwipsPerPixelX
'Applique la largeur de colonne si besoin
If lngMax > .ColWidth(idxCol) Then .ColWidth(idxCol) = lngMax
Next
End With
End SubVoici comment appeler la procédure ResizeColumns :
ResizeColumns Me.hdc, MSFlexGrid1La procédure attend un contexte de périphérique en premier paramètre. Le contexte de périphérique est renvoyé par la propriété hdc. Si la form et la MSFlexGrid ont la même police, vous pouvez passer le contexte de périphérique de la form. Sinon vous pouvez ajouter un PictureBox invisible qui aura la même police que celle de la MSFlexgrid et passer sa propriété hdc en premier paramètre.
Picture1.PaintPicture Image1.Picture, 0, 0, Picture1.Width, Picture1.HeightUne solution consiste à utiliser l'évènement KeyPress, qui a lieu lorsqu'une touche correspondant à un caractère est enfoncée. Les touches comme shift, alt, control et F1 à F12 ne sont pas concernées. La procédure de cet évènement a un argument, KeyAscii, qui est le code du caractère à afficher. Modifiez sa valeur pour afficher le caractère que vous voulez. Donnez-lui une valeur nulle si aucun caractère ne doit être affiché. La fonction chr() renvoie le caractère dont le code est passé en paramètre.
L'exemple suivant interdit tout caractère autre que les chiffres et la touche d'effacement :
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii <> 8 Then
If Not IsNumeric(Chr(KeyAscii)) Then KeyAscii = 0
End If
End SubUne astuce souvent utilisée consiste à rechercher le caractère entré, dans une chaîne contenant tous les caractères autorisés. Si ce caractère n'est pas dans la chaîne, rien n'est affiché :
Private Sub Text1_KeyPress(KeyAscii As Integer)
Dim allowedKeys As String
allowedKeys = "0123456789-,." & Chr(8)
If InStr(allowedKeys, Chr(KeyAscii)) = 0 Then KeyAscii = 0
End SubUne solution possible est de simuler l'appui sur les touches ctrl + z :
Text1.SetFocus
SendKeys "^z"Mais vous pouvez aussi envoyer le message EM_UNDO au textbox, grâce à la fonction SendMessage() de l'Api Windows. Ajoutez tout d'abord ces déclarations :
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const EM_UNDO = &HC7Pour annuler la dernière modification sur le contenu de Text1 :
SendMessage Text1.hwnd, EM_UNDO, 0, 0Une première idée serait d'utiliser la fonction Split() avec vbCrLf comme séparateur. Mais une fin de ligne n'est pas forcément due à un retour chariot. Nous allons plutôt faire appel aux API Windows.
Copiez tout d'abord ces déclarations au début du module de la form :
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, _
ByVal Length As Long)
Private Const EM_GETLINECOUNT = &HBA
Private Const EM_LINELENGTH = &HC1
Private Const EM_LINEINDEX = &HBB
Private Const EM_GETLINE = &HC4La procédure ci-dessous affiche une par une les lignes du textbox dont le handle est passé en paramètre :
Private Sub AfficheLignes(lngHandleTextBox As Long)
Dim lngNbLignes As Long, i As Long
Dim lngIndexCar As Long, intLongueurLigne As Integer
Dim strLigne As String
'nombre de lignes
lngNbLignes = SendMessage(lngHandleTextBox, EM_GETLINECOUNT, 0, 0)
For i = 1 To lngNbLignes
'index du premier caractère de la ligne
lngIndexCar = SendMessage(lngHandleTextBox, EM_LINEINDEX, i - 1, 0)
'longueur de la ligne
intLongueurLigne = SendMessage(lngHandleTextBox, EM_LINELENGTH, lngIndexCar, 0)
'récupère la ligne dans la chaîne strLigne
strLigne = Space(intLongueurLigne)
CopyMemory ByVal strLigne, intLongueurLigne, Len(intLongueurLigne)
SendMessage lngHandleTextBox, EM_GETLINE, i - 1, ByVal strLigne
MsgBox strLigne
Next
End SubCréez un menu dans la form et rendez-le invisible. Puis créez des sous-menus visibles. Ce sont ces derniers qui apparaîtront dans le menu popup.
Tout se passe dans la procédure MouseDown. Afin d'empêcher le menu contextuel de Windows de s'afficher lorsque l'utilisateur va relâcher la souris, nous désactivons le textbox puis le réactivons immédiatement.
Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbRightButton Then
Text1.Enabled = False
Text1.Enabled = True
PopupMenu menuTextBox 'menuTextBox est le nom du menu invisible
End If
End SubLe contrôle TabStrip représente un ensemble d'onglets. Mais il ne permet pas d'associer des contrôles (textbox, commandbutton, etc...) à chacun des onglets. Vous devez donc gérer vous même l'affichage des contrôles en fonction de l'onglet qui est actif. Le plus simple est d'utiliser des frames indexées, et de mettre au premier plan la frame correspondant à l'onglet activé. Ici la première frame est d'index 1 :
Private Sub TabStrip1_Click()
frameOnglet(TabStrip1.SelectedItem.Index).ZOrder 0
End SubToutefois, on utilise plus souvent le contrôle Tabstrip lorsque plusieurs onglets utilisent une même frame. Dans ce cas on met dans la propriété tag de chaque objet Tab l'index de la frame qu'il doit mettre au premier plan. Le code devient alors :
Private Sub TabStrip1_Click()
frameOnglet(TabStrip1.SelectedItem.Tag).ZOrder 0
End SubIl n'est pas la peine d'aligner ni de dimensionner les Frames de votre TabStrip. En général on utilise un code d'alignement dans l'événement Load de la feuille semblable à celui-ci :
For compteur = 0 To frameOnglet.Count-1
With TabStrip1
frameOnglet(compteur).Move .ClientLeft, .ClientTop, .ClientWidth, .ClientHeight
End With
Next compteurPour cela, DAO 3.6 et Jet 4.0 doivent être installés. Dans les références de votre projet, enlevez "Microsoft DAO 3.5 Object Library" et sélectionnez "Microsoft DAO 3.6 Object Library". Puis utilisez ce code source pour vous connecter :
Dim daoDB36 As Database
Dim rs As Recordset
Dim sPath As String
sPath = "c:\base.mdb"
Set daoDB36 = DBEngine.OpenDatabase(sPath)
Set rs = daoDB36.OpenRecordset("tClients")
Set Data1.Recordset = rsUn code source vous permettant d'imprimer un RichTextBox, avec la gestion des pages, est dans cet article de MSDN.
Sur une feuille, placez 2 contrôles RichTextBox avec leur texte respectif et un bouton de commande Command1. Placez ensuite ce code dans le module de la form.
Private Function ConcatRTF(RTF1 As String, RTF2 As String) As String
ConcatRTF = Left(RTF1, InStrRev(RTF1, "}") - 1) & Mid(RTF2, 2)
End Function
Private Sub Command1_Click()
With Me.RichTextBox1
.TextRTF = ConcatRTF(.TextRTF, Me.RichTextBox2.TextRTF)
.Refresh
End With
End SubCe n'est pas possible avec la ComboBox standard. Par contre, celle incluse dans le composant Microsoft Forms 2.0 dispose de cette fonctionnalité.
- Ajoutez le composant Microsoft Forms 2.0 Object Library dans votre projet. Cela a pour effet d'ajouter des contrôles dans la boîte à outils, dont le contrôle ComboBox (il a le même nom que la ComboBox standard de VB mais il est plus évolué).
- Ajoutez un nouveau contrôle ComboBox sur votre Form.
- Modifiez sa propriété ColumnCount à la valeur souhaitée.
L'exemple suivant montre comment remplir une ComboBox à 3 colonnes :
Dim i As Integer
For i = 0 To 4
cboTest.AddItem
cboTest.List(i, 0) = "Lig " & i & " Col 0"
cboTest.List(i, 1) = "Lig " & i & " Col 1"
cboTest.List(i, 2) = "Lig " & i & " Col 2"
Next iPour qu'une colonne soit cachée, il suffit de mettre sa largeur à 0. Par exemple pour qu'une ComboBox ait 3 colonnes et que les deux premières soient cachées :
Combo1.ColumnCount = 3
Combo1.ColumnWidths = "0" & ";" & "0" & ";" & "3975"Habituellement, une ComboBox se déroule quand l'utilisateur clique dessus. Si vous voulez la dérouler avec du code, placez ces déclarations dans un module :
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Const CB_SHOWDROPDOWN = &H14F
Public Sub DerouleCombo(handle As Long)
SendMessage handle, CB_SHOWDROPDOWN, True, ByVal 0
End SubVoici comment par exemple dérouler automatiquement une combo quand elle reçoit le focus :
Private Sub Combo1_GotFocus()
DerouleCombo Combo1.hwnd
End SubCopiez ce code dans un module standard :
Private Const CB_GETLBTEXTLEN = &H149
Private Const CB_SHOWDROPDOWN = &H14F
Private Const CB_GETDROPPEDWIDTH = &H15F
Private Const CB_SETDROPPEDWIDTH = &H160
Private Const CB_MSGMAX = &H15B
Private Const CB_SETITEMHEIGHT = &H153
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Public Sub LargeurCombo(hwnd As Long, largeur As Long)
SendMessage hwnd, CB_SETDROPPEDWIDTH, largeur, ByVal 0
End SubLa procédure LargeurCombo modifie la largeur de la zone de déroulement de la combo dont le handle est passé en paramètre. Pour la tester, posez une combo sur une form et placez code dans le module de la form :
Private Sub Form_Load()
Dim i As Long
For i = 1 To 20
Combo1.AddItem "ligne " & i
Next
LargeurCombo Combo1.hwnd, 300
End SubCeci est possible en faisant appel à l'api MoveWindow. Copiez ce code dans module standard.
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, _
ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
Public Sub SetCtrlHeight(vCtrl As Control, vHeight As Long)
Dim xForm As VB.Form, xCont As Object, XScaleMode As ScaleModeConstants
'Trouve où est situé le contrôle (Formulaire et Contenant)
Set xForm = vCtrl.Parent
Set xCont = vCtrl.Container
'Enlève le contrôle de son contenant pour le mettre sur la form
Set vCtrl.Container = xForm
'Sauvegarde ScaleMode avant de le modifier
XScaleMode = xForm.ScaleMode
'Met ScaleMode du formulaire en Pixels car MoveWindow utilise les pixels
xForm.ScaleMode = vbPixels
'Redimentionne la fenêtre du ComboBox
MoveWindow vCtrl.hwnd, vCtrl.Left, vCtrl.Top, vCtrl.Width, vHeight, 1
'Remet ScaleMode à sa valeur initiale
xForm.ScaleMode = XScaleMode
'Remet le contrôle dans son contenant initial
Set vCtrl.Container = xCont
End SubVoici comment donner à la zone de déroulement d'une combo box une hauteur de 180 pixels :
Private Sub Form_Load()
Dim xHeight As Long
xHeight = 180 ' en pixel : affiche 12 lignes en Font MS sans Serif taille 8
Call SetCtrlHeight(Combo1, xHeight)
End SubCette fonctionnalité consiste à sélectionner automatiquement l'élément de la liste dont le début correspond aux caractères saisis dans la combo. Si aucun n'élément ne correspond, rien n'est sélectionné.
Copiez tout d'abord ces déclarations au début du module de la form :
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Const CB_FINDSTRING = &H14CTout le reste du code se situe dans la procédure de l'événement KeyPress, qui a lieu chaque fois qu'un caractère est entré :
Private Sub Combo1_KeyPress(KeyAscii As Integer)
Dim Trouve As Long, Position As Integer, Taille As Integer, strTemp As String
With Me.Combo1
If KeyAscii = 8 Then
If .SelStart = 0 Then Exit Sub
.SelStart = .SelStart - 1
.SelText = ""
Else
Position = .SelStart
strTemp = .Text
End If
.SelText = Chr(KeyAscii)
Trouve = SendMessage(.hwnd, CB_FINDSTRING, 0, ByVal .Text)
If Trouve = -1 Then
'les trois lignes suivantes doivent être enlevées en cas de non correspondance possible
.Text = strTemp
.SelStart = Position
.SelLength = (Len(.Text) - Position)
KeyAscii = 0
Exit Sub
Else
Position = .SelStart
Taille = Len(.List(Trouve)) - Len(.Text)
.SelText = .SelText & Right(.List(Trouve), Taille)
.SelStart = Position
.SelLength = Taille
KeyAscii = 0
End If
End With
End SubSi l'un des éléments d'une ListBox est trop long pour pouvoir être affiché entièrement dans la liste, un ascenseur horizontal serait bien utile, mais ce contrôle n'a pas de propriété permettant de l'indiquer. Afin qu'un ascenseur soit créé quand l'un des éléments dépasse la largeur de la liste, copiez tout d'abord ce code dans un module.
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, _
ByVal nCount As Long, lpRect As RECT, _
ByVal wFormat As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Const LB_SETHORIZONTALEXTENT = &H194
Private Const DT_CALCRECT = &H400
Private Const SM_CXVSCROLL = 2
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Sub ApplyScrollBar(ByVal hdc As Long, MaListe As ListBox)
Dim compteur As Long, Nlargeur As Long, LargText As Long, sysScrollWidth As Long
Dim rcText As RECT
sysScrollWidth = GetSystemMetrics(SM_CXVSCROLL)
For compteur = 0 To MaListe.ListCount - 1
DrawText hdc, MaListe.List(compteur), -1&, rcText, DT_CALCRECT
LargText = rcText.Right + sysScrollWidth
If LargText >= Nlargeur Then
Nlargeur = LargText
End If
Next compteur
SendMessage MaListe.hwnd, LB_SETHORIZONTALEXTENT, Nlargeur, ByVal 0&
End SubEnsuite, appelez la procédure ApplyScrollBar chaque fois que vous ajoutez ou supprimez un élément dans la liste, ce qui aura pour effet d'afficher ou de supprimer l'ascenseur et d'actualiser sa taille s'il reste visible. Pour tester ce code, placez une listbox sur une form et placez ce code dans le module de la form :
Private Sub Form_Load()
List1.AddItem "fjkzlqgj fjekljdsk"
List1.AddItem "fjkzlqgj fjekd jfskdlqgjslkdgjklsq fjdsk"
List1.AddItem "fjkzlqgj fjekl"
ApplyScrollBar Me.hdc, List1
End SubSi vous préférez ne pas utiliser la collection Microsoft Forms 2.0, il existe néanmoins une manière propre de présenter une entrée multicolonnes dans une ListBox:
Les items doivent être insérés dans la liste séparés par des tabulations, par exemple:
List1.Additem "champ1" & vbTab & "champ2" & vbTab & "champ3"Si la police est à chasse fixe (Courrier, par exemple), les colonnes sont alors correctement alignées, mais si la police est à chasse variable (ce qui est le cas la plupart du temps), il faut utiliser les API de Windows pour faire un alignement correct, comme suit:
Placez ce code dans un module:
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Public Const LB_SETTABSTOPS = &H192Utilisez ensuite le code suivant pour produire une liste avec des champs alignés proprement:
Private Sub Form_Load()
'ce tableau va contenir les positions des tabulations (ce qui equivaut
'à la largeur des colonnes
ReDim tabstop(0 To 2) As Long
'on positionne les tabulations
tabstop(0) = 90
tabstop(1) = 130
tabstop(2) = 185
'on efface puis on réinitialise les tabulations
Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 0&, ByVal 0&)
Call SendMessage(List1.hwnd, LB_SETTABSTOPS, 3, tabstop(0))
List1.Refresh
End SubNous allons voir comment placer dans une combo ou une liste les valeurs contenues dans un champ d'une base de données en vue d'une sélection d'un enregistrement. La liaison directe avec la source de données évite la boucle de lecture du recordset ainsi que l'instruction additem et facilite la lecture des autres champs de l'enregistrement sélectionné.
Placez un contrôle DataCombo ou DataList sur une feuille et initialisez une connexion à une base de données; ensuite, insérez ce code :
Set DataCombo1.DataSource = rst
Set DataCombo1.RowSource = rst
DataCombo1.ListField = "MonChamp" 'nom du champSi l'on désire voir l'élément sélectionné en surbrillance, il faut ajouter au code précédent :
DataCombo1.DataField = "MonChamp"Pour placer le recordset sur l'élément sélectionné et récupérer la valeur des autres champs de cet enregistrement :
Private Sub DataCombo1_Click()
If DataCombo1 <> "" Then
rst.Bookmark = DataCombo1.SelectedItem
End If
Text1.Text = rst.Fields("AutreChamp") ' nom d'un champ quelconque dans la base
End SubChaque noeud d'un TreeView possède une clé qui est un identifiant unique, assigné au moment de l'insertion et dont on se sert ici afin de tester l'existence d'un noeud:
If Treeview.Nodes(cle_a_verifier) Is Nothing Then
'le noeud n'existe pas
End IfContrairement à une opinion largement répandue, il est possible de changer la couleur d'arrière-plan d'un TreeView.
Placez ces déclarations dans un module :
Private Const GWL_STYLE As Long = (-16)
Private Const TVS_HASLINES As Long = 2
Private Const TV_FIRST As Long = &H1100
Private Const TVM_SETBKCOLOR As Long = (TV_FIRST + 29)
Private Const TVM_SETTEXTCOLOR As Long = (TV_FIRST + 30)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As LongEnsuite, placez la procédure suivante dans la section générale du formulaire:
Public Sub SetTreeViewArrPlan(ByVal treeview As MSComctlLib.treeview, ByVal couleur As Long)
Dim style As Long, noeud As Node
'Changement de l'arrière-plan du treeview
Call SendMessage(treeview.hwnd, TVM_SETBKCOLOR, 0, ByVal couleur)
'réinitialisation de l'arbre
style = GetWindowLong(treeview.hwnd, GWL_STYLE)
'Si l'arbre a des lignes, on les désactive temporairement pour que
'l'arrière-plan se redessine proprement, puis on les réactive
If style And TVS_HASLINES Then
SetWindowLong treeview.hwnd, GWL_STYLE, style Xor TVS_HASLINES
SetWindowLong treeview.hwnd, GWL_STYLE, style
End If
'on change la couleur de fond des noeuds
For Each noeud In treeview.Nodes
noeud.BackColor = couleur
Next
End SubL'appel se fait comme suit :
Dim couleur As Long
couleur = vbRed
SetTreeViewArrPlan TreeView1, couleurDans un module standard, placez ce code :
Public Const RELIEF = 1
Public Const ENCADREMENT = 2
Public Sub Ombrage(Feuille As Form, Ctrl As Control, Effet As Integer, OmbreLarg As Integer, OmbreCoul As Long)
Dim CouleurOmbre As Long
Dim LargeurOmbre As Integer
Dim Largeur As Integer
Dim Taille As Integer
LargeurOmbre = OmbreLarg
CouleurOmbre = OmbreCoul
Largeur = Feuille.DrawWidth
Taille = Feuille.ScaleMode
Feuille.DrawWidth = 1
Select Case Effet
Case ENCADREMENT
Feuille.Line (Ctrl.Left + LargeurOmbre, Ctrl.Top + LargeurOmbre)- _
Step(Ctrl.Width - 1, Ctrl.Height - 1), CouleurOmbre, BF
Case RELIEF
Feuille.Line (Ctrl.Left - LargeurOmbre, Ctrl.Top - LargeurOmbre)- _
Step(Ctrl.Width - 1, Ctrl.Height - 1), CouleurOmbre, BF
End Select
Feuille.DrawWidth = Largeur
Feuille.ScaleMode = Taille
End SubPosez, par exemple, un PictureBox sur votre feuille, et placez ce code dans le module de la feuille :
Private Sub Form_Paint()
Ombrage Me, Picture1, ENCADREMENT, 10, QBColor(5) 'contour du cadre accentué
Ombrage Me, Picture1, RELIEF, 10, QBColor(5) 'effet d'enfoncement de l'image
End SubLa fonction ci-dessous renvoie Vrai si le contrôle passé en paramètre contient une image.
Public Function ImagePresente(controle As Control) As Boolean
ImagePresente = (controle.Picture.Handle > 0)
End FunctionIl peut être utile de savoir si une propriété existe pour un contrôle donné, dans une boucle par exemple, afin d'éviter les erreurs
Insérez ce code dans la section déclaration de votre form ou dans un module :
Public Function ExistProperty(Obj As Object, ByVal PropertyName As String) As Boolean
On Error Resume Next
CallByName Obj, PropertyName, VbGet
ExistProperty = (Err.Number = 0)
Err.Clear
End FunctionExemple d'utilisation :
Dim Ctrl As Control
For Each Ctrl In Me.Controls
If Not ExistProperty(Ctrl, "ForeColor") Then
Debug.Print "La propriété ForeColor n'existe pas pour le controle " & Ctrl.Name
End If
NextDans Projets -> Composants -> Cocher Microsoft Windows Common Controls 6.0 (SP4)
Le code suivant ne fonctionne que sous Win 2000 et supérieur mais le deuxième code proposé palie à ce manque et fonctionne sous Win 98.
Sur une feuille, poser un contrôle ToolBar et copier le code dans la partie déclaration :
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, _
ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Sub Form_Load()
Dim i As Integer
Dim btn As Button
' Ajoute un objets Button au contrôle Toolbar.
Set btn = Toolbar1.Buttons.Add(Caption:="Test", Style:=tbrDropdown)
' Ajoute deux objets ButtonMenu à l'objet Button.
btn.ButtonMenus.Add Text:="Option 1"
btn.ButtonMenus.Add Text:="Option 2"
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Dim dx As Long
Dim dy As Long
Dim Point As POINTAPI
With Button
If .Style = tbrDropdown Then
If .ButtonMenus.Count = 0 Then Exit Sub
dx = (Me.Left + Toolbar1.Left + .Left + .Width) / Screen.Width * 65535
dy = (Me.Top + Toolbar1.Top + .Top + .Height) / Screen.Height * 65535
GetCursorPos Point
mouse_event &H8003, dx, dy, 0, 0
mouse_event &H8004, dx, dy, 0, 0
SetCursorPos Point.X, Point.Y
End If
End With
End Sub
Private Sub Toolbar1_ButtonMenuClick(ByVal ButtonMenu As MSComctlLib.ButtonMenu)
Select Case ButtonMenu.Index
Case 1
MsgBox "Vous avez cliquer sur l'option 1"
Case 2
MsgBox "Vous avez cliquer sur l'option 2"
End Select
End SubPour Win 98 : Avec un bouton normal et le déroulement d'un menu quand on clique dessus.
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
If Button.Index = 1 Then
PopupMenu lemenu, , Button.Left, Button.Top + Button.Height + Toolbar1.Top + 12
End If
End SubLe menu est créé dans l'éditeur de menu de la form.
Créez un fichier Manifest comme suit: (dans le bloc note de windows par exemple)
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity
type="win32"
name="Microsoft.Windows.Editeur"
processorArchitecture="X86"
version="4.4.0.0"
/>
<description>Entrez la description du programme ici</description>
<dependency>
<dependentAssembly>
<assemblyIdentity
type="win32"
name="Microsoft.Windows.Common-Controls"
language="*"
processorArchitecture="X86"
version="6.0.0.0"
publicKeyToken="6595b64144ccf1df"
/>
</dependentAssembly>
</dependency>
</assembly>et sauvegardez-le avec le nom et l'extension du fichier exécutable pour lequel il est destiné. Exemple: J'ai un programme qui s'appelle "CSBar.exe", si je veux faire un manifest pour ce fichier exécutable, le fichier manifest aura pour nom "CSBar.exe.manifest" Pour finir, dans le module de code de votre Form principale, mettez le code suivant:
'Déclaration des API
Private Declare Function InitCommonControls Lib "comctl32.dll" () As Long
Private Sub Form_Initialize()
'Initialise les controles pour leur donner le style de Windows XP.
InitCommonControls
End SubCompilez votre programme et lancez-le, vous pourrez voir que vos contrôles on désormais le style de Windows XP.
Lien : Donner le style Windows XP aux contrôles dans l'IDE de Visual Basic 6
Mettez ce code dans un module :
Private Type SHFILEOPSTRUCT
hWnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Const FO_COPY = &H2
Private Const FOF_ALLOWUNDO = &H40
Public Sub CopyFileWindowsWay(SourceFile As String, DestinationFile As String)
Dim lngReturn As Long
Dim typFileOperation As SHFILEOPSTRUCT
With typFileOperation
.hWnd = 0
.wFunc = FO_COPY
.pFrom = SourceFile & vbNullChar & vbNullChar
.pTo = DestinationFile & vbNullChar & vbNullChar
.fFlags = FOF_ALLOWUNDO
End With
lngReturn = SHFileOperation(typFileOperation)
If lngReturn <> 0 Then
MsgBox Err.LastDllError, vbCritical Or vbOKOnly
Else
If typFileOperation.fAnyOperationsAborted = True Then
MsgBox "Operation Failed", vbCritical Or vbOKOnly
End If
End If
End SubAppel de la procédure :
Call CopyFileWindowsWay(App.Path & "\denoxaut.732", App.Path & "\messanger\denoxaut.732")Ouvrir un module (page de code) :
- menu Projet puis Composants
- Onglet Contrôle
- Cochez Microsoft Common Dialog Control
Dans la barre d'outils, choisissez le control Microsoft Common Dialog Control et placez le sur le formulaire. Nous le nommons Dlg.
Placez le code suivant dans un module (action click du bouton Btn_Chercher) :
Private Sub Btn_Chercher_Click()
With dlg
.DialogTitle = "selectionner un fichier" 'titre de la boite
.FileName="*.txt" 'on recherche un fichier d'extension txt
.initDir="c:\" 'repertoire par defaut
.CancelError = false 'pour ne pas partir en erreur si on click sur annuler
.ShowOpen
End With
'txtPath est la zone de texte recevant le chemin du fichier
txtPath = dlg.FileName
End SubLien : Afficher la boîte de dialogue ouvrir afin de récupérer le nom et le chemin du fichier sélectionné
Lien : Afficher la boîte de dialogue Enregistrer sous afin de récupérer le nom et le chemin du fichier sélectionné
Lien : Comment sélectionner plusieurs extensions dans le filtre d'un CommonDialog ?
Pour utiliser le CommonDialog, il faut cocher le composant Microsoft Common Dialog Control 6.0 (SP2) et utiliser ce code :
CommonDialog1.Filter = "Fichier zip et rar (*.zip,*.rar)|*.zip;*.rar"Placer un composant RichTextBox sur votre feuille (Microsoft Rich Textbox Control 6.0 (SP4)) et le code suivant :
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) As Long
Private Const WM_PASTE As Long = &H302
Private Sub Form_Load()
Clipboard.Clear
Clipboard.SetData LoadPicture("c:\bitmap.bmp")
SendMessage RichTextBox1.hwnd, WM_PASTE, 0, 0
End Sub
Une Combobox standard en VB6 n'a pas de propriété "MatchEntry"
Il est toutefois possible de faire de l'auto-complétion dans une Combobox avec le code suivant :
Private Sub Combo1_Change()
Dim i As Integer, start As Integer
start = Len(Combo1.Text)
For i = 0 To Combo1.ListCount - 1
If Left(Combo1.List(i), start) = Combo1.Text Then
Combo1.Text = Combo1.List(i)
End If
Next
Combo1.SelStart = start
Combo1.SelLength = Len(Combo1.Text)
End SubUne autre méthode en utilisant l'API Windows :
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Const CB_ERR As Long = (-1)
Private Const CB_SELECTSTRING As Long = &H14D
Private Sub Combo1_Change()
Dim start As Integer
start = Len(Combo1.Text)
If SendMessage(Combo1.hwnd, CB_SELECTSTRING, ByVal Combo1.ListIndex, ByVal Combo1.Text) <> CB_ERR Then
Combo1.SelStart = start
Combo1.SelLength = Len(Combo1.Text)
End If
End Sub