Option Explicit
Private Declare Function FindWindow& Lib "User32" Alias "FindWindowA" _
(ByVal lpClassName$, ByVal lpWindowName$)
Private Declare Function SetWindowLong& Lib "User32" Alias "SetWindowLongA" _
(ByVal Hwnd&, ByVal nIndex&, ByVal dwNewLong&)
Private Declare Function ShowWindow& Lib "User32" _
(ByVal Hwnd&, ByVal nCmdShow&)
Dim Tableau(), temp, TabTemp As Variant, lig%, n&, Hwnd&
Private Sub Categories_Change()
If Me.Categories.Value = "" Then Exit Sub
With Me.Rubriques
.ListItems.Clear
For lig = 1 To UBound(TabTemp, 1)
If TabTemp(lig, 3) = Me.Categories.Value Then
.ListItems.Add , , TabTemp(lig, 1)
n = .ListItems.Count
.ListItems(n).ListSubItems.Add , , TabTemp(lig, 2)
n = n + 1
End If
Next
End With
End Sub
Private Sub Classeur_Click()
Dim wb As Workbook
Dim ws As Worksheet
Dim Classeur$
Classeur = ThisWorkbook.Path & "\Codes" & "\Codes.xls"
Set wb = Workbooks.Open(Classeur)
Set ws = wb.Worksheets("Data")
ShowWindow Hwnd, 2
End Sub
Private Sub UserForm_Initialize()
Dim i%, j%, k%, derlig&, Cpt
Sheets("Data").Activate
Cpt = Application.CountA(Range("A2:A65536")) - Application.CountIf(Range("A2:A65536"), "*part*")
With ThisWorkbook.Worksheets("Data")
derlig = .Range("A65535").End(xlUp).Row
TabTemp = .Range(.Cells(2, 1), .Cells(derlig, 3)).Value
End With
With Me.Rubriques
With .ColumnHeaders: .Add , , "RUBRIQUES", 250: End With
For i = 2 To Worksheets("Data").Cells(65536, 1).End(xlUp).Row
.ListItems.Add , , Worksheets("Data").Cells(i, 1).Value
.ListItems(.ListItems.Count).Tag = i 'Le numréro de la ligne
Next i
Me.Nombre.Caption = Cpt & " Codes VBA-Excel"
End With
ReDim Tableau(200)
For i = 2 To 200
Tableau(i) = Cells(i + 1, 3)
Next
For i = 1 To (UBound(Tableau) - 1)
For k = i + 1 To UBound(Tableau) - 1
If Tableau(i) > Tableau(k) Then
temp = Tableau(i)
Tableau(i) = Tableau(k)
Tableau(k) = temp
End If
Next
Next
For k = 1 To (UBound(Tableau) - 1)
If Tableau(k) = Tableau(k + 1) Then
Else
Me.Categories.AddItem Tableau(k)
End If
Next
Hwnd = FindWindow(vbNullString, Me.Caption)
Dim Fichier As String
Dim X As Long
Fichier = ThisWorkbook.Path & "\vba.ico"
X = Len(Dir(Fichier))
If X = 0 Then Exit Sub
X = ExtractIconA(0, Fichier, 0)
SendMessageA FindWindow(vbNullString, Me.Caption), &H80, False, X
End Sub
Private Sub UserForm_Activate()
ShowWindow Hwnd, 0
SetWindowLong Hwnd, -20, &H40101
ShowWindow Hwnd, 1
End Sub
Private Sub Rubriques_Click()
Dim c As Integer
Application.ScreenUpdating = False
For c = 1 To Rubriques.ListItems.Count
If Me.Rubriques.SelectedItem.Text <> "" Then
Me.Lbl_Rubriques.Caption = Me.Rubriques.SelectedItem.Text
Me.Codes.Text = Worksheets("Data").Cells(Me.Rubriques.SelectedItem.Tag, 2).Text
End If
Next c
Application.ScreenUpdating = True
End Sub
Private Sub Copier_Click()
With Me.Codes
.SetFocus
.SelStart = 0
.SelLength = Len(Me.Codes.Value)
.Copy
End With
End Sub
Private Sub Fermer_Click()
Unload Me
End Sub