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

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

'                                      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

  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

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