XL 2016 VBA - OLEObjects.add fait perdre les valeurs des variables globales de tous les Modules

[Dudu2]

Bonjour,

J'avais déjà remarqué ce phénomène étrange et excessivement gênant lorsqu'on veut partager des variables entres plusieurs fonctions.
Si on déclare et valorise des variables au niveau d'un ou plusieurs Modules et que dans un des Modules on créé une ComboBox de feuille Active X, toutes ces valeurs sont perdues !

La création de la ComboBox dézingue toutes les variables Modules de TOUS les Modules !

Je cherche un contournement de ce problème car même si on peut s'en sortir avec un Application.OnTime Now après la création de la ComboBox, cette solution ne permet pas de passer des paramètres reçus qui sont précisément les valeurs à placer en variables Module. Et puis de toutes façons, comme tous les Modules sont affectés, c'est irrattrapable !

 

[patricktoulon]

@Dudu2
et oui en passant par les api pour enlever les caption la taille height minimum est de la caption soit 21 points

d'accords délire pour délire
voici ma version je l'ai fait pour m'amuser (entendons nous bien)
donc voila le module 1
on y vois une fonction show perso (ShowX) avec argument elle est dans le userform en public
on y vois un pseudo event "macombobox_change" qui est appellé par le vrai event de la combo dans le userform
tu constatera que j'envoi l'array par la fonction show perso "ShowX"
on peu envoyé un object range en second parametre il est optionnel =activecell par defaut

Option Explicit
Public VariableModule1 As Variant
Sub CréationComboBox()
    Dim T
    T = Array("item1", "item2", "item2")
    ufListbox.ShowX T
End Sub

Sub ValoriserVariableModules()
    VariableModule1 = "Valeur de la variable module1"
    VariableModule2 = "Valeur de la variable module2"
    MsgBox "VariableModule1 valorisée à """ & VariableModule1 & """" & vbCrLf & _
           "VariableModule2 valorisée à """ & VariableModule2 & """"
End Sub

Sub AfficherVariableModules()
    MsgBox "VariableModule1 = """ & VariableModule1 & """" & vbCrLf & _
           "VariableModule2 = """ & VariableModule2 & """"
End Sub

'sub pour faire ce que l'on veux de la valeur ou l'index selectionné dans la combo du userform
'c'est un pseudo event dispo dans un module standard (rigolo non???)
Sub MacomboBox_change(value, Optional index As Long = -1)
    MsgBox value
End Sub

le code dans le userform maintenant
j'y ai mis ma fonction perso de placement range tu la connais c'est celle de mon calandrier

Option Explicit
Public tablo

'fonction show perso incluant des parametres
Public Function ShowX(arr, Optional rng As Range = Nothing)
    With ufListbox
        .tablo = arr
        .Show 0
    End With
End Function

Private Sub Combo_Change()
    With Combo
        If .ListIndex > -1 Then MacomboBox_change .value, .ListIndex
    End With
    Unload Me
End Sub



Private Sub UserForm_Activate()
    Dim cel As Range
    Set cel = ActiveCell
    Combo.List = tablo
    Nocaption
    placementRange cel
End Sub

Private Sub Nocaption()
    Dim hwnd&, h&
    h = Me.Combo.Height
    hwnd = ExecuteExcel4Macro("CALL(""user32"",""GetActiveWindow"",""JCC"")")         'api GetActiveWindow
    ExecuteExcel4Macro ("CALL(""user32"",""SetWindowLongA"",""JJJJJ""," & hwnd & ", " & -16 & ", " & &H94080080 & ")")      'api SetWindowLongA
    Me.Height = 0
    Me.Width = Combo.Width - 4
    Combo.Width = Me.InsideWidth
    Combo.Height = Me.InsideHeight

End Sub

Private Function placementRange(Obj As Object)
'function  put Userform  into range périmeter  by patricktoulon (france) exceldownloads forum)
'see my calandar
    If Obj Is Nothing Then Exit Function
    Dim z#, EcX#, L1#, T1#, C#, R#, Vr As Range, HX#, Wx#, Ok As Boolean, Op&, PtoPx#, I&
    With ActiveWindow
        PtoPx = (.ActivePane.PointsToScreenPixelsX(72) - .ActivePane.PointsToScreenPixelsX(0)) / 72    'coeff point to pixel
        Op = Int(Val(Mid(Application.OperatingSystem, InStrRev(Application.OperatingSystem, " ") + 1)))    'number version system
        'exit si la cellule injecté n'est pas vible a l'ecran
        For I = 1 To .Panes.Count: Ok = IIf(Not Intersect(.Panes(I).VisibleRange, Obj) Is Nothing, True, Ok): Next
        If Ok = False Then Beep: MsgBox " cette cellule n'est pas visible a l'ecran": Exit Function
        z = (ActiveWindow.Zoom / 100): Set Vr = .VisibleRange    'Coeff zoom ,  rangevisible partie mobile
        'EcX = 4 And Op = 6 And Int(Val(Application.Version)) < 16  'ecart cadre
        L1 = (.ActivePane.PointsToScreenPixelsX(Int(Obj.Left)) / PtoPx) * z + EcX    'placement partie mobile
        T1 = .ActivePane.PointsToScreenPixelsY(Int(Obj.Top)) / PtoPx * z + EcX
        With .Panes(1).VisibleRange: C = .Cells(.Cells.Count).Column: R = .Cells(.Cells.Count).Row: End With    'limite splitrow et splitcolumn
        If .SplitRow > 0 Then  'placement  dans le splitrow
            If Obj.Row < R + 1 And .ScrollRow > R Then T1 = ((.ActivePane.PointsToScreenPixelsY(Vr.Cells(1).Top) / PtoPx) * z) - (Range(Obj, Cells(R, 1)).Height * z) + EcX
        End If
        If .SplitColumn > 0 Then    'placement  dans le splitcolumn
            If Obj.Column < C + 1 And .ScrollColumn > C Then L1 = ((.ActivePane.PointsToScreenPixelsX(Vr.Cells(1).Left) / PtoPx) * z) - (Range(Obj, Cells(1, C)).Width * z) + EcX
        End If
    End With
    'option de placement :
    Wx = (Obj.Width / 2) * z * 0
    HX = (Obj.Height / 2) * z * 0
    L1 = L1    '+ (Wx)
    T1 = T1    '+ (HX)
    If L1 > Application.Left + Application.Width - Me.Width Then L1 = Application.Left + Application.Width - Me.Width - 15
    If T1 > Application.Top + Application.Height - Me.Height Then T1 = Application.Top + Application.Height - Me.Height - 15
    With Me: .Left = L1: .Top = T1: End With
End Function

et voila

on peut faire plus petit en utilisant d'autre api si veux

 

[mapomme]

Fichier corrigé pour les déclarations de l'API en VBA7.

Il y en a qui cherchent les ennuis. En venir à des API pour une simple ComboBox.

 

[patricktoulon]

puré ca va péter !!!!

 

[Dudu2]

puré ca va péter !!!!

Ça déchire c'est sûr !

Ton positionnement souffre d'un manque de précision.
Je suppose qu'il ressemble au mien dont j'ai dû adapter les valeurs.
En A11:

En Q32:

 

[mapomme]

Re,

A tout hasard, si au début de la procédure de création et remplissage de la ComboBox, on stockait en local les valeurs de variables publiques avant de les restituer à la fin de la procédure. Je ne peux toujours pas tester (je suis sur 365).

Sub CréationComboBox()
    Dim Top As Long, Left As Long, Width As Long, Height As Long
    Dim CbB As OLEObject
    Dim OCB As ComboBox
    Dim old1, old2
    
    On Error Resume Next
    old1 = VariableModule1: old2 = VariableModule2                                 '<========
    ActiveSheet.Shapes(NomComboBox).Delete
    
    'Cadre la ComboBox sur la cellule active
    With ActiveCell
        Top = .Top
        Left = .Left
        Width = .Width + 16
        Height = .Height * 1.1
    End With
    
    'Création de la ComboBox Active X
    Set CbB = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, _
                                         DisplayAsIcon:=False, Left:=Left, Top:=Top, Width:=Width, Height:=Height)
    CbB.Name = NomComboBox
    CbB.Object.AddItem "Item 1"
    CbB.Object.AddItem "Item 2"
    CbB.Object.AddItem "Item 3"
    
    VariableModule1 = old1: VariableModule2 = old2                       '<========
    
    'Application.OnTime Now, "ValoriserVariableModule1"
End Sub

 

[Dudu2]

@mapomme,

A tout hasard, si au début de la procédure de création et remplissage de la ComboBox, on stockait en local les valeurs de variables publiques avant de les restituer à la fin de la procédure

C'est le OLEObjects.Add qui provoque ce phénomène qui concrètement se produit lors du End Sub ou End Function de la fonction qui l'a fait.

Donc tu ne peux pas les stocker en local. la seule chose que tu puisses faire c'est utiliser un artifice, genre les noms du Gestionnaire de noms (solution mentionnée par @patricktoulon), le Dictionary, le stockage en cellules. Mais ça implique que TOUTES les variables candidates soient traitées de cette façon ce qui n'est pas gérable dans un projet où tu inclus des modules divers / utilitaires qui n'ont pas prévu d'externaliser leurs variables globales, ce qui, en dehors de ce BUG particulier n'a aucune raison d'être.

J'ai lu quelque part que le OLEObjects.Add provoquait la recompilation du projet et donc le RAZ des variables globales. Quelque soit l'explication, on ne peut rien faire.

 

[mapomme]

C'est le OLEObjects.Add qui provoque ce phénomène qui concrètement se produit lors du End Sub ou End Function qui l'a fait.

C'est ce que subodorais mais n'ayant que 365...

 

[patricktoulon]

allez version 2
cette fois ci on utilise l'api createregionroundrectangle avec un type rect pour découper le userform
on peut alors faire une combobox de la taille de la cellule

la sub de nocaption de remplacement de la version 1

Option Explicit
Public tablo
Public cel As Range
Public ecart&
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type    'bouton coin arrondi
Private Sub Nocaption()
    Dim lRet As Long, lWidth, lHeight, r As RECT, ptopx#, t&, L&, hwnd&
    With ActiveWindow.ActivePane: ptopx = Round((.PointsToScreenPixelsX(72) - .PointsToScreenPixelsX(0)) / 72, 2): End With
    t = (Me.Height - Me.InsideHeight) * ptopx
    L = ((Me.Width - Me.InsideWidth) / 2) * ptopx
    r.Left = L: r.Top = t - L
    r.Right = (Combo.Width * ptopx) + L
    r.Bottom = (Combo.Height * ptopx) + t - L
    lWidth = r.Right: lHeight = r.Bottom
    hwnd = ExecuteExcel4Macro("CALL(""user32"",""GetActiveWindow"",""JCC"")")         'api GetActiveWindow
    lRet = ExecuteExcel4Macro("CALL(""gdi32"",""CreateRoundRectRgn"",""JJJJJJJ""," & r.Left & ", " & r.Top & ", " & lWidth & ", " & lHeight & ", " & 1 & ", " & 1 & ")")
    ExecuteExcel4Macro ("CALL(""user32"",""SetWindowRgn"",""JJJJ""," & hwnd & ", " & lRet & ", " & 1 & ")")
    ExecuteExcel4Macro ("CALL(""gdi32"",""DeleteObject"",""JJ""," & lRet & ")")
End Sub

le fichier joint
complètement barré le toulonnais

 

[Dudu2]

Très fort !
Par contre je ne comprends pas le principe de ce RECT appliqué au UserForm.

Edit: Et je n'arrive pas à utiliser ta fonction Nocaption().

 

[patricktoulon]

re
et oui avec cet api on a pas une largeur et hauteur
on a un top un left un right et un bottom ce qui connaissent pas bien se perdent avec ça
ce sont des coordonnées écran
allez version 3
je gonfle la puissance de la show perso (tout les arguments sont optionnels sauf l'array bien sur )
on injecte

1. l'array
2. la cellule ou pas --> active cell par defaut
3. le backgroundcolor --> blanc par defaut
4. le fontcolor --> noir par defaut
5. le font name--> calibri par defaut
6. le fontsize --> 8 par defaut

voila la sub d'appel
la combo sera en fond rouge ,le font en jaune,le font name en "algerian",et le font size en 10

Sub CréationComboBox()
    Dim t
    t = Array("item1", "item2", "item3")
    ufListbox.ShowX t, , vbRed, vbYellow, "algerian", 10
    'ufListbox.ShowX t'tout par défaut
End Sub

le toulonnais fait mu muse
@mapomme doit être vert derrière

 

[Dudu2]

Ok, ça a l'air bien.
Mais COMMENT utiliser ta fonction de suppression de Caption ?
Je n'arrive pas à extraire le code nécessaire.

Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Sub Nocaption()
    Dim lRet As Long, lWidth, lHeight, r As RECT, ptopx#, t&, L&, hwnd&
    With ActiveWindow.ActivePane: ptopx = Round((.PointsToScreenPixelsX(72) - .PointsToScreenPixelsX(0)) / 72, 2): End With
    t = (Me.Height - Me.InsideHeight) * ptopx
    L = ((Me.Width - Me.InsideWidth) / 2) * ptopx
    r.Left = L: r.Top = t - L
    r.Right = (Combo.Width * ptopx) + L
    r.Bottom = (Combo.Height * ptopx) + t - L
    lWidth = r.Right: lHeight = r.Bottom
    hwnd = ExecuteExcel4Macro("CALL(""user32"",""GetActiveWindow"",""JCC"")")         'api GetActiveWindow
    lRet = ExecuteExcel4Macro("CALL(""gdi32"",""CreateRoundRectRgn"",""JJJJJJJ""," & r.Left & ", " & r.Top & ", " & lWidth & ", " & lHeight & ", " & 1 & ", " & 1 & ")")
    ExecuteExcel4Macro ("CALL(""user32"",""SetWindowRgn"",""JJJJ""," & hwnd & ", " & lRet & ", " & 1 & ")")
    ExecuteExcel4Macro ("CALL(""gdi32"",""DeleteObject"",""JJ""," & lRet & ")")
End Sub

Private Sub UserForm_Initialize()
    Call Nocaption
End Sub

Edit: ok, il faut le faire sur le UserForm_Activate() et par sur le UserForm_Initialize()

 

[patricktoulon]

re
a ben oui comment veux tu avoir des coordonnées écran ou même un handle quand il n'est pas loader (affiché)
ne pas confondre module userform et object userform (msforms)
le initialise c'est pour tout ce que l'on peut pas faire quand il est afficher en mode modal
le activate on est dans l'object form on fait ce que l'on veux
pour te la faire courte ( et la on revient sur ce que j'ai expliqué moulte fois )
dans le initialyse on est dans une instance de classe module userform
dans le activate on est dans l'object form
ma fonction perso "ShowX" est dans le même contexte que initialyse sauf que c'est une autre instance du module

en gros
j'appelle la showx du userform je déclenche alors une classe module ufListbox
dans cette sub je fait le show 0 (j affiche le userform)
donc je déclenche l’instance une autre instance du module uflistbox avec le initialyse
et enfin dans le activate je suis dans l'object
les instances étant appelées ou déclenchées par une fonction bien précise les instance se (terminate toute seules)

c'est pour cela que dans ma fonction showx perso tu vois le userform nommé et non le raccourci "Me" car dans l'instance module classe Me n'existe pas

d'ailleurs pour comprendre le phénomène il te suffit d'essaye msgbox me.caption tu verra tu aura une erreur
de même que si tu place msgbox me.caption dans ma fonction apres un show modal (enleve le zero) le msgbox ne viendra pas sauf!!!!!!!! si on hide le userform car il libere vba pour laisser la fonction continuer a s'executer
c'est le principe fondamental de mon calandrier

 

[Dudu2]

Ok merci pour l'explication. A digérer .
Par contre je n'ai pas compris d'où tu sors ces propriétés du UserForm: .tablo, .ecart

With ufListbox
        .tablo = arr
        If rng Is Nothing Then Set .cel = ActiveCell Else Set .cel = rng
        .ecart = Me.Height - .InsideHeight - 3

Tout cela est un peu compliqué pour moi. Ce serait plus facile de monter au Mont Faron à pied.
Je vais sans doute m'en tenir au standard.

 

[patricktoulon]

re
ferme la bouche @mapomme

@Dudu2 tu a raison j'ai fait une erreur
je commente

With ufListbox 'avec l'object userform 'DANS  UN BLOC WIDTH 
.tablo = arr 'lavariable public [B]tablo [/B]du userform= la variable arr(l'array injecté)
'si rng (argument(2) de la fonction("ShowX") = rien alors la variable public [B]cel [/B]du userform  est la cellule active sinon c'est la variable rng injecté 
If rng Is Nothing Then Set .cel = ActiveCell Else Set .cel = rng
'ecart = la hauteur du userform - l'interieur du userform 
.ecart = .Height - .InsideHeight - 3

autrement dit j'ajoute des propriété et membre a l'userform par l'intermediaire de la pasation de variable et argument fonction

je te le refait commenté correctement
c'est le quel que tu utilise le 1,2,ou 3

 

[patricktoulon]

re
je répété donc
quand le code de la fonction showX s'execute on est dans une classe ufListbox
donc tout ce qui se raporte a l'userform doit etre explicitement désigné
donc pas with me mais with UfListbox
pourquoi?: ben parce que le userform en tant qu'object form n'existe pas encore

la fonction commenté

'fonction show perso incluant des parametres
Public Function ShowX(arr, _
                      Optional rng As Range = Nothing, _
                      Optional backgroundcolor As Long = vbWhite, _
                      Optional FontColor As Long = 0, _
                      Optional Fontname As String = "calibri", _
                      Optional Fontsize As Long = 8)
    With ufListbox    'AVEC L OBJECT UFLISTBOX'DONC  LA ON EST DANS UN BLOC WITH OBJECT USERFORM ET NON MODULE
'arr est l'array ijincté par l appel dans le module1
        .tablo = arr    'LA VARIABLE TABLO APPARTENANT A L'USERFORM EN PUBLIC = L ARGUMENT ARR(INJECTE DANS L'APEL

        If rng Is Nothing Then Set .cel = ActiveCell Else Set .cel = rng    'attention au "." devant cel on est dans un bloc with  et cel etant une variable du userform

'rng est le 2d argument de la fonction c'est un object range  en optional =nothing si omis
' donc si rng est omis donc = nothing  ben la varaiable  public  (cel) de l'userform = la cellule active sinon  cest le rng injecté

'comme on supprime pas la caption comme dans ma version 2  avec setwindowlong
'mais que l'on decoupe avec une region  il faut prevoir un ecart de la hauteur de la caption soit le tout - l'interieur du userform

        .ecart = .Height - .InsideHeight - 3

        'et maintenant avec la combo  on modifie les propertie avec les arguments  (pas besoins d'expliquer cela je pense
        With .Combo
            .BackColor = backgroundcolor
            .ForeColor = FontColor
            .Font.Name = Fontname
            .Font.Size = Fontsize
        End With
        'et enfin maintenant on fait  le vrai  show qui va afficher le userform avec le combo modifié et les variable cel  et tablo  valoriser
        .Show 0

    End With
    'TOUTE LES Variables PUBLIC DU USERFORM  DOIVENT ETRE PRÉCÉDÉES PAR UN "."!!!!!!!!

End Function

c'est vrai que pour moi c'est simple mais ca peut etre déroutant pour certains
ça en effet on est dans le même module
seuls les experts en module classe comprennent le trucs
après je pense que les commentaires sont assez explicites
j'espère que tu a compris le principe