XL 2021 Savez-vous planter les choux ?

Constantin · Hier à 08:13

Bonjour à tous,
A la demande d'aspsy et sur les conseils de sylvanu, j'ai repris un fichier pour le compléter façon jardinier.
J'ai ainsi ajouté (partiellement) , dans la BaseJM, l'Oca du Pérou (travail en cours)
- Problème 1 : Je n'arrive pas à importer la photo de l'Oca dans le rapport. J'ai vu que JM27 avait expliqué comment faire mais, comme à mon habitude, je n'ai pas réussi.(explications trop succinctes pour un balbutiant comme moi)
- Problème 2 : L'affichage du (des) tableaux mentionnent "Réalisation:Jean-Marcel.H"=JM27 d'XLD ?). J'aimerai placer cette annotation dans un endroit qui ne gêne pas mais je suis incapable de le voir dans l'UserForm.

Je numérote les problèmes parce qu'il y en aura d'autres à venir...
Bien à vous,

JM27 · Hier à 19:52

@cathodique
Effectivement je pense que ma version ( qui est la dernière) n'est pas compatible avec la tienne.
j'ai bien vu que tu n'as pas effacé le nom de l'auteur mais que tu as traité différemment.
Attention Constantin : ce message s'adresse à Cathodique.😀
ne viens donc pas le parasité.

cathodique · Aujourd'hui à 15:15

patricktoulon à dit:

re
ne pas en vouloir à cathodique il a fait confiance en chat gpt
et les modifs de chatgpt sont stupéfiantes tellement c'est stupide
c'est incroyable comme chatgpt a tricoté mon code simple ou il fallait seulement ajouter les déclaration 64 en un truc sans nom

je suis estomaqué

allez
je vous donne le vieux machin pour ceux pour qui ca pesent trop de devoir se depatouiller avec les déclarations d'api

VB:

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'                            Module RESIZER  userform version basic
'version  avec api en macro 4
'release 2020  for XLD
'****************************************************************************************************
Option Explicit

Dim OldW#, OldH#
Sub trois_boutons1() 'ajoute les 3 boutons et le resize dynamique à l'userform
    Dim hWnd&
    hWnd = ExecuteExcel4Macro("CALL(""user32"",""GetActiveWindow"",""JCC"")") 'api GetActiveWindow
    ExecuteExcel4Macro ("CALL(""user32"",""SetWindowLongA"",""JJJJJ""," & hWnd & ", " & -16 & ", " & &H94CF0080 & ")") 'api SetWindowLongA
End Sub
Sub NoTitleBar1() 'supprime la barre de titre( rempli absolument tout l'ecran
    Dim hWnd&
    hWnd = ExecuteExcel4Macro("CALL(""user32"",""GetActiveWindow"",""JCC"")") 'api GetActiveWindow
    ExecuteExcel4Macro ("CALL(""user32"",""SetWindowLongA"",""JJJJJ""," & hWnd & ", " & -16 & ", " & &H140F0101 ")") 'api SetWindowLongA
End Sub

Sub UsfFullScreen1() 'met le userform en plein ecran
    Dim hWnd&
    hWnd = ExecuteExcel4Macro("CALL(""user32"",""GetActiveWindow"",""JCC"")") 'api GetActiveWindow
    ExecuteExcel4Macro ("CALL(""user32"",""ShowWindow"",""JJJ""," & hWnd & ", 3)") 'api SetWindowLongA
End Sub

Sub memoControlSize1(usf) 'on memorise dans le tag des controls leur position et dimension
    Dim CtrL
    OldW = usf.Width
    OldH = usf.Height
    For Each CtrL In usf.Controls
        CtrL.Tag = CtrL.Left & ";" & CtrL.Top & ";" & CtrL.Width & ";" & CtrL.Height
        On Error Resume Next
        CtrL.Tag = CtrL.Tag & ";" & CtrL.Font.Size
        CtrL.Tag = CtrL.Tag & ";"
        Err.Clear: On Error GoTo 0
        If TypeName(CtrL) = "ListBox" Or TypeOf CtrL Is ListBox Then
            CtrL.Tag = CtrL.Tag & ";" & Replace(CtrL.ColumnWidths, ";", "|")
        End If
        CtrL.Tag = CtrL.Tag & ";"
    Next
End Sub

Sub resiZer1(usf)
    Dim newW#, NewH#, t, cw$, tc, CtrL, i&
    newW = usf.Width / OldW
    NewH = usf.Height / OldH
    For Each CtrL In usf.Controls
        t = Split(CtrL.Tag, ";")
        CtrL.Move t(0) * newW, t(1) * NewH, t(2) * newW, t(3) * NewH
        If TypeName(CtrL) = "ListBox" Or TypeOf CtrL Is ListBox Then
            If CtrL.ColumnWidths = "" Then cw = Application.Rept("80", CtrL.ColumnCount) Else cw = CtrL.ColumnWidths
            tc = Split(t(6), "|")
            For i = 0 To UBound(tc): tc(i) = Val(tc(i)) * Application.Min(newW, NewH): Next
            CtrL.ColumnWidths = Join(tc, ";")
        End If
        On Error Resume Next
        CtrL.Font.Size = t(4) * Application.Min(newW, NewH)
        Err.Clear: On Error GoTo 0
    Next
End Sub

et maintenat le même exactement avec les api déclarées en bon et due forme

VB:

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'                            Module RESIZER  userform version basic
'version  avec api déclarées
'release 2020  for XLD
'****************************************************************************************************

Option Explicit

#If VBA7 Then
    #If Win64 Then
        Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" ( _
                              ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" ( _
                              ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #End If
   
    Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
                              ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
   
    Public Declare PtrSafe Function ShowWindow Lib "user32" ( _
                              ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
   
    Public Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
   
#Else
    Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
                              ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
   
    Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
                              ByVal lpClassName As String, ByVal lpWindowName As String) As Long
   
    Public Declare Function ShowWindow Lib "user32" ( _
                              ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
   
    Public Declare Function GetActiveWindow Lib "user32" () As Long
   
#End If

Dim OldW#, OldH#

Sub trois_boutons() 'ajoute les 3 boutons et le resize dynamique à l'userform
    Dim hWnd&
    hWnd = GetActiveWindow
    SetWindowLongPtr hWnd, -16, &H94CF0080 'api SetWindowLongA
End Sub

Sub NoTitleBar() 'supprime la barre de titre( rempli absolument tout l'ecran
    Dim hWnd&
    hWnd = GetActiveWindow
    SetWindowLongPtr hWnd, -16, &H140F0101
End Sub

Sub SameSizeApplication(usf) 'taille et position identique à l'application
    With Application
        usf.Move .Left, .Top, .Width, .Height
    End With
End Sub

Sub UsfFullScreen() 'met le userform en plein ecran
    Dim hWnd&
    hWnd = GetActiveWindow
    ShowWindow hWnd, 3
End Sub

Sub memoControlSize(usf) 'on memorise dans le tag des controls leur position et dimension
    Dim CtrL
    OldW = usf.Width
    OldH = usf.Height
    For Each CtrL In usf.Controls
        CtrL.Tag = CtrL.Left & ";" & CtrL.Top & ";" & CtrL.Width & ";" & CtrL.Height
        On Error Resume Next
        CtrL.Tag = CtrL.Tag & ";" & CtrL.Font.Size
        CtrL.Tag = CtrL.Tag & ";"
        Err.Clear: On Error GoTo 0
        If TypeName(CtrL) = "ListBox" Or TypeOf CtrL Is ListBox Then
            CtrL.Tag = CtrL.Tag & ";" & Replace(CtrL.ColumnWidths, ";", "|")
        End If
        CtrL.Tag = CtrL.Tag & ";"
    Next
End Sub

Sub resiZer(usf)
    Dim newW#, NewH#, t, cw$, tc, CtrL, i&
    newW = usf.Width / OldW
    NewH = usf.Height / OldH
    For Each CtrL In usf.Controls
        t = Split(CtrL.Tag, ";")
        CtrL.Move t(0) * newW, t(1) * NewH, t(2) * newW, t(3) * NewH
        If TypeName(CtrL) = "ListBox" Or TypeOf CtrL Is ListBox Then
            If CtrL.ColumnWidths = "" Then cw = Application.Rept("80", CtrL.ColumnCount) Else cw = CtrL.ColumnWidths
            tc = Split(t(6), "|")
            For i = 0 To UBound(tc): tc(i) = Val(tc(i)) * Application.Min(newW, NewH): Next
            CtrL.ColumnWidths = Join(tc, ";")
        End If
        On Error Resume Next
        CtrL.Font.Size = t(4) * Application.Min(newW, NewH)
        Err.Clear: On Error GoTo 0
    Next
End Sub

voila le resize est tout totomatic
vous pouvez tester avec ce classeur il y a 3 userform exemples

l'userform1 utilisera le module avec la methode par les macro4(plein ecran, les trois boutons dans la barre de titre et la taskbar est visible)
l'userform2 utilisera le module avec api déclarées(plein ecran, pas de barre de titre, pas de taskbar(il couvre absolument tout l'ecran)
l'userform3 utilisera le module api déclarées(couvre l'application ,pas de barre de titre )

un peu d'humour
@Nain porte quoi
non on ca plait au nazes

division par zéro sur cette ligne:
newW = usf.Width / OldW
pour userform2 et userform3 (sur excel 2010)

patricktoulon · Aujourd'hui à 16:26

oui appelle appelle resizer1 a la place de resizer dans le userform1

Nain porte quoi · Aujourd'hui à 16:35

cathodique à dit:
Voilà, encore un qui pense avoir les poumons plus oxygénés que les autres.

??? 😳
Je ne comprend pas la pique, ma réflexion n'était pas contre vous mais envers le "chat qui pète" qui a tendance à raconter un peu beaucoup n'importe quoi (une preuve de plus dans ce fil) et qui a encore pas mal de boulot pour arriver à pondre un truc cohérent.
Je ne me permettrait pas de critiquer le travail de qui que ce soit

nullosse · Aujourd'hui à 16:44

Salut,
il y a deux soucis avec le code du post #29
1 - Les Excel 64 bits n'ont pas l'air d'aimer les Dim hWnd& . Avec des dim hWnd cela fonctionne
2 - Excel 2010 est strict sur les columnwidths des ListBox il faut indiquer l'unité : ex "10;10" ne passe pas il faut par exemple "10 pt; 10 pt" ( c'est Roger Murdock, interprété par Kareem Abdul-Jabbar) qui m'a soufflé cela.
Nullosse

cathodique · Aujourd'hui à 16:56

patricktoulon à dit:
oui appelle appelle resizer1 a la place de resizer dans le userform1

Pour afficher ce contenu, nous aurons besoin de votre consentement pour définir des cookies tiers.
Pour plus d'informations, consultez notre page sur les cookies.

Je te remercie pour ta magistrale démonstration.
J'ai bien vu que sur ta machine tout fonctionne bien.
Pour la division par zéro, j'ai mis ceci dans le formulaire et je n'ai plus eu la division par zéro.

VB:

Private Sub UserForm_Initialize()
'code pour userform2
    memoControlSize Me
End Sub

Private Sub UserForm_Activate()
    Static done As Boolean
    If done Then Exit Sub
    done = True

    NoTitleBar
    UsfFullScreen
End Sub

Private Sub UserForm_Resize()
    resiZer Me
End Sub

Merci beaucoup pour tous tes conseils. Depuis que je tourne sur excel2010, j'en suis tombé amoureux.
Merci aussi pour ton partage gracieux de tes connaissances qui n'est pas le cas de tout le monde.

Bonne fin de journée.

Constantin · Aujourd'hui à 17:35

Et si vous ouvriez une nouvelle discussion entre vous ?

Nain porte quoi · Aujourd'hui à 18:17

Constantin à dit:
Et si vous ouvriez une nouvelle discussion entre vous ?

patricktoulon · Aujourd'hui à 19:09

re
@nullosse
oui tu a peut être raison les dim avec "&" pour long sont forcement faux pour le 64 par contre je suis étonné que le non typé donc variant fonctionne puisque les déclarations attendent un longptr en vba 7
pour ce cw(columnwidths) je n'avais jamais entendu parler de ça mais soit
voici donc le code corrigé en conséquence

VB:

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'                            Module RESIZER  userform version basic
'version  avec api déclarées
'release 2020  for XLD
'****************************************************************************************************

Option Explicit

#If VBA7 Then
    #If Win64 Then
        Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" ( _
                              ByVal Hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" ( _
                              ByVal Hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #End If
   
    Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
                              ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
   
    Public Declare PtrSafe Function ShowWindow Lib "user32" ( _
                              ByVal Hwnd As LongPtr, ByVal nCmdShow As Long) As Long
   
    Public Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
   
#Else
    Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
                              ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
   
    Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
                              ByVal lpClassName As String, ByVal lpWindowName As String) As Long
   
    Public Declare Function ShowWindow Lib "user32" ( _
                              ByVal Hwnd As Long, ByVal nCmdShow As Long) As Long
   
    Public Declare Function GetActiveWindow Lib "user32" () As Long
   
#End If
#If VBA7 Then
    Dim Hwnd As LongPtr
#Else
    Dim Hwnd As Long
#End If
Dim OldW#, OldH#

Sub trois_boutons() 'ajoute les 3 boutons et le resize dynamique à l'userform
    Hwnd = GetActiveWindow
    SetWindowLongPtr Hwnd, -16, &H94CF0080 'api SetWindowLongA
End Sub

Sub NoTitleBar() 'supprime la barre de titre( rempli absolument tout l'ecran
    Hwnd = GetActiveWindow
    SetWindowLongPtr Hwnd, -16, &H140F0101
End Sub


Sub SameSizeApplication(usf) 'taille et position identique à l'application
    With Application
        usf.Move .Left, .Top, .Width, .Height
    End With
End Sub

Sub UsfFullScreen() 'met le userform en plein ecran
    Hwnd = GetActiveWindow
    ShowWindow Hwnd, 3
End Sub

Sub memoControlSize(usf) 'on memorise dans le tag des controls leur position et dimension
    Dim CtrL
    OldW = usf.Width
    OldH = usf.Height
    For Each CtrL In usf.Controls
        CtrL.Tag = CtrL.Left & ";" & CtrL.Top & ";" & CtrL.Width & ";" & CtrL.Height
        On Error Resume Next
        CtrL.Tag = CtrL.Tag & ";" & CtrL.Font.Size
        CtrL.Tag = CtrL.Tag & ";"
        Err.Clear: On Error GoTo 0
        If TypeName(CtrL) = "ListBox" Or TypeOf CtrL Is ListBox Then
            CtrL.Tag = CtrL.Tag & ";" & Replace(CtrL.ColumnWidths, ";", "|")
        End If
        CtrL.Tag = CtrL.Tag & ";"
    Next
End Sub

Sub resiZer(usf)
    Dim newW#, NewH#, t, cw$, tc, CtrL, i&
    newW = usf.Width / OldW
    NewH = usf.Height / OldH
    For Each CtrL In usf.Controls
        t = Split(CtrL.Tag, ";")
        CtrL.Move t(0) * newW, t(1) * NewH, t(2) * newW, t(3) * NewH
        If TypeName(CtrL) = "ListBox" Or TypeOf CtrL Is ListBox Then
            If CtrL.ColumnWidths = "" Then
                cw = Application.Rept("80 ", CtrL.ColumnCount)
                cw = Replace(Trim(cw), " ", " pt;")
               t(6) = cw
               'Else: cw = CtrL.ColumnWidths
            End If
            tc = Split(t(6), "|")
            For i = 0 To UBound(tc): tc(i) = Val(tc(i)) * Application.Min(newW, NewH): Next
            CtrL.ColumnWidths = Join(tc, " pt;")
            'MsgBox CtrL.ColumnWidths
        End If
        On Error Resume Next
        CtrL.Font.Size = t(4) * Application.Min(newW, NewH)
        Err.Clear: On Error GoTo 0
    Next
End Sub

@Constantin
j'avoue ne pas comprendre ton comportement
tu a des pointures qui sont intervenus dans ta demande
au lieu de te braquer tu pourrais peut être en prendre

XL 2021 Savez-vous planter les choux ?

Constantin

XLDnaute Occasionnel

Pièces jointes

JM27

cathodique

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Nain porte quoi

XLDnaute Occasionnel

nullosse

XLDnaute Occasionnel

cathodique

XLDnaute Barbatruc

Constantin

XLDnaute Occasionnel

Nain porte quoi

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

XL 2021 Savez-vous planter les choux ?

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

Privacy & Transparency

Privacy & Transparency