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