[vba] Taille d'un comment.shape

Modeste

20/09/2005 à 22:11

Bonsour®
Apprenti.xls wrote:

La procédure fonctionne correctement, mais je
la trouve un peu longuette ... J'ai plusieurs questions :
1/ comment faire pour la structurer plus efficacement ?

pour répondre au 1er point :
en evitant tout ces "if" .... (valeur doit etre strictement numerique et
positif !!)

Sub Commentaire()
Dim I As Integer
Dim Valeur
Dim chemin As String
Dim MonImage As String
chemin = "http://zzzzz/"
On Error GoTo Erreur

Valeur = ActiveCell.Offset(0, -1)
If IsEmpty(Valeur) Then
GoTo Erreur
Else
MonImage = chemin & Format(Valeur, "00000") & ".jpg)"

With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture MonImage
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With

End If
Exit Sub

Erreur:
On Error GoTo 0
ActiveCell.Activate
End Sub

--
n'oubliez pas les FAQ :
http://www.excelabo.net http://dj.joss.free.fr/faq.htm
http://www.faqoe.com http://faqword.free.fr
--
Feed Back
http://viadresse.com/?94912042

michdenis

21/09/2005 à 05:35

Bonjour Apprenti.xls,

Pour ta procédure, on pourrait réduire cette dernière à ceci :

Cette présentation représente l'ensemble de tes demandes.

IMPORTANT :
Tes liens hypertextes doivent indiquer le chemin complet.

'Dans le haut du module déclaration API
'Servant à déterminer si le lien hypertexte est valide ....

'======================================= Private Const S_FALSE = &H1
Private Const S_OK = &H0
'Only implemented as unicode...
Private Declare Function IsValidURL Lib "URLMON.DLL" _
(ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As Long
'----------------------------------------
Public Function IsGoodURL(ByVal sURL As String) As Boolean
'The IsValidURL always expects a UNICODE string, but whenever
'VB calls an API function, it converts the strings to ANSI strings.
'That's why we're going to use a trick here. Before calling the function,
'We're going to convert the unicode string to unicode so we get a double
'unicode string.
'Before VB calls the API function, it converts our double unicode string
'to a normal unicode string; exactely what IsValidURL is expecting.
sURL = StrConv(sURL, vbUnicode)
'Now call the function
IsGoodURL = (IsValidURL(ByVal 0&, sURL, 0) = S_OK)
End Function
'---------------------------
Function TestLienHypertexte(Link As String)
On Error Resume Next
If CStr(IsGoodURL(Link)) Then
TestLienHypertexte = Link
Else
TestLienHypertexte = ""
MsgBox " Ce lien hypertexte " & Link & _
" n'est pas valide."
End If
End Function
'---------------------------

Sub Commentaire()

Dim GestionErreur As String
Dim MonImage As String
Dim Sh As Shape, X As String

On Error GoTo GestionErreur
With ActiveCell
With .Offset(, -1)
If .Value <> "" Then
Select Case .Value
Case Is < 10
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 100
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 1000
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 10000
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
End Select
.Value = "0000" & .Value
End If
End With
.ClearComments
If MonImage = "" Then
.AddComment.Text Text:="Image non disponible."
Else
.AddComment.Text Text:=""
Set Sh = .Comment.Shape
End If
End With

If MonImage <> "" Then
With Sh
With .OLEFormat.Object
.Height = 20 'à déterminer
.Width = 40 'à déterminer
End With
.Fill.UserPicture MonImage
.Placement = xlMove
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
.OLEFormat.Object.Visible = False
.LockAspectRatio = msoTrue
.Locked = True
End With
End If
Exit Sub

GestionErreur:
MsgBox Err.Number & " : " & Err.Description
Exit Sub

End Sub
'======================================= *******************************************

Question II la photo est-elle dynamique ou non si le lien change ?
La photo affichée dans le commentaire sera celle que tu désigneras le chemin dans la procédure.
*******************************************

Question III quelle pourrait être la syntaxe pour vérifier qu'il n'existe pas de
commentaire auparavant ?
'---------------------------------
Dim C as comment
On Error Resume Next
Set C = Range("a1").Comment
If err<>0 then
err=0
Msgbox "La cellule n'a pas de commentaires"
Else
Msgbox "La cellule a déjà un commentaire"
End if
'---------------------------------

Cependant, c'est plus simple de le supprimer par :
Range("A1").ClearComments
et d'en ajouter un autre au besoin
.AddComment.Text Text:=""
*******************************************

Question IV comment vérifier si la photo existe avant d'afficher un commentaire

Dans le haut d'un module standard, tu copie ceci :

'Déclaration des API et de la fonction
'-------------------------------------
Private Const S_FALSE = &H1
Private Const S_OK = &H0
'Only implemented as unicode...
Private Declare Function IsValidURL Lib "URLMON.DLL" _
(ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As Long

Public Function IsGoodURL(ByVal sURL As String) As Boolean
'The IsValidURL always expects a UNICODE string, but whenever
'VB calls an API function, it converts the strings to ANSI strings.
'That's why we're going to use a trick here. Before calling the function,
'We're going to convert the unicode string to unicode so we get a double
'unicode string.
'Before VB calls the API function, it converts our double unicode string
'to a normal unicode string; exactely what IsValidURL is expecting.
sURL = StrConv(sURL, vbUnicode)
'Now call the function
IsGoodURL = (IsValidURL(ByVal 0&, sURL, 0) = S_OK)
End Function
'-------------------------------------

Dans ton code, tu teste comme ceci :
'--------------------------------
Sub TesterValiditerLienHypertexte()
On Error Resume Next
With ActiveCell
x = .Hyperlinks(1).Address
If Err <> 0 Then
Err = 0
MsgBox "Cellule sans lien hypertexte"
Exit Sub
End If
If CStr(IsGoodURL(x)) Then
MsgBox "Ok le lien est bon"
Else
MsgBox "Lien n'est pas bon."
End If
End With
End Sub
'--------------------------------
*******************************************

Question V comment faire en sorte que toutes mes photos
soient de la même taille, même et surtout après un filtre ?

Tu testeras ceci ....

Salutations!

"Apprenti.xls" <apprenti.xls(a supprimer)@voila.fr> a écrit dans le message de news:
Bonjour à tous !

Toujours au stade de l'apprentissage, j'ai aujourd'hui quelques
interrogations au sujet de l'affichage de commentaires.
J'ai conçu une petite procédure pour afficher une photo en commentaire en
fonction d'un numéro qui se trouve dans la colonne immédiatement à gauche.
La procédure fonctionne correctement, mais je la trouve un peu longuette ...
J'ai plusieurs questions :
1/ comment faire pour la structurer plus efficacement ?
2/ la photo est-elle dynamique ou non si le lien change ?
3/ quelle pourrait être la syntaxe pour vérifier qu'il n'existe pas de
commentaire auparavant ?
4/ comment vérifier si la photo existe avant d'afficher un commentaire ?
5/ enfin, et je vous remercie tous, d'ores et déjà, de m'avoir lu jusque
là, comment faire en sorte que toutes mes photos soient de la même taille,
même et surtout après un filtre ?

Toute aide est la bienvenue, car j'apprends, j'apprends, mais là, je butte
un peu...
À bientôt !

Voici mon code :

Sub Commentaire()
Dim I As Integer
Dim Valeur
On Error GoTo Erreur

Set Valeur = ActiveCell.Offset(0, -1)
If IsEmpty(Valeur) Then
GoTo Erreur
Else

If Valeur < 10 Then
Valeur = "0000" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 100 Then
Valeur = "000" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 1000 Then
Valeur = "00" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 10000 Then
Valeur = "0" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
End If
End If
End If
End If
End If
ActiveCell.Activate

Erreur:
ActiveCell.Activate
Exit Sub
End Sub

Bonjour Apprenti.xls,

Pour ta procédure, on pourrait réduire cette dernière à ceci :

Cette présentation représente l'ensemble de tes demandes.

IMPORTANT :
Tes liens hypertextes doivent indiquer le chemin complet.

'Dans le haut du module déclaration API
'Servant à déterminer si le lien hypertexte est valide ....

'======================================= Private Const S_FALSE = &H1
Private Const S_OK = &H0
'Only implemented as unicode...
Private Declare Function IsValidURL Lib "URLMON.DLL" _
(ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As Long
'----------------------------------------
Public Function IsGoodURL(ByVal sURL As String) As Boolean
'The IsValidURL always expects a UNICODE string, but whenever
'VB calls an API function, it converts the strings to ANSI strings.
'That's why we're going to use a trick here. Before calling the function,
'We're going to convert the unicode string to unicode so we get a double
'unicode string.
'Before VB calls the API function, it converts our double unicode string
'to a normal unicode string; exactely what IsValidURL is expecting.
sURL = StrConv(sURL, vbUnicode)
'Now call the function
IsGoodURL = (IsValidURL(ByVal 0&, sURL, 0) = S_OK)
End Function
'---------------------------
Function TestLienHypertexte(Link As String)
On Error Resume Next
If CStr(IsGoodURL(Link)) Then
TestLienHypertexte = Link
Else
TestLienHypertexte = ""
MsgBox " Ce lien hypertexte " & Link & _
" n'est pas valide."
End If
End Function
'---------------------------

Sub Commentaire()

Dim GestionErreur As String
Dim MonImage As String
Dim Sh As Shape, X As String

On Error GoTo GestionErreur
With ActiveCell
With .Offset(, -1)
If .Value <> "" Then
Select Case .Value
Case Is < 10
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 100
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 1000
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 10000
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
End Select
.Value = "0000" & .Value
End If
End With
.ClearComments
If MonImage = "" Then
.AddComment.Text Text:="Image non disponible."
Else
.AddComment.Text Text:=""
Set Sh = .Comment.Shape
End If
End With

If MonImage <> "" Then
With Sh
With .OLEFormat.Object
.Height = 20 'à déterminer
.Width = 40 'à déterminer
End With
.Fill.UserPicture MonImage
.Placement = xlMove
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
.OLEFormat.Object.Visible = False
.LockAspectRatio = msoTrue
.Locked = True
End With
End If
Exit Sub

GestionErreur:
MsgBox Err.Number & " : " & Err.Description
Exit Sub

End Sub
'======================================= *******************************************

Question II la photo est-elle dynamique ou non si le lien change ?
La photo affichée dans le commentaire sera celle que tu désigneras le chemin dans la procédure.
*******************************************

Question III quelle pourrait être la syntaxe pour vérifier qu'il n'existe pas de
commentaire auparavant ?
'---------------------------------
Dim C as comment
On Error Resume Next
Set C = Range("a1").Comment
If err<>0 then
err=0
Msgbox "La cellule n'a pas de commentaires"
Else
Msgbox "La cellule a déjà un commentaire"
End if
'---------------------------------

Cependant, c'est plus simple de le supprimer par :
Range("A1").ClearComments
et d'en ajouter un autre au besoin
.AddComment.Text Text:=""
*******************************************

Question IV comment vérifier si la photo existe avant d'afficher un commentaire

Dans le haut d'un module standard, tu copie ceci :

'Déclaration des API et de la fonction
'-------------------------------------
Private Const S_FALSE = &H1
Private Const S_OK = &H0
'Only implemented as unicode...
Private Declare Function IsValidURL Lib "URLMON.DLL" _
(ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As Long

Public Function IsGoodURL(ByVal sURL As String) As Boolean
'The IsValidURL always expects a UNICODE string, but whenever
'VB calls an API function, it converts the strings to ANSI strings.
'That's why we're going to use a trick here. Before calling the function,
'We're going to convert the unicode string to unicode so we get a double
'unicode string.
'Before VB calls the API function, it converts our double unicode string
'to a normal unicode string; exactely what IsValidURL is expecting.
sURL = StrConv(sURL, vbUnicode)
'Now call the function
IsGoodURL = (IsValidURL(ByVal 0&, sURL, 0) = S_OK)
End Function
'-------------------------------------

Dans ton code, tu teste comme ceci :
'--------------------------------
Sub TesterValiditerLienHypertexte()
On Error Resume Next
With ActiveCell
x = .Hyperlinks(1).Address
If Err <> 0 Then
Err = 0
MsgBox "Cellule sans lien hypertexte"
Exit Sub
End If
If CStr(IsGoodURL(x)) Then
MsgBox "Ok le lien est bon"
Else
MsgBox "Lien n'est pas bon."
End If
End With
End Sub
'--------------------------------
*******************************************

Question V comment faire en sorte que toutes mes photos
soient de la même taille, même et surtout après un filtre ?

Tu testeras ceci ....

Salutations!

"Apprenti.xls" <apprenti.xls(a supprimer)@voila.fr> a écrit dans le message de news: eFPe4khvFHA.1392@tk2msftngp13.phx.gbl...
Bonjour à tous !

Toujours au stade de l'apprentissage, j'ai aujourd'hui quelques
interrogations au sujet de l'affichage de commentaires.
J'ai conçu une petite procédure pour afficher une photo en commentaire en
fonction d'un numéro qui se trouve dans la colonne immédiatement à gauche.
La procédure fonctionne correctement, mais je la trouve un peu longuette ...
J'ai plusieurs questions :
1/ comment faire pour la structurer plus efficacement ?
2/ la photo est-elle dynamique ou non si le lien change ?
3/ quelle pourrait être la syntaxe pour vérifier qu'il n'existe pas de
commentaire auparavant ?
4/ comment vérifier si la photo existe avant d'afficher un commentaire ?
5/ enfin, et je vous remercie tous, d'ores et déjà, de m'avoir lu jusque
là, comment faire en sorte que toutes mes photos soient de la même taille,
même et surtout après un filtre ?

Toute aide est la bienvenue, car j'apprends, j'apprends, mais là, je butte
un peu...
À bientôt !

Voici mon code :

Sub Commentaire()
Dim I As Integer
Dim Valeur
On Error GoTo Erreur

Set Valeur = ActiveCell.Offset(0, -1)
If IsEmpty(Valeur) Then
GoTo Erreur
Else

If Valeur < 10 Then
Valeur = "0000" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 100 Then
Valeur = "000" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 1000 Then
Valeur = "00" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 10000 Then
Valeur = "0" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
End If
End If
End If
End If
End If
ActiveCell.Activate

Erreur:
ActiveCell.Activate
Exit Sub
End Sub

Vous avez filtré cet utilisateur ! Consultez son message

Bonjour Apprenti.xls,

Pour ta procédure, on pourrait réduire cette dernière à ceci :

Cette présentation représente l'ensemble de tes demandes.

IMPORTANT :
Tes liens hypertextes doivent indiquer le chemin complet.

'Dans le haut du module déclaration API
'Servant à déterminer si le lien hypertexte est valide ....

'======================================= Private Const S_FALSE = &H1
Private Const S_OK = &H0
'Only implemented as unicode...
Private Declare Function IsValidURL Lib "URLMON.DLL" _
(ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As Long
'----------------------------------------
Public Function IsGoodURL(ByVal sURL As String) As Boolean
'The IsValidURL always expects a UNICODE string, but whenever
'VB calls an API function, it converts the strings to ANSI strings.
'That's why we're going to use a trick here. Before calling the function,
'We're going to convert the unicode string to unicode so we get a double
'unicode string.
'Before VB calls the API function, it converts our double unicode string
'to a normal unicode string; exactely what IsValidURL is expecting.
sURL = StrConv(sURL, vbUnicode)
'Now call the function
IsGoodURL = (IsValidURL(ByVal 0&, sURL, 0) = S_OK)
End Function
'---------------------------
Function TestLienHypertexte(Link As String)
On Error Resume Next
If CStr(IsGoodURL(Link)) Then
TestLienHypertexte = Link
Else
TestLienHypertexte = ""
MsgBox " Ce lien hypertexte " & Link & _
" n'est pas valide."
End If
End Function
'---------------------------

Sub Commentaire()

Dim GestionErreur As String
Dim MonImage As String
Dim Sh As Shape, X As String

On Error GoTo GestionErreur
With ActiveCell
With .Offset(, -1)
If .Value <> "" Then
Select Case .Value
Case Is < 10
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 100
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 1000
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 10000
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
End Select
.Value = "0000" & .Value
End If
End With
.ClearComments
If MonImage = "" Then
.AddComment.Text Text:="Image non disponible."
Else
.AddComment.Text Text:=""
Set Sh = .Comment.Shape
End If
End With

If MonImage <> "" Then
With Sh
With .OLEFormat.Object
.Height = 20 'à déterminer
.Width = 40 'à déterminer
End With
.Fill.UserPicture MonImage
.Placement = xlMove
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
.OLEFormat.Object.Visible = False
.LockAspectRatio = msoTrue
.Locked = True
End With
End If
Exit Sub

GestionErreur:
MsgBox Err.Number & " : " & Err.Description
Exit Sub

End Sub
'======================================= *******************************************

Question II la photo est-elle dynamique ou non si le lien change ?
La photo affichée dans le commentaire sera celle que tu désigneras le chemin dans la procédure.
*******************************************

Question III quelle pourrait être la syntaxe pour vérifier qu'il n'existe pas de
commentaire auparavant ?
'---------------------------------
Dim C as comment
On Error Resume Next
Set C = Range("a1").Comment
If err<>0 then
err=0
Msgbox "La cellule n'a pas de commentaires"
Else
Msgbox "La cellule a déjà un commentaire"
End if
'---------------------------------

Cependant, c'est plus simple de le supprimer par :
Range("A1").ClearComments
et d'en ajouter un autre au besoin
.AddComment.Text Text:=""
*******************************************

Question IV comment vérifier si la photo existe avant d'afficher un commentaire

Dans le haut d'un module standard, tu copie ceci :

'Déclaration des API et de la fonction
'-------------------------------------
Private Const S_FALSE = &H1
Private Const S_OK = &H0
'Only implemented as unicode...
Private Declare Function IsValidURL Lib "URLMON.DLL" _
(ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As Long

Public Function IsGoodURL(ByVal sURL As String) As Boolean
'The IsValidURL always expects a UNICODE string, but whenever
'VB calls an API function, it converts the strings to ANSI strings.
'That's why we're going to use a trick here. Before calling the function,
'We're going to convert the unicode string to unicode so we get a double
'unicode string.
'Before VB calls the API function, it converts our double unicode string
'to a normal unicode string; exactely what IsValidURL is expecting.
sURL = StrConv(sURL, vbUnicode)
'Now call the function
IsGoodURL = (IsValidURL(ByVal 0&, sURL, 0) = S_OK)
End Function
'-------------------------------------

Dans ton code, tu teste comme ceci :
'--------------------------------
Sub TesterValiditerLienHypertexte()
On Error Resume Next
With ActiveCell
x = .Hyperlinks(1).Address
If Err <> 0 Then
Err = 0
MsgBox "Cellule sans lien hypertexte"
Exit Sub
End If
If CStr(IsGoodURL(x)) Then
MsgBox "Ok le lien est bon"
Else
MsgBox "Lien n'est pas bon."
End If
End With
End Sub
'--------------------------------
*******************************************

Question V comment faire en sorte que toutes mes photos
soient de la même taille, même et surtout après un filtre ?

Tu testeras ceci ....

Salutations!

"Apprenti.xls" <apprenti.xls(a supprimer)@voila.fr> a écrit dans le message de news:
Bonjour à tous !

Toujours au stade de l'apprentissage, j'ai aujourd'hui quelques
interrogations au sujet de l'affichage de commentaires.
J'ai conçu une petite procédure pour afficher une photo en commentaire en
fonction d'un numéro qui se trouve dans la colonne immédiatement à gauche.
La procédure fonctionne correctement, mais je la trouve un peu longuette ...
J'ai plusieurs questions :
1/ comment faire pour la structurer plus efficacement ?
2/ la photo est-elle dynamique ou non si le lien change ?
3/ quelle pourrait être la syntaxe pour vérifier qu'il n'existe pas de
commentaire auparavant ?
4/ comment vérifier si la photo existe avant d'afficher un commentaire ?
5/ enfin, et je vous remercie tous, d'ores et déjà, de m'avoir lu jusque
là, comment faire en sorte que toutes mes photos soient de la même taille,
même et surtout après un filtre ?

Toute aide est la bienvenue, car j'apprends, j'apprends, mais là, je butte
un peu...
À bientôt !

Voici mon code :

Sub Commentaire()
Dim I As Integer
Dim Valeur
On Error GoTo Erreur

Set Valeur = ActiveCell.Offset(0, -1)
If IsEmpty(Valeur) Then
GoTo Erreur
Else

If Valeur < 10 Then
Valeur = "0000" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 100 Then
Valeur = "000" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 1000 Then
Valeur = "00" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 10000 Then
Valeur = "0" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
End If
End If
End If
End If
End If
ActiveCell.Activate

Erreur:
ActiveCell.Activate
Exit Sub
End Sub

michdenis

21/09/2005 à 05:46

Une dernière information :

Pour empêcher que le chemin "en dur" de tes liens hypertextes se transforment en chemin relatif et foutre le bordel :

barre des menus de la feuille de calcul / outils / options / onglet général / Options Web / onglet Fichiers / décoche : "mettre à
jour les liens lors de l'enregistrement"

Salutations!

Apprenti.xls

23/09/2005 à 10:05

Merci Modeste !
Je me doutais bien qu'il fallait passer par qqch comme ça, mais en
l'occurence, cela ne fonctionne pas.
Les images sont en effet bien identifiées comme "00012.jpg" et la solution
du format n'est pas suffisante... dommage, mais merci encore de m'avoir
apporté une première idée pour alléger ma macro, je vais essayer de m'en
servir ailleurs, malgré tout.
@+

"Modeste" a écrit dans le message de news:
ul57Z%

Bonsour®
Apprenti.xls wrote:
La procédure fonctionne correctement, mais je
la trouve un peu longuette ... J'ai plusieurs questions :
1/ comment faire pour la structurer plus efficacement ?

pour répondre au 1er point :
en evitant tout ces "if" .... (valeur doit etre strictement numerique et
positif !!)

Sub Commentaire()
Dim I As Integer
Dim Valeur
Dim chemin As String
Dim MonImage As String
chemin = "http://zzzzz/"
On Error GoTo Erreur

Valeur = ActiveCell.Offset(0, -1)
If IsEmpty(Valeur) Then
GoTo Erreur
Else
MonImage = chemin & Format(Valeur, "00000") & ".jpg)"

With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture MonImage
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With

End If
Exit Sub

Erreur:
On Error GoTo 0
ActiveCell.Activate
End Sub

--
n'oubliez pas les FAQ :
http://www.excelabo.net http://dj.joss.free.fr/faq.htm
http://www.faqoe.com http://faqword.free.fr
--
Feed Back
http://viadresse.com/?94912042

Apprenti.xls

23/09/2005 à 10:36

Merci Denis !

Une fois de plus, un nouveau coup de main. Finalement, je m'aperçois que ma
demande dans un seul fil est trop importante. J'aurais dû en créer plusieurs
et étalés dans le temps. Je teste pour l'instant ton code pour la
vérification des liens hypertextes. Cela ne fonctionne pas exactement comme
je le souhaiterais, j'essaye de l'adapter en ce moment.
Je reviendrai plus tard pour dire où j'en suis plus précisément. Je n'ai pas
accès au forum tous les jours ...

En attendant, pour le 5ème point, le seul objet de ce fil finalement,
(Comment faire en sorte que toutes mes photos soient de la même taille, même
et surtout après un filtre ?), tu as oublié de recoupier le code que tu
avais sans doute préparé ;o)

Tu testeras ceci ....

Merci encore pour ton coup de main.
J'apprends, j'apprends, j'aurais eu franchement du mal pour l'API sans aide
...
@+

"michdenis" a écrit dans le message de news:

Bonjour Apprenti.xls,

Pour ta procédure, on pourrait réduire cette dernière à ceci :

Cette présentation représente l'ensemble de tes demandes.

IMPORTANT :
Tes liens hypertextes doivent indiquer le chemin complet.

'Dans le haut du module déclaration API
'Servant à déterminer si le lien hypertexte est valide ....

'======================================= > Private Const S_FALSE = &H1
Private Const S_OK = &H0
'Only implemented as unicode...
Private Declare Function IsValidURL Lib "URLMON.DLL" _
(ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As
Long
'----------------------------------------
Public Function IsGoodURL(ByVal sURL As String) As Boolean
'The IsValidURL always expects a UNICODE string, but whenever
'VB calls an API function, it converts the strings to ANSI strings.
'That's why we're going to use a trick here. Before calling the
function,
'We're going to convert the unicode string to unicode so we get a
double
'unicode string.
'Before VB calls the API function, it converts our double unicode
string
'to a normal unicode string; exactely what IsValidURL is expecting.
sURL = StrConv(sURL, vbUnicode)
'Now call the function
IsGoodURL = (IsValidURL(ByVal 0&, sURL, 0) = S_OK)
End Function
'---------------------------
Function TestLienHypertexte(Link As String)
On Error Resume Next
If CStr(IsGoodURL(Link)) Then
TestLienHypertexte = Link
Else
TestLienHypertexte = ""
MsgBox " Ce lien hypertexte " & Link & _
" n'est pas valide."
End If
End Function
'---------------------------

Sub Commentaire()

Dim GestionErreur As String
Dim MonImage As String
Dim Sh As Shape, X As String

On Error GoTo GestionErreur
With ActiveCell
With .Offset(, -1)
If .Value <> "" Then
Select Case .Value
Case Is < 10
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 100
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 1000
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 10000
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
End Select
.Value = "0000" & .Value
End If
End With
.ClearComments
If MonImage = "" Then
.AddComment.Text Text:="Image non disponible."
Else
.AddComment.Text Text:=""
Set Sh = .Comment.Shape
End If
End With

If MonImage <> "" Then
With Sh
With .OLEFormat.Object
.Height = 20 'à déterminer
.Width = 40 'à déterminer
End With
.Fill.UserPicture MonImage
.Placement = xlMove
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
.OLEFormat.Object.Visible = False
.LockAspectRatio = msoTrue
.Locked = True
End With
End If
Exit Sub

GestionErreur:
MsgBox Err.Number & " : " & Err.Description
Exit Sub

End Sub
'======================================= > *******************************************

Question II la photo est-elle dynamique ou non si le lien change ?
La photo affichée dans le commentaire sera celle que tu désigneras le
chemin dans la procédure.
*******************************************

Question III quelle pourrait être la syntaxe pour vérifier qu'il n'existe
pas de
commentaire auparavant ?
'---------------------------------
Dim C as comment
On Error Resume Next
Set C = Range("a1").Comment
If err<>0 then
err=0
Msgbox "La cellule n'a pas de commentaires"
Else
Msgbox "La cellule a déjà un commentaire"
End if
'---------------------------------

Cependant, c'est plus simple de le supprimer par :
Range("A1").ClearComments
et d'en ajouter un autre au besoin
.AddComment.Text Text:=""
*******************************************

Question IV comment vérifier si la photo existe avant d'afficher un
commentaire

Dans le haut d'un module standard, tu copie ceci :

'Déclaration des API et de la fonction
'-------------------------------------
Private Const S_FALSE = &H1
Private Const S_OK = &H0
'Only implemented as unicode...
Private Declare Function IsValidURL Lib "URLMON.DLL" _
(ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As
Long

Public Function IsGoodURL(ByVal sURL As String) As Boolean
'The IsValidURL always expects a UNICODE string, but whenever
'VB calls an API function, it converts the strings to ANSI strings.
'That's why we're going to use a trick here. Before calling the
function,
'We're going to convert the unicode string to unicode so we get a
double
'unicode string.
'Before VB calls the API function, it converts our double unicode
string
'to a normal unicode string; exactely what IsValidURL is expecting.
sURL = StrConv(sURL, vbUnicode)
'Now call the function
IsGoodURL = (IsValidURL(ByVal 0&, sURL, 0) = S_OK)
End Function
'-------------------------------------

Dans ton code, tu teste comme ceci :
'--------------------------------
Sub TesterValiditerLienHypertexte()
On Error Resume Next
With ActiveCell
x = .Hyperlinks(1).Address
If Err <> 0 Then
Err = 0
MsgBox "Cellule sans lien hypertexte"
Exit Sub
End If
If CStr(IsGoodURL(x)) Then
MsgBox "Ok le lien est bon"
Else
MsgBox "Lien n'est pas bon."
End If
End With
End Sub
'--------------------------------
*******************************************

Question V comment faire en sorte que toutes mes photos
soient de la même taille, même et surtout après un filtre ?

Tu testeras ceci ....

Salutations!

"Apprenti.xls" <apprenti.xls(a supprimer)@voila.fr> a écrit dans le
message de news:
Bonjour à tous !

Toujours au stade de l'apprentissage, j'ai aujourd'hui quelques
interrogations au sujet de l'affichage de commentaires.
J'ai conçu une petite procédure pour afficher une photo en commentaire en
fonction d'un numéro qui se trouve dans la colonne immédiatement à gauche.
La procédure fonctionne correctement, mais je la trouve un peu longuette
...
J'ai plusieurs questions :
1/ comment faire pour la structurer plus efficacement ?
2/ la photo est-elle dynamique ou non si le lien change ?
3/ quelle pourrait être la syntaxe pour vérifier qu'il n'existe pas de
commentaire auparavant ?
4/ comment vérifier si la photo existe avant d'afficher un commentaire ?
5/ enfin, et je vous remercie tous, d'ores et déjà, de m'avoir lu jusque
là, comment faire en sorte que toutes mes photos soient de la même taille,
même et surtout après un filtre ?

Toute aide est la bienvenue, car j'apprends, j'apprends, mais là, je butte
un peu...
À bientôt !

Voici mon code :

Sub Commentaire()
Dim I As Integer
Dim Valeur
On Error GoTo Erreur

Set Valeur = ActiveCell.Offset(0, -1)
If IsEmpty(Valeur) Then
GoTo Erreur
Else

If Valeur < 10 Then
Valeur = "0000" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 100 Then
Valeur = "000" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 1000 Then
Valeur = "00" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 10000 Then
Valeur = "0" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
End If
End If
End If
End If
End If
ActiveCell.Activate

Erreur:
ActiveCell.Activate
Exit Sub
End Sub

Merci Denis !

Une fois de plus, un nouveau coup de main. Finalement, je m'aperçois que ma
demande dans un seul fil est trop importante. J'aurais dû en créer plusieurs
et étalés dans le temps. Je teste pour l'instant ton code pour la
vérification des liens hypertextes. Cela ne fonctionne pas exactement comme
je le souhaiterais, j'essaye de l'adapter en ce moment.
Je reviendrai plus tard pour dire où j'en suis plus précisément. Je n'ai pas
accès au forum tous les jours ...

En attendant, pour le 5ème point, le seul objet de ce fil finalement,
(Comment faire en sorte que toutes mes photos soient de la même taille, même
et surtout après un filtre ?), tu as oublié de recoupier le code que tu
avais sans doute préparé ;o)

Tu testeras ceci ....

Merci encore pour ton coup de main.
J'apprends, j'apprends, j'aurais eu franchement du mal pour l'API sans aide
...
@+

"michdenis" <michdenis@hotmail.com> a écrit dans le message de news:
Oium91lvFHA.3864@TK2MSFTNGP12.phx.gbl...

Bonjour Apprenti.xls,

Pour ta procédure, on pourrait réduire cette dernière à ceci :

Cette présentation représente l'ensemble de tes demandes.

IMPORTANT :
Tes liens hypertextes doivent indiquer le chemin complet.

'Dans le haut du module déclaration API
'Servant à déterminer si le lien hypertexte est valide ....

'======================================= > Private Const S_FALSE = &H1
Private Const S_OK = &H0
'Only implemented as unicode...
Private Declare Function IsValidURL Lib "URLMON.DLL" _
(ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As
Long
'----------------------------------------
Public Function IsGoodURL(ByVal sURL As String) As Boolean
'The IsValidURL always expects a UNICODE string, but whenever
'VB calls an API function, it converts the strings to ANSI strings.
'That's why we're going to use a trick here. Before calling the
function,
'We're going to convert the unicode string to unicode so we get a
double
'unicode string.
'Before VB calls the API function, it converts our double unicode
string
'to a normal unicode string; exactely what IsValidURL is expecting.
sURL = StrConv(sURL, vbUnicode)
'Now call the function
IsGoodURL = (IsValidURL(ByVal 0&, sURL, 0) = S_OK)
End Function
'---------------------------
Function TestLienHypertexte(Link As String)
On Error Resume Next
If CStr(IsGoodURL(Link)) Then
TestLienHypertexte = Link
Else
TestLienHypertexte = ""
MsgBox " Ce lien hypertexte " & Link & _
" n'est pas valide."
End If
End Function
'---------------------------

Sub Commentaire()

Dim GestionErreur As String
Dim MonImage As String
Dim Sh As Shape, X As String

On Error GoTo GestionErreur
With ActiveCell
With .Offset(, -1)
If .Value <> "" Then
Select Case .Value
Case Is < 10
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 100
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 1000
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 10000
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
End Select
.Value = "0000" & .Value
End If
End With
.ClearComments
If MonImage = "" Then
.AddComment.Text Text:="Image non disponible."
Else
.AddComment.Text Text:=""
Set Sh = .Comment.Shape
End If
End With

If MonImage <> "" Then
With Sh
With .OLEFormat.Object
.Height = 20 'à déterminer
.Width = 40 'à déterminer
End With
.Fill.UserPicture MonImage
.Placement = xlMove
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
.OLEFormat.Object.Visible = False
.LockAspectRatio = msoTrue
.Locked = True
End With
End If
Exit Sub

GestionErreur:
MsgBox Err.Number & " : " & Err.Description
Exit Sub

End Sub
'======================================= > *******************************************

Question II la photo est-elle dynamique ou non si le lien change ?
La photo affichée dans le commentaire sera celle que tu désigneras le
chemin dans la procédure.
*******************************************

Question III quelle pourrait être la syntaxe pour vérifier qu'il n'existe
pas de
commentaire auparavant ?
'---------------------------------
Dim C as comment
On Error Resume Next
Set C = Range("a1").Comment
If err<>0 then
err=0
Msgbox "La cellule n'a pas de commentaires"
Else
Msgbox "La cellule a déjà un commentaire"
End if
'---------------------------------

Cependant, c'est plus simple de le supprimer par :
Range("A1").ClearComments
et d'en ajouter un autre au besoin
.AddComment.Text Text:=""
*******************************************

Question IV comment vérifier si la photo existe avant d'afficher un
commentaire

Dans le haut d'un module standard, tu copie ceci :

'Déclaration des API et de la fonction
'-------------------------------------
Private Const S_FALSE = &H1
Private Const S_OK = &H0
'Only implemented as unicode...
Private Declare Function IsValidURL Lib "URLMON.DLL" _
(ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As
Long

Public Function IsGoodURL(ByVal sURL As String) As Boolean
'The IsValidURL always expects a UNICODE string, but whenever
'VB calls an API function, it converts the strings to ANSI strings.
'That's why we're going to use a trick here. Before calling the
function,
'We're going to convert the unicode string to unicode so we get a
double
'unicode string.
'Before VB calls the API function, it converts our double unicode
string
'to a normal unicode string; exactely what IsValidURL is expecting.
sURL = StrConv(sURL, vbUnicode)
'Now call the function
IsGoodURL = (IsValidURL(ByVal 0&, sURL, 0) = S_OK)
End Function
'-------------------------------------

Dans ton code, tu teste comme ceci :
'--------------------------------
Sub TesterValiditerLienHypertexte()
On Error Resume Next
With ActiveCell
x = .Hyperlinks(1).Address
If Err <> 0 Then
Err = 0
MsgBox "Cellule sans lien hypertexte"
Exit Sub
End If
If CStr(IsGoodURL(x)) Then
MsgBox "Ok le lien est bon"
Else
MsgBox "Lien n'est pas bon."
End If
End With
End Sub
'--------------------------------
*******************************************

Question V comment faire en sorte que toutes mes photos
soient de la même taille, même et surtout après un filtre ?

Tu testeras ceci ....

Salutations!

"Apprenti.xls" <apprenti.xls(a supprimer)@voila.fr> a écrit dans le
message de news: eFPe4khvFHA.1392@tk2msftngp13.phx.gbl...
Bonjour à tous !

Toujours au stade de l'apprentissage, j'ai aujourd'hui quelques
interrogations au sujet de l'affichage de commentaires.
J'ai conçu une petite procédure pour afficher une photo en commentaire en
fonction d'un numéro qui se trouve dans la colonne immédiatement à gauche.
La procédure fonctionne correctement, mais je la trouve un peu longuette
...
J'ai plusieurs questions :
1/ comment faire pour la structurer plus efficacement ?
2/ la photo est-elle dynamique ou non si le lien change ?
3/ quelle pourrait être la syntaxe pour vérifier qu'il n'existe pas de
commentaire auparavant ?
4/ comment vérifier si la photo existe avant d'afficher un commentaire ?
5/ enfin, et je vous remercie tous, d'ores et déjà, de m'avoir lu jusque
là, comment faire en sorte que toutes mes photos soient de la même taille,
même et surtout après un filtre ?

Toute aide est la bienvenue, car j'apprends, j'apprends, mais là, je butte
un peu...
À bientôt !

Voici mon code :

Sub Commentaire()
Dim I As Integer
Dim Valeur
On Error GoTo Erreur

Set Valeur = ActiveCell.Offset(0, -1)
If IsEmpty(Valeur) Then
GoTo Erreur
Else

If Valeur < 10 Then
Valeur = "0000" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 100 Then
Valeur = "000" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 1000 Then
Valeur = "00" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 10000 Then
Valeur = "0" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
End If
End If
End If
End If
End If
ActiveCell.Activate

Erreur:
ActiveCell.Activate
Exit Sub
End Sub

Vous avez filtré cet utilisateur ! Consultez son message

Merci Denis !

Une fois de plus, un nouveau coup de main. Finalement, je m'aperçois que ma
demande dans un seul fil est trop importante. J'aurais dû en créer plusieurs
et étalés dans le temps. Je teste pour l'instant ton code pour la
vérification des liens hypertextes. Cela ne fonctionne pas exactement comme
je le souhaiterais, j'essaye de l'adapter en ce moment.
Je reviendrai plus tard pour dire où j'en suis plus précisément. Je n'ai pas
accès au forum tous les jours ...

En attendant, pour le 5ème point, le seul objet de ce fil finalement,
(Comment faire en sorte que toutes mes photos soient de la même taille, même
et surtout après un filtre ?), tu as oublié de recoupier le code que tu
avais sans doute préparé ;o)

Tu testeras ceci ....

Merci encore pour ton coup de main.
J'apprends, j'apprends, j'aurais eu franchement du mal pour l'API sans aide
...
@+

"michdenis" a écrit dans le message de news:

Bonjour Apprenti.xls,

Pour ta procédure, on pourrait réduire cette dernière à ceci :

Cette présentation représente l'ensemble de tes demandes.

IMPORTANT :
Tes liens hypertextes doivent indiquer le chemin complet.

'Dans le haut du module déclaration API
'Servant à déterminer si le lien hypertexte est valide ....

'======================================= > Private Const S_FALSE = &H1
Private Const S_OK = &H0
'Only implemented as unicode...
Private Declare Function IsValidURL Lib "URLMON.DLL" _
(ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As
Long
'----------------------------------------
Public Function IsGoodURL(ByVal sURL As String) As Boolean
'The IsValidURL always expects a UNICODE string, but whenever
'VB calls an API function, it converts the strings to ANSI strings.
'That's why we're going to use a trick here. Before calling the
function,
'We're going to convert the unicode string to unicode so we get a
double
'unicode string.
'Before VB calls the API function, it converts our double unicode
string
'to a normal unicode string; exactely what IsValidURL is expecting.
sURL = StrConv(sURL, vbUnicode)
'Now call the function
IsGoodURL = (IsValidURL(ByVal 0&, sURL, 0) = S_OK)
End Function
'---------------------------
Function TestLienHypertexte(Link As String)
On Error Resume Next
If CStr(IsGoodURL(Link)) Then
TestLienHypertexte = Link
Else
TestLienHypertexte = ""
MsgBox " Ce lien hypertexte " & Link & _
" n'est pas valide."
End If
End Function
'---------------------------

Sub Commentaire()

Dim GestionErreur As String
Dim MonImage As String
Dim Sh As Shape, X As String

On Error GoTo GestionErreur
With ActiveCell
With .Offset(, -1)
If .Value <> "" Then
Select Case .Value
Case Is < 10
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 100
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 1000
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
Case Is < 10000
X = .Hyperlinks(1).Address
MonImage = TestLienHypertexte(X)
End Select
.Value = "0000" & .Value
End If
End With
.ClearComments
If MonImage = "" Then
.AddComment.Text Text:="Image non disponible."
Else
.AddComment.Text Text:=""
Set Sh = .Comment.Shape
End If
End With

If MonImage <> "" Then
With Sh
With .OLEFormat.Object
.Height = 20 'à déterminer
.Width = 40 'à déterminer
End With
.Fill.UserPicture MonImage
.Placement = xlMove
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
.OLEFormat.Object.Visible = False
.LockAspectRatio = msoTrue
.Locked = True
End With
End If
Exit Sub

GestionErreur:
MsgBox Err.Number & " : " & Err.Description
Exit Sub

End Sub
'======================================= > *******************************************

Question II la photo est-elle dynamique ou non si le lien change ?
La photo affichée dans le commentaire sera celle que tu désigneras le
chemin dans la procédure.
*******************************************

Question III quelle pourrait être la syntaxe pour vérifier qu'il n'existe
pas de
commentaire auparavant ?
'---------------------------------
Dim C as comment
On Error Resume Next
Set C = Range("a1").Comment
If err<>0 then
err=0
Msgbox "La cellule n'a pas de commentaires"
Else
Msgbox "La cellule a déjà un commentaire"
End if
'---------------------------------

Cependant, c'est plus simple de le supprimer par :
Range("A1").ClearComments
et d'en ajouter un autre au besoin
.AddComment.Text Text:=""
*******************************************

Question IV comment vérifier si la photo existe avant d'afficher un
commentaire

Dans le haut d'un module standard, tu copie ceci :

'Déclaration des API et de la fonction
'-------------------------------------
Private Const S_FALSE = &H1
Private Const S_OK = &H0
'Only implemented as unicode...
Private Declare Function IsValidURL Lib "URLMON.DLL" _
(ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As
Long

Public Function IsGoodURL(ByVal sURL As String) As Boolean
'The IsValidURL always expects a UNICODE string, but whenever
'VB calls an API function, it converts the strings to ANSI strings.
'That's why we're going to use a trick here. Before calling the
function,
'We're going to convert the unicode string to unicode so we get a
double
'unicode string.
'Before VB calls the API function, it converts our double unicode
string
'to a normal unicode string; exactely what IsValidURL is expecting.
sURL = StrConv(sURL, vbUnicode)
'Now call the function
IsGoodURL = (IsValidURL(ByVal 0&, sURL, 0) = S_OK)
End Function
'-------------------------------------

Dans ton code, tu teste comme ceci :
'--------------------------------
Sub TesterValiditerLienHypertexte()
On Error Resume Next
With ActiveCell
x = .Hyperlinks(1).Address
If Err <> 0 Then
Err = 0
MsgBox "Cellule sans lien hypertexte"
Exit Sub
End If
If CStr(IsGoodURL(x)) Then
MsgBox "Ok le lien est bon"
Else
MsgBox "Lien n'est pas bon."
End If
End With
End Sub
'--------------------------------
*******************************************

Question V comment faire en sorte que toutes mes photos
soient de la même taille, même et surtout après un filtre ?

Tu testeras ceci ....

Salutations!

"Apprenti.xls" <apprenti.xls(a supprimer)@voila.fr> a écrit dans le
message de news:
Bonjour à tous !

Toujours au stade de l'apprentissage, j'ai aujourd'hui quelques
interrogations au sujet de l'affichage de commentaires.
J'ai conçu une petite procédure pour afficher une photo en commentaire en
fonction d'un numéro qui se trouve dans la colonne immédiatement à gauche.
La procédure fonctionne correctement, mais je la trouve un peu longuette
...
J'ai plusieurs questions :
1/ comment faire pour la structurer plus efficacement ?
2/ la photo est-elle dynamique ou non si le lien change ?
3/ quelle pourrait être la syntaxe pour vérifier qu'il n'existe pas de
commentaire auparavant ?
4/ comment vérifier si la photo existe avant d'afficher un commentaire ?
5/ enfin, et je vous remercie tous, d'ores et déjà, de m'avoir lu jusque
là, comment faire en sorte que toutes mes photos soient de la même taille,
même et surtout après un filtre ?

Toute aide est la bienvenue, car j'apprends, j'apprends, mais là, je butte
un peu...
À bientôt !

Voici mon code :

Sub Commentaire()
Dim I As Integer
Dim Valeur
On Error GoTo Erreur

Set Valeur = ActiveCell.Offset(0, -1)
If IsEmpty(Valeur) Then
GoTo Erreur
Else

If Valeur < 10 Then
Valeur = "0000" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 100 Then
Valeur = "000" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 1000 Then
Valeur = "00" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
If Valeur < 10000 Then
Valeur = "0" & Valeur
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
Else
With ActiveCell
.Select
.AddComment
.Comment.Text Text:=""
End With
With ActiveCell.Comment.Shape
.Fill.UserPicture _
"http://zzzzz/" & Valeur & ".jpg"
.ScaleWidth 0.66, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.66, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
End With
End If
End If
End If
End If
End If
ActiveCell.Activate

Erreur:
ActiveCell.Activate
Exit Sub
End Sub

[vba] Taille d'un comment.shape

5 réponses

Veuillez sélectionner un problème