Astuce du jour: Palette de couleur sur le click droit

MJ13 · 7 Mars 2013

Astuce du jour: Copier Coller Valeur Format...

Bonjour à tous

Voici le plan des différentes astuces présentes dans cette discussion (Mise à Jour le 21 03 2014):

Encadre Tableau

Mise en page feuille

Redimensionnement d'images

Capture Ecran

Encadrement tableau

Tri Tableau

Installer sur Win8 64 bits programmes anciens

Lancer nouvelle instance d'Excel

Astuces pour le forum

Supprimer les lignes en trop

Recherche Rapide Google

Tri Ascendant Descendant

Range Dossier suivant extension des fichiers V1 et V2

Résolution Ecran

Palette de couleur sur le click droit

Programmer le Bouton Marche/Arrêt

Résoudre le problème des Litviews

Copier Coller valeur format...

Quand , on programme en VBA, avec l'enregistreur de macros, on a souvent des lignes de codes superflues .

En essayant de trouver un moyen simple pour encadrer un tableau de toutes les cellules on peut écrire:

Code VBA:
Selection.Borders.LineStyle = xlContinuous

Au lieu de:

Code VBA:
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

Je voulais le partager avec vous pour une fois que je trouve une astuce intéressante .

MJ13 · 14 Décembre 2013

Re : Astuce du jour: Résolution Ecran

Bonjour David, Jean-Claude

Merci David pour ce code.

Sur Xl2007 et Win 8 pro, j'ai mis ce code avec le width avant le height :

Code:

Sub ResolutionEcran()
 strComputer = "."
 Set objWMIService = GetObject( _
     "winmgmts:\\" & strComputer & "\root\cimv2")
 Set colItems = objWMIService.Execquery( _
     "Select * from Win32_DesktopMonitor")
 For Each objItem In colItems
     MsgBox "Résolution de l'écran : " & objItem.Screenwidth & " x " & _
     objItem.Screenheight & vbCrLf: Exit Sub
 Next
 Set objWMIService = Nothing
 Set colItems = Nothing
 End Sub

Par contre, vous ne savez pas si on peut changer la résolution de l'écran à partir d'excel?

david84 · 14 Décembre 2013

Re : Astuce du jour: Résolution Ecran

Re

@Jean-Claude : bizarre...teste le fichier de cette discussion à laquelle tu avais participée : quel résultat as-tu lorsque tu cliques sur Résolution d'écran ?

@Michel :

Sur Xl2007 et Win 8 pro, j'ai mis ce code avec le width avant le height :

Code VBA:
Sub ResolutionEcran()
strComputer = "."
Set objWMIService = GetObject( _
"winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.Execquery( _
"Select * from Win32_DesktopMonitor")
For Each objItem In colItems
MsgBox "Résolution de l'écran : " & objItem.Screenwidth & " x " & _
objItem.Screenheight & vbCrLf: Exit Sub
Next
Set objWMIService = Nothing
Set colItems = Nothing
End Sub

Je pense que l'Exit Sub n'est pas nécessaire.

Par contre, vous ne savez pas si on peut changer la résolution de l'écran à partir d'excel?

Tu parles bien du fait de modifier la résolution d'écran obtenue via le panneau de configuration ?
J'attends ta confirmation pour regarder de mon côté.
En passant par du WMI c'est possible sur le principe de modifier certains paramètres Windows mais encore faut-il que les propriétés de la classe sur lesquelles tu veux agir te le permettent or dans le cas présent les propriétés ScreenHeight et ScreenWidth de la classe Win32_DesktopMonitor sont en lecture seule...
J'attends que tu me confirmes si l'on s'est bien compris pour éventuellement regarder s'il existe d'autres classes qui possèdent ce type de propriété mais sur lesquelles on pourrait agir.
A+

MJ13 · 14 Décembre 2013

Re : Astuce du jour: Résolution Ecran

Re

Tu parles bien du fait de modifier la résolution d'écran obtenue via le panneau de configuration ?
J'attends ta confirmation pour regarder de mon côté.
En passant par du WMI c'est possible sur le principe de modifier certains paramètres Windows mais encore faut-il que les propriétés de la classe sur lesquelles tu veux agir te le permettent or dans le cas présent les propriétés ScreenHeight et ScreenWidth de la classe Win32_DesktopMonitor sont en lecture seule...
J'attends que tu me confirmes si l'on s'est bien compris pour éventuellement regarder s'il existe d'autres classes qui possèdent ce type de propriété mais sur lesquelles on pourrait agir.

Oui, David, c'est cela. Mais, si c'est trop compliqué, laisse tomber.

Merci .

JCGL · 14 Décembre 2013

Re : Astuce du jour: Résolution Ecran

Bonjour à tous,

David : Le test avec le code de ton #47 (basé sur un code de Michel XLD) :

Cela ne correspond pas à la capture d'écran du Panneau de Configuration... (deuxième image de mon message # 45).

A++ l'ami
A+ à tous

MJ13 · 14 Décembre 2013

Re : Astuce du jour: Résolution Ecran

Re

Jean-Claude: il y a une différence entre les 2 codes que j'ai pris du fichier de David dans le lien ICI (je ne connais le pas lien par rapport au fichier de MichelXLD ). Et dans mon cas, le premier donne comme toi, mais le second fonctionne .

Mais tu peux tester en remplaçant Win32 par Win64.

Code:

Sub ResolutionEcran()
strComputer = "."
Set objWMIService = GetObject( _
    "winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.Execquery( _
    "Select * from Win32_DisplayControllerConfiguration")
For Each objItem In colItems
MsgBox objItem.Videomode
Next
Set objWMIService = Nothing
Set colItems = Nothing
End Sub

Sub ResolutionEcran2()
 strComputer = "."
 Set objWMIService = GetObject( _
 "winmgmts:\\" & strComputer & "\root\cimv2")
 Set colItems = objWMIService.Execquery( _
 "Select * from Win32_DesktopMonitor")
 For Each objItem In colItems
 MsgBox "Résolution de l'écran : " & objItem.Screenwidth & " x " & _
 objItem.Screenheight & vbCrLf': Exit Sub
 Next
 Set objWMIService = Nothing
 Set colItems = Nothing
 End Sub

david84 · 14 Décembre 2013

Re : Astuce du jour: Résolution Ecran

Re

Cela ne correspond pas à la capture d'écran du Panneau de Configuration... (deuxième image de mon message # 45).

Oui je sais (je pense que l'un correspond à la résolution de l'écran et l'autre à sa définition) mais je voulais surtout savoir si tu ramenais un résultat ou pas pour vérifier si le WMI était fonctionnel sur ton ordinateur.
Est-ce qu'en passant par des API c'est mieux (même si cela plante au 1er essai après avoir collé le code dans le module relance le code une 2ème fois) :

Code:

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If

Sub AfficherResolution()
Dim Largeur As Long, Hauteur As Long
Largeur = GetSystemMetrics(0)
Hauteur = GetSystemMetrics(1)
MsgBox "La résolution de votre écran est de " & Largeur & " par " & Hauteur
End Sub

Code normalement compatible avec une version Excel 32 ou 64 bits.

Oui, David, c'est cela. Mais, si c'est trop compliqué, laisse tomber.

Tant que je n'ai pas essayé je ne saurai pas si c'est compliqué ou pas .
Ceci dit c'est quoi l'objectif au juste ? Dans quel but as-tu besoin de ces infos ?
A+

JCGL · 14 Décembre 2013

Re : Astuce du jour: Résolution Ecran

Bonjour à tous,

Michel (avec l'environnement donné précédemment) :

Ceci :

VB:

ub ResolutionEcran()
strComputer = "."
Set objWMIService = GetObject( _
    "winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.Execquery( _
    "Select * from Win32_DisplayControllerConfiguration")
For Each objItem In colItems
MsgBox objItem.Videomode
Next
Set objWMIService = Nothing
Set colItems = Nothing
End Sub

Donne cela :

A+ à tous

david84 · 14 Décembre 2013

Re : Astuce du jour: Résolution Ecran

En attendant la précision à la question posée dans le message #51, j'ai trouvé un code de Laurent Longre sur le site exelabo :

Ce lien n'existe plus

Testé et approuvé (trop fort ce Laurent !) : ce code modifie la résolution de ton ordinateur à partir d'Excel.
Mais bon, teste sur un ordi "accessoire" si tu as (au cas où).
Ceci-dit est-ce vraiment cela que tu voulais ?

@Jean-Claude : as-tu testé le code du message #51 ?
A+

MJ13 · 14 Décembre 2013

Re : Astuce du jour: Résolution Ecran

Re

JC: Essaye plutôt le second code avec Win64 dans le post 50, mais pas sur que cela fonctionne?

Sinon pour changer la résolution de l'écran, en farfouillant sur le net, j'ai trouvé ceci issu d'un post de Jercaz sur XLD. Sur WIn 8 Pro et Xl 2007, cela fonctionne .

Merci à vous 2 pour vos contributions et tests .

Bon Week-end.

PS: En effet David, après relecture, cela doit être le code de Larent Longre, merci à lui .

david84 · 14 Décembre 2013

Re : Astuce du jour: Résolution Ecran

Un code qui te permet de lister les différentes configurations disponibles sur ton système d'exploitation : résolutions horizontale et verticale, fréquence de rafraîchissement, nombre de paramètres de couleurs :

Code:

Sub ModesVideo()
Dim i&, T(), strComputer As String
strComputer = "."
Set objWMIService = GetObject( _
"winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.Execquery( _
"Select * from CIM_VideoControllerResolution")

For Each objItem In colItems
    ReDim Preserve T(i)
    T(i) = objItem.Caption & vbCrLf: i = i + 1
Next

[A1].Resize(UBound(T)) = Application.Transpose(T)
Set objWMIService = Nothing
Set colItems = Nothing
End Sub

A+

MJ13 · 15 Décembre 2013

Re : Astuce du jour: Résolution Ecran

Re

Merci David pour ce dernier code.

Sinon pour Jean-Claude avec les code du post 50, sur un PC Win 8.1 en 64 bits et XL2007 32 Bits, le premier code me donne 1024*768 60 Hertz donc faux et le second un x puis la bonne définition 1368*768 .

Peut-être un problème d'Office 2013.

Roland_M · 15 Décembre 2013

Re : Astuce du jour: Résolution Ecran

bonjour à tous,

j'ai retrouvé dans ma besace un utilitaire du genre
avec les routines en question qu'il suffit de récupérer !
si ça peut aider !?

et aussi ceci qui est régulièrement demandé !
encore récemment je ne me souviens plus qui !?

récupérer le no ou la lettre d'une colonne !?

Code:

Sub LettreEtNumeroDeColonne()
C = 250 '< ex ici avec 250

A$ = Columns(C).Address
L$ = Mid(A$, InStr(A$, ":") + 2)
C = Cells(1, L$).Column

MsgBox L$ & vbLf & C
End Sub

MJ13 · 15 Décembre 2013

Re : Astuce du jour: Résolution Ecran

Bonjour Roland

Merci pour ces trouvailles .

Je l'ai repris en ajoutant un bouton et on peut choisir la résolution en indiquant ceux que l'on veux (j'aime bien que les programmes fonctionnent du premier coup ).

Roland_M · 15 Décembre 2013

Re : Astuce du jour: Résolution Ecran

re

salut à toi MJ13

ici il ne s'agit pas d'un programme mais de routines que l'on incorpore et adapte à ses besoins !

MJ13 · 15 Janvier 2014

Re : Astuce du jour: Palette de couleur sur le click droit

Bonjour à tous

Merci à tous pour ces derniers développements sur la résolution de l'écran .

Aujourd'hui, je vous propose un fichier pour avoir une palette de couleur qui se déclencehe sur le click droit dans une feuille. J'ai pu rassembler divers codes trouvé sur XLD et sur le net pour vous montrer ce petit utilitaire assez fun.

Astuce du jour: Palette de couleur sur le click droit

MJ13

XLDnaute Barbatruc

MJ13

XLDnaute Barbatruc

david84

XLDnaute Barbatruc

MJ13

XLDnaute Barbatruc

JCGL

XLDnaute Barbatruc

Pièces jointes

MJ13

XLDnaute Barbatruc

david84

XLDnaute Barbatruc

JCGL

XLDnaute Barbatruc

Pièces jointes

david84

XLDnaute Barbatruc

MJ13

XLDnaute Barbatruc

Pièces jointes

david84

XLDnaute Barbatruc

MJ13

XLDnaute Barbatruc

Roland_M

XLDnaute Barbatruc

Pièces jointes

MJ13

XLDnaute Barbatruc

Pièces jointes

Roland_M

XLDnaute Barbatruc

MJ13

XLDnaute Barbatruc

Pièces jointes

Discussions similaires