Salut,
Je te rassure @Thierry le logo on le voit bien. Pour ceux qui ont XL97 modifié cette partie de code. Une façon de renvoyer la 1 ère sous chaine et la dernière sous chaine d'une chaine de caractères. idem pour le thread en inversant le tableau
Private Sub LbxString_Click()
Dim Contenu As Variant
Dim LbxVal As String, Subject As String
Dim X As Byte
LbxVal = Me.LbxString
Contenu = InStr(1, LbxVal, "#") - 1 'Split(LbxVal, "# : ")
Thread = Left(LbxVal, Contenu) ' (Contenu(0)
Subject = Right(LbxVal, Len(LbxVal) - Contenu)
Zou Thread, Subject
End Sub
Bien sûr le mode modal est à proscrire. Moi aussi je suis pris par le temps Thierry mais il y a 2 boucles au moins qu'on pourrait se passer, c'est vrai que la barre de progression est jolie mais elle prend du temps donc à toi de voir Thierry si tu veux modifier ou pas
Sub Totaling(TheString As String)
Dim Cell As Range
Dim FirstAddress As String
Dim StringFound As New Collection, Item
Me.LblScan = "Please Wait"
'Workbooks(OpenFile).Activate 'inutile c'est fait dans l'initialize
With Range(RangeSearch)
Set Cell = .Find(TheString, LookIn:=xlValues, lookat:=xlPart)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
Total = Total + 1
With Me
.LblScan = "Please Wait..." 'un doublon non ?
.LblRecords = "Records " & Total
DoEvents
End With
On Error Resume Next
StringFound.Add Cell.Offset(0, -ColOffset).Text & "# : " & Cell.Text, _
Cell.Offset(0, -ColOffset).Text & "# : " & Cell.Text
Set Cell = .FindNext(Cell)
Me.LblScan = "Please Wait......"
DoEvents
Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
End If
End With
For Each Item In StringFound
With USF1
.LbxString.AddItem Item
F = F + 1
End With
Next Item
USF1.LblScan = "Filtered Records " & F
End Sub
Sub Zou(ThreadN As String, Subj As String)
Dim Cel As Range, Cell As Range
Dim FirstAddress As String
Dim Tot As Byte, Toto As Byte
Dim I As Integer
Workbooks(OpenFile).Activate
ReDim TheThread(5, Toto)
With Range("C:C")
Set Cel = .Find(ThreadN, LookIn:=xlValues, lookat:=xlWhole)
If Not Cel Is Nothing Then
FirstAddress = Cel.Address
Do
'NB <<<< just to get that !! lol
ReDim Preserve TheThread(5, Toto)
TheThread(0, Toto) = Cel.Text
TheThread(1, Toto) = Cel.Offset(0, 2).Text
TheThread(2, Toto) = Cel.Offset(0, -1).Text
TheThread(3, Toto) = Cel.Offset(0, 4).Text
TheThread(4, Toto) = Cel.Offset(0, 3).Text
Toto = Toto + 1
Set Cel = .FindNext(Cel)
Loop While Not Cel Is Nothing And Cel.Address <> FirstAddress
End If
End With
Thread = TheThread(0, 0)
Me.ImgED.Visible = False
With Me.FrmDetails
.Visible = True
.LblThread = TheThread(0, 0)
.LblAuthor = TheThread(1, 0)
.LblDate = TheThread(2, 0)
.LblEmail = TheThread(3, 0)
.LblSubject = TheThread(4, 0)
.LblSpin = "Record " & LBound(TheThread, 2) + 1 & " of " & UBound(TheThread, 2) + 1
End With
With Me.FrmStats
.Visible = True
.LblMainNum = TheThread(0, 0)
.LblOrigin = TheThread(1, 0)
.LblPostNum = Toto
.LblLast = TheThread(1, UBound(TheThread, 2))
.LblLastEmail = TheThread(3, UBound(TheThread, 2))
.LblLastDate = TheThread(2, UBound(TheThread, 2))
.LblLastSubject = TheThread(4, UBound(TheThread, 2))
End With
With Me.SpbPost
.Min = UBound(TheThread, 2)
.Max = LBound(TheThread, 2)
.Value = LBound(TheThread, 2)
End With
End Sub
Private Sub SpbPost_Change()
Dim Pos As Byte
Pos = Me.SpbPost
With Me.FrmDetails
.Visible = True
.LblThread = TheThread(0, Pos)
.LblAuthor = TheThread(1, Pos)
.LblDate = TheThread(2, Pos)
.LblEmail = TheThread(3, Pos)
.LblSubject = TheThread(4, Pos)
.LblSpin = "Record " & Pos + 1 & " of " & UBound(TheThread, 2) + 1
End With
End Sub
ça permet de gagner un peu de temps. Je crois qu'on pourrait en gagner encore Thierry mais pas le temps de tester.=>fonctionne sous 97 et 2003 chez moi.
A+++
