XL 2016 VBA - Réduire la largeur de la grille Excel

[Dudu2]

Bonjour,

DataSnipper est un outil commercial ajoutant à Excel des fonctionnalités diverses.
Parmi ces fonctionnalités, la possibilité de visualiser des documents PDF directement dans Excel avec cette particularité (voir image ci-dessous) que la fenêtre Excel est divisée en 2 verticalement. La partie gauche contient la grille Excel, la partie droite contient probablement un Control ActiveX visualisateur PDF, je ne sais pas lequel ? Acrobat ? PDF-XChange Viewer ? Autre ?

La question est: comment est-il possible dans une fenêtre Excel de réduire la largeur de la grille Excel et ses ascenseurs comme le fait ce logiciel ?

 

[nullosse]

@nullosse
voila il fallait simplement remplacer tout les 0.75(qui est coeff pointpixel pour dpi 100%) par ma petite fonction fonction PpX

Salut,
Finalement tu utilises le userform apropos comme conteneur pour Word. Attention dans la fermeturevolet tu fais un unload apropos avant de fermer Word ce qui fait planter word si il est ouvert dedans et il reste en processus.
Nullosse

 

[patricktoulon]

re
Bonjour @nullosse
oui j'ai remis le userform en host pensant que peut être dans vos versions d'Excel vous avez le full focus
mais pour moi sur 2013 le userform ne sert strictement a rien si il n'est pas apparenté au XLDESK parent du EXCEL7

dis moi pour word le bouton est bien caché chez toi?

 

[nullosse]

@nullosse
dis moi pour word le bouton est bien caché chez toi?

Non le cache est au-dessus et il est blanc :

 

[patricktoulon]

et oui il faut multiplier le topou le height par 1.25 en fait acr les dimension je les ai pris en pixel sur un windows en zoom 100%
voila le code corrigé tu me diras

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************

'                                      Application Taskpane project
'Version 2.0
'Date version:02/10/2025
'auteur patricktoulon
'macro d'ouverture du volet Word
Option Explicit
Sub OuvrirVoletWord_V_4()
    Dim Hdock As LongPtr, Hword As LongPtr, HForm As LongPtr, HRibbon As LongPtr, i&, Haut&, t, N$, Fichier$
    Dim HwnDmask As LongPtr, WindowsZoom As Double
    If TaskPaneUsed Then MsgBox "Fermez le volet actuel ": Exit Sub
    
    ' Ouvrir le panneau
    fermetureVolet_v_4
    
    'ouverture du paneau source
    'on teste si le window est la
    t = AllPartExcelWindowList
    For i = 2 To UBound(t)
        If t(i, 2) = "bosa_sdm_XL9" Then
            Hdock = CLngPtr(t(i - 2, 1))
            Haut = t(i, 8)
            Exit For
        End If
    Next
    ' sil n'est pas là
    If Hdock = 0 Then
        Application.CommandBars.ExecuteMso "XmlSource"
        
        t = AllPartExcelWindowList
        For i = 2 To UBound(t)
            If t(i, 2) = "bosa_sdm_XL9" Then
                Hdock = CLngPtr(t(i - 2, 1))
                Haut = t(i, 8)
                Exit For
            End If
        Next
    End If
    apropos.Show 0
    HForm = GetActiveWindow
    SetWindowLong HForm, -16, &H16000000
  SetParent HForm, Hdock
   SetWindowPos HForm, 0, 7, 2, ((Application.Width / 2) / PpX) - 7, Haut + 40, 0
  
    ' Ouvre le fichier Word
    Fichier = Application.GetOpenFilename("Word Files (*.doc*), *.doc*", 1, "Ouvrir un fichier")
    If Fichier = "Faux" Then: Application.CommandBars.ExecuteMso "XmlSource": Unload apropos: Exit Sub
    
    
    Set wordxapp = CreateObject("Word.Application")
    wordxapp.left = 3000
    wordxapp.Visible = True
    wordxapp.Documents.Open Fichier
    DoEvents
    N = Split(Mid(Fichier, InStrRev(Fichier, "\") + 1), ".")(0)
    
    ' Ici tu utilises ta fonction GetWinHandle
    Hword = GetWinHandle("OpusApp", N, 10)
  Do While IsWindowVisible(Hword) = 0
     DoEvents
  Loop
   SetWindowLong Hword, -16, &H16000000
   'on va chercher la fenêtre du ruban
    t = WordPartWindowList(Hword)
    If IsArray(t) Then
        For i = 1 To UBound(t)
            DoEvents
            If Not IsEmpty(t(i, 1)) Then
                If t(i, 2) = "NetUIHWND" Then HRibbon = CLngPtr(t(i, 1)): Exit For
                'Debug.Print "handle :" & t(i, 1) & " classe : " & t(i, 2)
            End If
        Next
    End If
    
    
    'Unload apropos
   WindowsZoom = Round(GetDpiForWindow(Application.hwnd) / 96 * 100) / 100
    'Crée un mask avec une petite fenêtre vide  et on la colle dans le ruban
     'un bout de scotch sur le bouton
   HwnDmask = CreateWindowEx(&H8, "STATIC", vbNullString, &HCF0000 Or &H10000000, -(75 * WindowsZoom), 0, 45 * WindowsZoom, 55 * WindowsZoom, 0, 0, 0, 0)
    DoEvents
    SetWindowLong HwnDmask, -16, &H16000000 'checkbox on vire la caption
    SetWindowPos Hword, -1, -5, -36, ((Application.Width / 2) / PpX), Haut + 36, 0
    SetParent HwnDmask, HRibbon
    SetParent Hword, HForm
    DoEvents
   ActiveSheet.Activate
   ActiveWindow.VisibleRange.Cells(1).Select
End Sub

 

[nullosse]

et oui il faut multiplier le topou le height par 1.25 en fait acr les dimension je les ai pris en pixel sur un windows en zoom 100%
voila le code corrigé tu me diras

Il est toujours au-dessus. On a l'impression qu'il est attaché à la fenêtre word et pas au ruban de word. Avec ton excel il est attaché où ?

 

[patricktoulon]

il est attaché a la NetUIHWND

  t = WordPartWindowList(hword)
    If IsArray(t) Then
        For i = 1 To UBound(t)
            DoEvents
            If Not IsEmpty(t(i, 1)) Then
                If t(i, 2) = "NetUIHWND" Then HRibbon = CLngPtr(t(i, 1)): Exit For
                'Debug.Print "handle :" & t(i, 1) & " classe : " & t(i, 2)
            End If
        Next
    End If

quand je fait une liste ca donne ca

Sub ExhaustiveWordListList()
    Dim t, fichier, hword As LongPtr, i&
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("listeComposantword").Delete
    On Error GoTo 0
      fichier = Application.GetOpenFilename("Word Files (*.doc*), *.doc*", 1, "Ouvrir un fichier")
    If fichier = "Faux" Then Exit Sub
   
Set wordxapp = CreateObject("Word.Application")
    wordxapp.left = 15
    wordxapp.Visible = True
    wordxapp.Documents.Open fichier
    DoEvents
   
    ' Ici tu utilises ta fonction GetWinHandle
    hword = GetWinHandle("OpusApp", , 10)
   
    t = WordPartWindowList(hword)
   
    With Sheets.Add
        .Name = "listeComposantword"
        .Cells(1).Resize(, 9) = Split("handle,classe,left,top,right,bottom,width,height,Handleparent", ",")
        .Cells(2, 1).Resize(200, 9) = t
        .ListObjects.Add(xlSrcRange, Range("$A$1:$I$200"), , xlYes).Name = "listcompo"
        .ListObjects("listcompo").TableStyle = "TableStyleMedium2"
    End With
End Sub

mais visiblement vu ta capture les hauteurs ne sont pas les même chez moi chez toi donc adapte la hauteur

 

[patricktoulon]

Bonjour @nullosse , @Dudu2

je vous le livre en complément en avant première avant que la modé ai validé la ressource
j'ai bloqué le lancement si la fenêtre excel n'est pas plein écran
toujours les deux boutons implémentables dans les deux sections
tout est expliqué avec le bouton à propos

 

[Dudu2]

Bonjour @patricktoulon,

Comment ça fonctionne ?

 

[patricktoulon]

Bonjour @Dudu2
regarde ton ruban c'est lui le pilote
et a ce que je vois tu l'a ouvert comme un fichier Excel
c'est un complément il te faut le mettre dans le dossier de tes xlam ou ou tu veux et l'intégrer dans excel par le menu option
tu sais faire ça non?
si tu ne sais pas je peux t'aider c'est simple

 

[patricktoulon]

a ben oui le but c'est ca un outils reutilisable sur n'importe quel fichier
donc en complément c'est la méthode toute indiquée
n'oubliez pas de bien lire
je vous ai donné la possibilité d'ajouter deux boutons dans chaque section pour faire ce que vous voulez sans que vous ayez a taper dans les xmls (on pense un peu a dudu hein) le bouton a propos vous explique tout

 

[nullosse]

Salut patricktoulon
il y a quelque rectifications à faire dans le module Word_pane :
1 - j'ai trouvé le moyen de couvrir à coup sûr le bouton Fichier du ruban :
a - on récupère la hauteur du ruban quand on cherche l'objet HRibbon et on l'applique au masque que l'on crée

    If IsArray(t) Then
        For i = 1 To UBound(t)
            DoEvents
            If Not IsEmpty(t(i, 1)) Then
                If t(i, 2) = "NetUIHWND" Then
                   HRibbon = CLngPtr(t(i, 1))
                   HauteurRuban = t(i, 8)
                   Exit For
                End If
                'Debug.Print "handle :" & t(i, 1) & " classe : " & t(i, 2)
            End If
        Next
    End If
    'Unload apropos
    WindowsZoom = Round(GetDpiForWindow(Application.hWnd) / 96 * 100) / 100
    'Crée un mask avec une petite fenêtre vide  et on la colle dans le ruban
    'un bout de scotch sur le bouton
    HwnDmask = CreateWindowEx(&H8, "STATIC", vbNullString, &H90000000, 0, 0, 60 * WindowsZoom, HauteurRuban, 0, 0, 0, 0)

J'ai changé un des paramètres du CreateWindowEx -> &H90000000 = WS_POPUP or WS_VISIBLE
D'autre par les fenêtres dans le volet ne se redimensionne pas alors il faut mettre pour la largeur de la fenêtre Userform et celle de word la moitié de celle de l'appli word (c'est ce qu'il y avait avant) ce qui correspond à la largeur max que le volet peut prendre :

 SetWindowPos hword, -1, -5, -48 * WindowsZoom, ((Application.Width / 2) / PpX) - 5, Haut + 40 + 48 * WindowsZoom, 0

-48 cela correspond à la hauteur du bandeau Titre.
Pour le HForm :

 SetWindowPos HForm, 0, 7, 2, ((Application.Width / 2) / PpX) - 7, Haut + 40, 0

et quand on déplace la fenêtre on voit parfois le fond du userform (apropos) il faudrait rendre invisible les controles du Userform dès qu'on a mis la fenêtre word dedans.

Nullosse

 

[patricktoulon]

non en fait j'ai bloqué au plein ecran pour ca
car l'appn en mode xlnormal le width/2 n'est pas le max
apres pour les dimension du cache bouton il me semble que c'es qui est je vais regarder
merci pour le retour
resultat chez moi avec ton correctif
on voit bien que c'est pas bon

je vais vous faire dans la journée un excel animé pour que vous voyez mieux la chose a propos des windows childs et soeurs dans la fenêtre

 

[nullosse]

apres pour les dimension du cache bouton il me semble que c'es qui est je vais regarder
merci pour le retour
resultat chez moi avec ton correctif
on voit bien que c'est pas bon
je vais vous faire dans la journée un excel animé pour que vous voyez mieux la chose a propos des windows childs et soeurs dans la fenêtre

En fait il faut capturer le ruban quand il est en mode réduit ( que les onglets sans les boutons) Regarde bien mon animation je suis en mode ruban réduit et quand je fais apparaître les boutons le cache ne va pas dessus.
pour réduire le ruban :

  wordxapp.CommandBars.ExecuteMso "MinimizeRibbon"

Pas sûr que cela fonctionne avec toutes les versions d'excel

 

[patricktoulon]

ok je vais tester mai la logique c'est
comme tu peux le voir avec le tableau et la fenêtre word mon calcul est cohérent
maintenant peut ^tre que chez vous l'arborescence des fen^tres n'est pas la m^me
il faudrait que tu me donne le tableau obtenu chez toi pour voir

 

[nullosse]

ok je vais tester mai la logique c'est
comme tu peux le voir avec le tableau et la fenêtre word mon calcul est cohérent
maintenant peut ^tre que chez vous l'arborescence des fen^tres n'est pas la m^me
il faudrait que tu me donne le tableau obtenu chez toi pour voir

voici ce que j'obtiens chez moi :

ce qui est louche c'est le width et height à zéro sur le premier NetUIHWND