Option Explicit
Const ChmTromb1 = "M:\Common\Doc_Plant\Trombinoscope\"
Const ChmTromb2 = "M:\Common\Doc_Plant\Trombinoscope\"
'
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Nom As String, L As Integer
If Target.Address = Me.[NomChrch].Address Then
TriNoms
Nom = UCase(Me.[NomChrch].Value)
If Nom = "" Then Exit Sub
On Error Resume Next
L = WorksheetFunction.Match(Nom, Me.[Noms], 1)
If Err <> 0 Then L = 1
On Error GoTo 0
If Me.[Noms].Rows(L).Value < Nom Then L = L + 1
If Left$(Me.[Noms].Rows(L).Value, Len(Nom)) > Nom And L > 1 Then L = L - 1
Me.[Noms].Rows(L).Select
ActiveWindow.ScrollRow = Selection.Row
End If
End Sub ' _
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not (Aide.Visible = xlSheetVisible Or ThisWorkbook.ReadOnly) Then ThisWorkbook.Workbook_Open
Dim ZNm As String, ZNd As String, ZNf As String, ZCNf As String, Rg As Range, X As Double
If Image1.Visible Then Image1.Visible = False
If Label1.Visible Then Label1.Visible = False
On Error Resume Next
If Intersect(Me.[Statut], Target.EntireRow).Value = "LocFct" Then GoTo VérifManipDanger
ZNm = Intersect(Me.[Noms], Target.EntireRow).Value
If Err <> 0 Then
ZNm = "": ZNd = "": Err.Clear
ElseIf ZNm <> "" Then
ZNd = Replace(ZNm, "'", "´")
ZNd = Replace(ZNd, " ", "_")
ZNd = Replace(ZNd, ".", "*")
If Right$(ZNd, 1) <> "*" Then ZNd = ZNd & ".*"
ZNf = Dir(ChmTromb1 & ZNd)
If ZNf = "" Then
ZNf = Dir(ChmTromb2 & ZNd): If ZNf <> "" Then _
ZCNf = ChmTromb2 & ZNf
Else
ZCNf = ChmTromb1 & ZNf
End If
End If
If ZNf <> "" Then
If ThisWorkbook.ReadOnly Then Set Rg = Me.[Clé] Else Set Rg = Me.[Notes]
With Image1: .Left = Rg.Left + Rg.Width + 10: .Top = Target.Top: .AutoSize = True: End With
With Label1: .Left = Image1.Left: .ForeColor = RGB(&HAE, &HFF, 0): .Height = 15
.Caption = Replace(Left$(ZNf, InStr(ZNf, ".") - 1), "_", " "): End With
Image1.Picture = LoadPicture(ZCNf)
If Err = 0 Then
Application.OnTime Now, "Liste.AfficherPhoto" '+ 1 / 68400
Else
MsgBox Err.Description & vbLf & """" & ZCNf & """.", vbExclamation, "Chargement image"
With Label1: .Top = Target.Top: .Width = 240: End With
GoTo VérifManipDanger: End If
With Image1: .AutoSize = False
X = 2 ^ (Int(4 * Log(120000 / (.Width * .Height)) / 0.693147180559945) / 8)
.Height = .Height * X: .Width = .Width * X: End With
With Label1: .Top = Image1.Top + Image1.Height - 1.5: .Width = Image1.Width: End With
ElseIf ZNd <> "" Then
With Label1: .Top = Target.Top: .Left = Rg.Left + Rg.Width + 10: .Height = 30: .Width = 180
.Caption = "Photo introuvable:" & vbLf & "«" & ZNd & "»" & vbLf & ""
.ForeColor = RGB(255, 195, 0): .Visible = True: End With
DéfilerLabel
End If
VérifManipDanger:
If ThisWorkbook.ReadOnly Then Exit Sub
If Not Intersect(Me.[Clé], Target) Is Nothing Then
' If MsgBox("Vous avez sélectionné des cellules dont la modification" & vbLf & _
' "risque d'entraîner des discordances entre la liste et les plans." & vbLf & _
' "Annulez pour écarter ces cellules de la sélection.", _
' vbExclamation + vbOKCancel + vbDefaultButton2, "Sélection dangereuse") = vbCancel Then
Application.EnableEvents = False
Err.Clear: Intersect(Union(Me.[Noms:Tel], Me.[Statut], Me.[Notes]), Target).Select
Application.EnableEvents = True
If Err Then UfEmplac.Afficher
' End If
End If
End Sub
'
Sub AfficherPhoto()
Label1.Visible = True
Image1.Visible = True
DéfilerLabel
End Sub
Sub DéfilerLabel()
Dim L As Integer, Ls As Integer: Ls = Selection.Row
With ActiveWindow
L = Label1.BottomRightCell.Row - .VisibleRange.Rows.Count + 2: If L > Ls Then L = Ls
While .ScrollRow < L: Temporiser: .SmallScroll Down:=1: Wend
End With
End Sub
