Forum du club des d�veloppeurs et IT Pro - Blogs - patricktoulon

un pseudo evenement Application_AfterResize

patricktoulon — Fri, 28 Jun 2019 08:36:09 GMT

bonjour a tous

juste une petite astuce pour cr�er un �v�nement AfterResize de l'application qui n'existe pas
l'�v�nement window_Resize ne fonctionnant qu'avec le Windows du classeur il est donc inutilisable pour la fen�tre application

cette m�thode demande tr�s peu de ressource puisque la surveillance se fait avec l'�v�nement on_update de la commandbars
une alternative au timer (api) ou application ontime en boucle et autre
de plus quand le update est d�clench� il est non bloquant pour le reste des macros ou l'utilisation de Excel
pour l'exemple je zoom une plage d�finie pour la garder visible enti�rement a chaque instant

a placer dans le module thisworkbook

[CODE=vba]
Option Explicit
Private WithEvents Cmbrs As CommandBars
Dim oldwidth As Double
Dim oldheight As Double
'
'evenement commandbars
Private Sub Cmbrs_OnUpdate()
With Application
.CommandBars.FindControl(ID:=2040).Enabled = Not .CommandBars.FindControl(ID:=2040).Enabled
If oldheight <> .Height Or .Width <> oldwidth Then
Application_AfterResize
End If
End With
End Sub
'
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.CommandBars.FindControl(ID:=2040).Enabled = True
End Sub
'
Private Sub Workbook_Open()
Set Cmbrs = Application.CommandBars
End Sub
'
'
Private Sub Application_AfterResize()
Dim cel As Range
Set cel = Selection
Range("A1:J30").Select
ActiveWindow.Zoom = True
oldheight = Application.Height
oldwidth = Application.Width
cel.Select
End Sub
[/CODE]

test� sur 2007

un msgbox temporaire sans boucle ontime sans wait sans api SetTimer etc.. .. dans un userform

patricktoulon — Wed, 20 Mar 2019 12:28:14 GMT

[CENTER][B][SIZE=3] collection boite de dialogue perso episode 7[/SIZE][/B][/CENTER]

[QUOTE=patricktoulon;10836043]Bonjour a tous
il y a beaucoup d'exemple sur ce sujet m[B]ais celui la n'y est pas
[/B]
je vous propose aujourd'hui avec si peu de code un :[CENTER][SIZE=3][B]un msgbox temporaire [/B][B]avec un userform
[/B][B]sans boucle!! , sans app.ontime!! , sans app.wait !! , sans api SetTimer !!! etc....
[COLOR=#b22222]ET non!! bloquant
que vous pouvez personaliser a votre gout

[/COLOR][/B][/SIZE][/CENTER]
[SIZE=3][SIZE=1]comment allons nous faireet bien dans une autre discussion qui n'avait rien a voir avec ce projet ,on m'a fait decouvrir quelque chose

[/SIZE][/SIZE]
[CENTER](((a savoir [B][I]classer la commandbars et cr�er l'evenement OnUpdate)))
[/I][/B][/CENTER]
[SIZE=3][SIZE=1]cet evenement se declenche quand on modifie un bouton dans la commandbars
mais nous alons cr�er cet evenement[B] non pas dans un module classe mais [/B]dans le userform lui meme qui sera le msgbox
apres tout il me semble avoir entendu dire que les modules userform sont des classes ;)
on va donc prendre un Userform lui mettre un textbox multiligne avec scroll vetical pour un eventuel grand texte ,avec saut de ligne
et un bouton( vous placez le textbox comme vous voulez)
pour ma part je l'ai plac� comme il est dans un msgbox classique

voyons voir une image parle mieux que des mots
[ATTACH=CONFIG]459601[/ATTACH]

[B]Maintenant que nous avons notre msgbox(X) ( je l'ai appel� [B][COLOR=#b22222]MsgBoxX[/COLOR])
[/B]
On va lui mettre ce code ci dessous

[/B][CODE]Option Explicit
Private WithEvents Cmbrs As CommandBars 'creation de l'object commandbars events
Public delay As Long ' delay d'affichage
Public title As String 'titre de la caption
Public PosX As Long 'position horizontale
Public PosY As Long ' position verticale
Dim t[/CODE][/SIZE][/SIZE][CODE]
[SIZE=3][SIZE=1]' !!!!!!!!!!!evenement commandbars!!!!!!!!!!!
Private Sub Cmbrs_OnUpdate()
Application.CommandBars.FindControl(ID:=2040).Enabled = Not Application.CommandBars.FindControl(ID:=2040).Enabled
If Timer - t >= delay - 0.5 Then Application.CommandBars.FindControl(ID:=2040).Enabled = True: Unload Me
End Sub[/SIZE][/SIZE]
[SIZE=3][SIZE=1]
'l'ecriture dans le textbox est bloqu�e
Private Sub message_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer): KeyCode = 0: End Sub[/SIZE][/SIZE]

Private Sub CommandButton1_Click(): Unload Me: End Sub ' bouton fermer
Private Sub UserForm_Activate()
Me.Caption = IIf(title <> "", title, "Message d' Alerte !!")
t = Timer
If PosX <> 0 And PosY <> 0 Then Me.Left = PosX: Me.Top = PosY
Set Cmbrs = Application.CommandBars
Application.CommandBars.FindControl(ID:=2040).Enabled = Not Application.CommandBars.FindControl(ID:=2040).Enabled' va avoir pour effet de declencher l'evenement de la commandbars
End Sub
[/CODE]

voila pour le userform

[B]voyons maintenant pour l'appel de ce [COLOR=#b22222][B]MsgBoxX[/B][/COLOR]
[/B][CODE]
Option Explicit
'model MsgBoxX
Sub test()
With MsgBoxX
With .message
.Value = "ceci est une message test!!! " & vbCrLf & "temporaire " & vbCrLf & "DEVELOPPEZ.COM"
'la ligne ci dessous est facultative c'est les options du textbox
.BackColor = vbBlue: .ForeColor = RGB(255, 200, 100): .Font.Name = "arial black"
End With
.title = "message de test !" '(facultatif)
.PosX = 50 '(facultatif)
.PosY = 100 '(facultatif)
.delay = 3 '(obligatoire)
.Show 0
End With
End Sub
[/CODE]
tout les lignes tagu�es "(facultatif)" comme le mot l'indique ne sont pas obligatoire

une petite demo avec l'affichage pendant 2 secondes

[ATTACH=CONFIG]459605[/ATTACH]
voila j'ai mon compteur Windows 7 qui bouge pas d'un poil il n'y a donc pas de consomation excessive de processeur ou memoire comme avec d'autre proc�d�s

pour info pour que ca fonctionne il faut que le userform soit non modal ([B].show [COLOR=#b22222]0[/COLOR])[/B]

merci a [URL="https://www.developpez.net/forums/u901761/rafaaj2000/"]RAFAAJ2000[/URL] de m'avoir fait decouvrir la possibilit� de cr�er cet evenement commandbars ;)
comme lui en a trouv�e une je suppose que les id�es de mise en application vont fleurir ( partagez)

qu'en pensez vous

[SIZE=3]
[SIZE=1]

[/SIZE][/SIZE][/QUOTE]

Images attach�es

collection boite de dialogue perso episode 6

patricktoulon — Sun, 10 Feb 2019 15:43:35 GMT

[I][B][COLOR=#b22222][SIZE=2] collection boite de dialogue perso episode 6
[/SIZE][/COLOR][/B][/I]
un calendrier dans son propre formulaire utilisable sur sheets ou textbox et combobox

et si au click droit sur cellule on avait un calendrier qui s'affiche pour mettre la date choisi dans celles ci

et si au click droit sur un textbox on avait le calendrier qui s'affiche pour choisir une date

et pareil dans une combobox a fin de ne pas etre oblig� de derouler des kilometres une combo pour choisir une date

et si on avait la possibilit� de choisr sans sub ou fonction suplementaire le format de sortie

et si il semettais en francais ou en US(anglais) en fonction de la region parametr�e dans le system

je vous propose cette version de mon calendrier dans un userform

elle peut vous sortir les 3 format application.international(xldateorder )

et un dernier qui se contente de vous sortir la date en fonction de celle du system automatiquement

je rapelle qu'il es question ici d'avoir un calendrier dispo meme pour ceux qui sont en 64 bits
etant donn� que je n'utilise toujours pas de control calendart et autre datepicker ,seulement des controls generiques dispos dans toute versions d'excel
methode d'utilisation dans un sheets

[CODE]Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim dat
If Target.Column = 1 And Target.Cells.Count = 1 Then
Cancel = True
With Calendrier
Set .Destination = Target
.Show
If .DateResult <> False Then Target = .DateResult
Unload Calendrier
End With
End If
End Sub
[/CODE]

[ATTACH=CONFIG]448779[/ATTACH]

exemple d'utilisation dans des textbox d'un userform sous divers format

[ATTACH=CONFIG]448783[/ATTACH]
[CODE]Option Explicit
'

Private Sub ComboBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then
With Calendrier
Set .Destination = ComboBox1
.Show

If .DateResult <> False Then ComboBox1.Value = .DateResult: If ComboBox1.ListIndex = -1 Then ComboBox1.Value = "Nofound!!"
Unload Calendrier
End With
End If
End Sub
'
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer): KeyCode = 0: End Sub
Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then
With Calendrier
Set .Destination = TextBox1
.Show
If .DateResult <> False Then TextBox1.Value = .DateResult
Unload Calendrier
End With
End If
End Sub
'
Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer): KeyCode = 0: End Sub
Private Sub TextBox2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then
With Calendrier
Set .Destination = TextBox2
.region = 0
.Show
If .DateResult <> False Then TextBox2.Value = .regionDate0
Unload Calendrier
End With
End If
End Sub
'
Private Sub TextBox3_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer): KeyCode = 0: End Sub
Private Sub TextBox3_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then
With Calendrier
Set .Destination = TextBox3
.separateur = "-"
.region = 2
.Show

If .DateResult <> False Then TextBox3.Value = .regionDate2
Unload Calendrier
End With
End If
End Sub

'
Private Sub TextBox4_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then
With Calendrier
Set .Destination = TextBox4
.region = 1
.separateur = "-"
.Show

If .DateResult <> False Then TextBox4.Value = .regionDate1
Unload Calendrier
End With
End If
End Sub
[/CODE]
exemple en piece jointe

Images attach�es

Fichiers attach�s

forcer la saisie de date avec masque dynamique

patricktoulon — Thu, 01 Nov 2018 16:15:44 GMT

[CENTER][B]UN DATEBOX MULTI FORMAT DYNAMIQUE AVEC MASQUE DE SAISIE
EPISODE 1[/B][/CENTER]

bonjour a tous
c'est un exercice qui a �t� compliqu� au depart et nombreux ont �t� les essais qui ont pu sortir de ma tete et bien mal pens�s

[B]cahier des charges pour ce projet
[/B]
[LIST=1][*][B]imposer et avoir le choix [/B]un format de date dans un textbox[*]avoir un [B]masque [/B]de saisie en l'occurence("__/__/____")[*][B]restreindre[/B] l'utilisation des touches ( pav� numerique (haut du clavier ou pav� a droite du clavier)) ,la touche back , suppr, fleche(droite et gauche)[*][B]avertir et annuler[/B] la frappe quand une date (completement r�dig�e ou pas) est �ron�e[*][B]mise en evidence [/B]de l'erreur en selectionnant la partie de la date ou partie de date tap�e en erreur[*][B]utilisation minimum [/B]de variable globale[B] voir pas du tout [/B](economie memoire)[*][B]pouvoir naviguer [/B]entre les parties de la date avec les touche de navigation(TAB et fleches)[*][B]revenir en arriere[/B] avec la [B]touche back [/B]avec remise en place de la partie homologue du mask[*][B]transportabilit� [/B][*]que ce ne soit pas une [B]usine a gaz [/B][*]j'ai mis en place le masque des la premiere touche tap�e quelle quel soit ( vous n'avez donc pas a le mettre en mode edition dans VBE)[/LIST]

bref rendre impossible de taper une date eronn�e sans en etre averti

et cela avec un seul evenement textbox (dans cet exercice j'ai choisi le [B]keydown)[/B]

il y a divers exemple ici et la je vous laisse le soins d'en apprecier leur valeur en fonction du meme cahier des charges

pour que ce code puisse servir a plusieur textboxs sur un meme [B]userform [/B]je l'ai fait dans une sub que l'on mettra dans un module standard

rien ne vous empeche cela dit d'en faire une private sub et la mettre dans le [B]module du userform[/B]

j'ai a�r� le code pour plus d'aisance dans la lisibilit� du code

voila donc la sub
[CODE=vba]Option Explicit
'Date:01/10/2018
'auteur:-------------------------patricktoulon sur developpez.com et excel download
'projet:-------------------------datebox multi format avec mask de saisie dynamique au format inject� dans l'appel
'version:------------------------3.2
'format de date accept�:---------"dd/mm/yyyy" : "mm/dd/yyyy" : "yyyy/mm/dd"
'touche clavier utilisable:------TAB :ENTER :FLECHES (DROITE et GAUCHE) : pav� numerique (HAUT et BAS)
'action 1:-----------------------positionnement automatique pendant la saisie
'action 2:-----------------------navigation dans les parties de la date(jour/mois/ann�e)avec les touches TAB et fleches(droite et gauche)
'action 3:-----------------------retour et selection automatique en cas d'erreur dans la partie qui viend d'etre tap�e
'modifications:le 07/10/2018-----ajout du Rollover sur les touches de navigation(ergonomie)
'modifications le 08/10/2018-----am�lioration de la gestion des touches de navigation et de la touche back(ergonomie)(le next segment pris en compte au selstart+1)
'modifications le 08/10/2018-----ajout du test si le format inject� n'est pas accept� et de la sortie avec message
'modifications le 12/10/2018-----correction l'erreur non relev�e du "00" mois et jour

Sub control_saisiex(txt, KeyCode, Optional Forme As String = "dd/mm/yyyy")
Dim t$, xL&, X&, M&, J&, A&, Ji&, Mi&, Ai&, finD&, ldate As Date, MasK$
'calcul des selstart autoris�s pour le keycode 96 to 105 en fonction du format
Ji = InStr(1, Forme, "d"): Mi = InStr(1, Forme, "m"): Ai = InStr(1, Forme, "y")
'Cr�ation du mask en fonction du format inject� dans l'apel
If Ai = 7 Then finD = 6 Else finD = 8 'repere pour le next selstart avec les touches de navigation
Select Case Forme
Case "yyyy/mm/dd": MasK = "____/__/__": Case "dd/mm/yyyy", "mm/dd/yyyy": MasK = "__/__/____"
Case Else: MsgBox "le format demand� n'est pas accept�": KeyCode = 0: Exit Sub 'si un format inject� nest pas valide on sort
End Select
With txt
If .Value = "" Then .Value = MasK 'au cas ou le masque n'y serait pas au depart
t = .Value 'T prend la valeur du textbox
If TypeName(.Parent) = "UserForm" Then .ControlTipText = Forme ' bulle indiquant le format qui a �t� inject�
If t = MasK Then .SelStart = 0 ' on se positionne a gauche si pas de date(mask vierge)
X = .SelStart: xL = .SelLength 'on determine la position et le length de la selection
If KeyCode >= 48 And KeyCode <= 57 Then KeyCode = KeyCode + 48 ' pour ce qui n'ont pas le pav� numerique et se servent des chiffre en haut de clavier
Select Case KeyCode
'_____________________________________________________________________________________________________
'Gestion des touches du pav� numerique(haut et bas)
Case 96 To 105
Select Case X
Case Ji - 1 To Ji, Mi - 1 To Mi, Ai - 1 To Ai + 2
Mid$(t, X + 1, IIf(xL = 0, 1, xL)) = Chr(KeyCode - 48) & Mid$(MasK, X + 2): .Value = t: .SelStart = X + 1
Case Else: KeyCode = 0
End Select
If Mid$(t, X + 2, 1) = "/" Then .SelStart = X + 2
KeyCode = 0
'_______________________________________________________________________________________
'controle de la validit� de la date ici
J = Val(Mid$(t, Ji, 2)): M = Val(Mid$(t, Mi, 2)): A = IIf(Mid$(t, Ai, 4) Like "*_*", 2000, Val(Mid$(t, Ai, 4))) 'r�cuperation du jour mois ann�e en fonction de l'etat de la saisie
J = IIf(J = 0, 1, J): M = IIf(M = 0, 1, M): ldate = DateSerial(A, M, J): 'date th�orique ou reele dynamique
If Day(ldate) <> J Or Month(ldate) <> M Or Year(ldate) <> A Or Val(Mid$(t, Ji, 1)) > 3 Or Val(Mid$(t, Mi, 1)) > 1 Or Mid$(t, Ji, 2) = "00" Or Mid$(t, Mi, 2) = "00" Then 'Condition d 'erreur globale
X = InStrRev(Mid$(t, 1, X), "/"): xL = IIf(X = Ai - 1, 4, 2): Mid(t, X + 1, xL) = Mid(MasK, X + 1, xL): .Value = t: .SelStart = X: .SelLength = xL: Beep 'repositionnement et annulation de la partie en erreur
End If
'_____________________________________________________________________________________________________
'Gestion de la Touche back(retours en arri�re)
Case 8
If InStr(Mid$(t, 1, X), "/") > 0 Then X = InStrRev(Mid$(t, 1, InStrRev(Mid$(t, 1, X), "/") - IIf(Mid(t, X, 1) = "/", 1, 0)), "/") Else X = 0
KeyCode = 0: xL = IIf(X = Ai - 1, 4, 2): Mid$(t, X + 1, xL) = "____": .Value = t: .SelStart = IIf(t = MasK, 0, X): .SelLength = IIf(t = MasK, 0, xL)
'_____________________________________________________________________________________________________
'Gestion de la Touche suppr(supprimer)remplace la partie selectionn�e par son homologue du masque
Case 46
xL = IIf(xL = 0, 1, xL): KeyCode = 0: Mid$(t, X + 1, xL) = Mid$(MasK, X + 1, xL): .Value = t: .SelStart = IIf(t = MasK, 0, X)

'_____________________________________________________________________________________________________
'gestion de la Touche fleche gauche deplacement vers la gauche et Rollover
Case 37
KeyCode = 0: X = InStrRev(t, "/", IIf(X = 1, 2, X - 1)): xL = IIf(X = Ai - 1, 4, 2):
.SelStart = IIf(t = MasK, 0, X): .SelLength = IIf(t = MasK, 0, xL)

'_____________________________________________________________________________________________________
'Gestion de la Touche fleche droite et la touche tab deplacement vers la droite et Rollover
Case 39, 9
If InStr(Mid$(t, X + 1), "/") > 0 Then X = X + InStr(1, Mid$(t, X + 1), "/") Else X = 0 'x=find si on veut pas que ca tourne
KeyCode = 0: .SelStart = IIf(t = MasK, 0, X): .SelLength = IIf(t = MasK, 0, IIf(X = Ai - 1, 4, 2))
Case 13
If InStr(txt.Value, "_") Then KeyCode = 0
'_____________________________________________________________________________________________________
'Gestion des autres touches
Case Else: KeyCode = 0
End Select
End With
End Sub
[/CODE]

et donc dans le userform OUpour un textbox dans un sheets on l'appelera comme suit avec l'evenement [B]keydown
exemple :
[/B][CODE=vba]Option Explicit
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
control_saisiex TextBox1, KeyCode, "yyyy/mm/dd"
End Sub
Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
control_saisiex TextBox2, KeyCode, "dd/mm/yyyy"
End Sub
Private Sub TextBox3_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
control_saisiex TextBox3, KeyCode, "yyyy/mm/dd"
End Sub
Private Sub TextBox4_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
control_saisiex TextBox4, KeyCode 'sans argument le format par defaut est francais
End Sub

[/CODE]

pour le cas ou avec la souris on clique sur un autre control et donc sortie du textbox en ayant pas une date correcte
on bloque la sortie avec le before update
mais ca reste a la charge du developpeur: en effet les possibilit� en fonction de la sortie peuvent etre diverses et vari�e
le travaille ici a consist� uniquement a controler la saisie

mais bien que l'on sorte de mon projet qui est l'utilisation du keydown , il est interessant et utile de le proposer
un exemple selon pijaku :
[CODE=vba]Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Cancel = Not IsDate(TextBox1.Value)
End Sub
[/CODE]

et pour proteger le textbox contre la modification par vba

[CODE=vba]Private Sub TextBox1_Change()
If TextBox1 <> ActiveControl Then
If Not IsDate(TextBox1.Value) Then TextBox1.Value = "__/__/____"
End If
End Sub
[/CODE]

Merci pijaku pour les tests

un classeur en exemple en piece jointe

Fichiers attach�s

Ma collection de boite de dialogue perso episode 2

patricktoulon — Fri, 28 Sep 2018 14:13:15 GMT

[CENTER][B]Episode 2[/B]
[COLOR=#b22222][SIZE=2][B]Un calendrier dynamique simple

[/B][/SIZE][/COLOR][/CENTER]
apres moulte versions dans la meme serie a savoir dans un userform dynamiquement cr�� voici le pseudo calendar
la encore je n'utilise pas de module classe tout est dans la fonction

[LIST=1][*]creation de l'userform[*]des bouton et listbox[*]ecriture du code[/LIST]

la aussi rien n'existe avant /rien n'existe apres autrement dit le fichier ne reste pas parasit� par des modules classe ou userforms inutiles

[CODE=vba]Option Explicit
'**********************************************************************************************
' COLLECTION DE BOITES DE DIALOG PERSO *
' modele: calandrier dynamique *
' version 4.0 07/02/2017 sans module classe *
' author: patricktoulon sur DVP.com ;alias chamalin2@hotmail.com *
'**********************************************************************************************
Function calendrier()
Dim UsF, ObJ, i&, L&, Jo, J&, t&
Set UsF = ThisWorkbook.VBProject.VBComponents.Add(3)
With UsF
.Properties("Caption") = "choisir une date": .Properties("Width") = 130: .Properties("Height") = 150:
.Properties("Backcolor") = RGB(230, 230, 230)
Set ObJ = UsF.Designer.Controls.Add("Forms.ComBobox.1")
With ObJ: .Left = 5: .Top = 5: .Width = 60: .Height = 15: .Name = "mois": .ListRows = 12: End With
Set ObJ = UsF.Designer.Controls.Add("Forms.ComBobox.1")
With ObJ: .Left = 70: .Top = 5: .Width = 55: .Height = 15: .Name = "an": End With
Jo = Array(, "lun", "mar", "mer", "jeu", "ven", "sam", "dim")
L = -12:
For i = 1 To 7
L = L + 17
Set ObJ = UsF.Designer.Controls.Add("Forms.Label.1")
With ObJ: .Left = L: .Top = 22: .Width = 15: .Height = 13: .Name = "tj" & i: .BorderStyle = 0:
.Caption = UCase(Jo(i)): .BackColor = RGB(100, 100, 200): .ForeColor = vbWhite: .TextAlign = 2
End With
Next

L = -12: t = 37
For i = 0 To 41
L = L + 17: If L >= 119 Then L = 5: t = t + 15
Set ObJ = UsF.Designer.Controls.Add("Forms.Label.1")
With ObJ: .Left = L: .Top = t: .Width = 15: .Height = 13: .Name = "jour" & i + 1:
.BorderStyle = 1: .BackColor = RGB(150, 150, 150): .ForeColor = vbWhite: .TextAlign = 2
End With
Next
With .CodeModule
J = .countoflines
.insertlines J + 1, "public madate as variant"
J = .countoflines
.insertlines J + 1, "function nbjours ( A&,M&)" & vbCrLf & "nbjours = Day(DateSerial(A, M+1 , 0) )" & vbCrLf & "End Function"
J = .countoflines
.insertlines J + 1, "Private Sub UserForm_Activate()" & vbCrLf & "Dim i&" & vbCrLf & _
"With Me.an: .List = Evaluate(""ROW("" & 1 & "":"" & Year(Date) + 100 & "")""): .Value = Year(Date): End With" & vbCrLf & _
"With mois: For i = 1 To 12: .AddItem Format(""01/"" & i & ""/2018"", ""mmmm""): Next: .Value = Format(Date, ""mmmm""): End With" & vbCrLf & "End Sub"
J = .countoflines
.insertlines J + 1, "Private Sub grille(A, M&)" & vbCrLf & "Dim NBJ&, x&,i&" & vbCrLf & "NBJ = nbjours(Val(A), M)" & vbCrLf _
& "For i = 1 To 42: Me.Controls(""jour"" & i).Caption = """": Next" & vbCrLf _
& "x = Weekday(DateSerial(A, M, 1), vbUseSystemDayOfWeek) - 1" & vbCrLf _
& "For i = 1 To NBJ: With Me.Controls(""jour"" & i + x): .Caption = i: .BackColor = &H969696: .ForeColor = vbYellow: .TextAlign = 2: End With: Next" & vbCrLf _
& "With Me.Controls(""jour"" & Day(Date) + x): If M = Month(Date) And A = Year(Date) Then .BackColor = vbWhite: .ForeColor = vbRed" & vbCrLf & "End With" & vbCrLf & "End Sub"
J = .countoflines
.insertlines J + 1, "Private Sub mois_Change()" & vbCrLf & "grille val(an.Value), mois.ListIndex + 1" & vbCrLf & "End Sub"
J = .countoflines
.insertlines J + 1, "Private Sub an_Change()" & vbCrLf & "grille val(an.Value), mois.ListIndex + 1" & vbCrLf & "End Sub"
J = .countoflines
.insertlines J + 1, "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)" & vbCrLf _
& "If CloseMode = 0 Then Cancel = True: madate = False: Me.Hide" & vbCrLf & "End Sub"
J = .countoflines
For i = 1 To 42
J = .countoflines
.insertlines J + 1, "Private Sub jour" & i & "_Click()" & vbCrLf & " If jour" & i & ".Caption <> """" Then madate = DateSerial(an.Value, mois.ListIndex + 1, jour" & i & ".Caption): Me.Hide" & vbCrLf & "End Sub"
Next
End With
End With
VBA.UserForms.Add (UsF.Name)
With UserForms(UserForms.Count - 1)
.Show
calendrier = .madate
End With
ThisWorkbook.VBProject.VBComponents.Remove (UsF)
End Function[/CODE]
[B]pour tester[/B]
[CODE=vba]Sub test()
Dim madate As Variant
madate = calendrier
MsgBox madate
End Sub[/CODE]

ici aussi le projet doit etre approuv�
[B]S�curit� des macros>Param�tres des macros> cocher la case "Acc�s approuv� au mod�le d'objet du projet VBA".[/B]

ma collection de boites de dialogue perso

patricktoulon — Fri, 28 Sep 2018 06:54:16 GMT

[CENTER]
Contrairement a mon abitude de travailler avec des classes j'ai pris un chemin different sur ce theme
les fonctions qui vont suivre concernant des boites de dialogue perso n'utilisent pas de module classe
tout est cr�e dynamiquement (userform ,controls,code)
rien n'existe avant fonction ,rien n'existe apres que la fonction ai fait son job
tout se passe dans la fonction dans un module standard

[B]episode 1[/B]
[B]
Boite de dialogue pour changer l'imprimante par defaut de windows ([COLOR=#800000]ne change en rien les parametres d'excel[/COLOR])

[/B][/CENTER]
il peut nous arriver de devoir imprimer un ou une liste de fichiers externes sur une imprimante precise
pour cela il nous faut determiner cette imprimante par defaut
donc voici une petite boites de dialogue perso dans un userform qui peut vous permettre de le faire

[CODE=vba]Option Explicit
'**********************************************************************************************
' COLLECTION DE BOITES DE DIALOG PERSO *
' modele: dialog selection d'imprimante par defaut dans les parametres WINDOWS pas excel *
'Utile quand on veut imprimer un fichier externe a l'application sur imprimante particuliere *
' version 1.0 :-: Date:22/09/2018 *
' author: patricktoulon sur DVP.com ;alias [EMAIL="chamalin2@hotmail.com"]chamalin2@hotmail.com[/EMAIL] *
'**********************************************************************************************
Sub test()
Dim imprimante
imprimante = open_dialog_Windows_printer
MsgBox imprimante
End Sub
Function open_dialog_Windows_printer() As Variant
Dim ObJ As Object, J%, UsF
Dim colItems As Object, objItem As Object
Set UsF = ThisWorkbook.VBProject.VBComponents.Add(3)
With UsF
.Properties("Caption") = "Choisir une Imprimante Windows": .Properties("Width") = 250: .Properties("Height") = 120:
.Properties("Backcolor") = RGB(230, 230, 230)
Set ObJ = UsF.Designer.Controls.Add("Forms.ListBox.1")
With ObJ: .Left = 5: .Top = 5: .Width = UsF.Properties("Width") - 15: .Height = UsF.Properties("Height") - 40: .Name = "liste": .BackColor = vbWhite
.ColumnCount = 2
End With
Set ObJ = UsF.Designer.Controls.Add("Forms.CommandButton.1")
With ObJ: .Left = 250 - 70: .Top = 120 - 42: .Width = 60: .Height = 20: .Name = "annuler": .Caption = "annuler": .BackColor = RGB(220, 220, 250): End With
Set ObJ = UsF.Designer.Controls.Add("Forms.CommandButton.1")
With ObJ: .Left = 250 - 140: .Top = 120 - 42: .Width = 60: .Height = 20: .Name = "Choisir": .Caption = "Choisir": .BackColor = RGB(150, 250, 150): End With
With .CodeModule
J = .countoflines
.insertlines J + 1, ""
.insertlines J + 2, "public newprinter as variant"
.insertlines J + 3, "'"
.insertlines J + 4, "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)"
.insertlines J + 5, "Cancel=true:newprinter=false: Me.Hide "
.insertlines J + 6, "End Sub" & vbCrLf & "'"
.insertlines J + 7, "Private Sub annuler_Click():newprinter=false:me.hide :end sub "
.insertlines J + 8, "Private Sub choisir_Click()"
.insertlines J + 10, "Dim imprim as object"
.insertlines J + 11, "If liste.value <> """" Then"
.insertlines J + 12, "Set imprim = CreateObject(""WScript.Network""): imprim.SetDefaultPrinter liste.value"
.insertlines J + 13, "newprinter = liste.Value: Me.Hide"
.insertlines J + 14, "Else"
.insertlines J + 15, "MsgBox ""vous devez en selectionner une !!"""
.insertlines J + 16, "End If"
.insertlines J + 17, "End Sub"
End With
End With
VBA.UserForms.Add (UsF.Name)
With UserForms(UserForms.Count - 1)
Set colItems = GetObject("winmgmts:\\.\root\cimv2").ExecQuery("Select * from Win32_Printer", , 48)
With .liste
For Each objItem In colItems
.AddItem objItem.Name: .List(.ListCount - 1, 1) = IIf(objItem.Default = True, "Par defaut", "----------")
Next
End With
.Show
open_dialog_Windows_printer = .newprinter
End With
ThisWorkbook.VBProject.VBComponents.Remove (UsF)
End Function

[/CODE]
[ATTACH=CONFIG]415617[/ATTACH]

petite precision importante
le project doit etre approuv�
[B]S�curit� des macros>Param�tres des macros> cocher la case "Acc�s approuv� au mod�le d'objet du projet VBA".
[/B]merci pijaku pour le rappel[B];)
[/B]

Images attach�es