none
PrintPreviewAndPrintについて。 RRS feed

  • 質問

  • 印刷プレビュー(全画面表示)にバグがあり、下部のオブジェクトが表示されない事象がありました。

    このことについては上記のようにマイクロソフトでも把握しているようです。

    その回避方法について、
    Application.CommandBars.ExecuteMso "PrintPreviewAndPrint"
    を使うことを推奨され、使う方向でソースを書いています。
    しかし、

    Application.Dialogs(xlDialogPrint).Show 2, 1, Page, 1

    のように、出力開始ページなどマクロで計算したものをPrintPreviewAndPrintに引き渡したいと思うのです。
    しかし、その辺について述べられたものがなく困っております。

    すでにyahooでも質問したのですが、回答が返ってこないため、急遽こちらにも質問するところです。
    マルチポストは失礼にあたるのですが、それを重々承知の上で質問させていただきます。
    申し訳ございません。

    2018年1月5日 4:42

すべての返信

  • もとの質問はこれ?

    Excel2016限定なら無理やりやればできないことは無いかもしれない

    '参照の追加でUIAutmationClientを追加しておく
    Option Explicit
    Enum PrintRangeType
        Sheet = 0
        Book = 1
        Selected = 2
    End Enum
    
    Private Function FindElementBy _
        (ByVal uia As UIAutomationClient.CUIAutomation8 _
        , ByVal e As UIAutomationClient.IUIAutomationElement _
        , ByVal scope As UIAutomationClient.TreeScope _
        , ByVal propertyId As Long _
        , ByVal v As Variant _
        , ByVal errmsg As String) As UIAutomationClient.IUIAutomationElement
        
        Dim con As UIAutomationClient.IUIAutomationPropertyCondition
        Set con = uia.CreatePropertyCondition(propertyId, v)
        
        Set FindElementBy = e.FindFirst(scope, con)
        If (FindElementBy Is Nothing) Then
            Err.Raise vbObjectError + 512, Description:=errmsg
        End If
    End Function
    
    Private Function FindElementsBy _
        (ByVal uia As UIAutomationClient.CUIAutomation8 _
        , ByVal e As UIAutomationClient.IUIAutomationElement _
        , ByVal scope As UIAutomationClient.TreeScope _
        , ByVal propertyId As Long _
        , ByVal v As Variant _
        , ByVal errmsg As String) As UIAutomationClient.IUIAutomationElement()
        
        Dim con As UIAutomationClient.IUIAutomationPropertyCondition
        Set con = uia.CreatePropertyCondition(propertyId, v)
        
        Dim ar As UIAutomationClient.IUIAutomationElementArray
        
        Set ar = e.FindAll(scope, con)
        If (ar.Length = 0) Then
            Err.Raise vbObjectError + 512, Description:=errmsg
        End If
        Dim a() As UIAutomationClient.IUIAutomationElement
        ReDim a(ar.Length - 1)
        
        Dim i As Integer
        For i = 0 To ar.Length - 1
            Set a(i) = ar.GetElement(i)
        Next
        FindElementsBy = a
    End Function
    
    Private Function FindElementByHandle(ByVal uia As UIAutomationClient.CUIAutomation8, ByVal e As UIAutomationClient.IUIAutomationElement, ByVal scope As UIAutomationClient.TreeScope, ByVal v As Variant, ByVal errmsg As String) As UIAutomationClient.IUIAutomationElement
        Set FindElementByHandle = FindElementBy(uia, e, scope, UIAutomationClient.UIA_NativeWindowHandlePropertyId, v, errmsg)
    End Function
    
    Private Function FindElementByPropetyId(ByVal uia As UIAutomationClient.CUIAutomation8, ByVal e As UIAutomationClient.IUIAutomationElement, ByVal scope As UIAutomationClient.TreeScope, ByVal v As Variant, ByVal errmsg As String) As UIAutomationClient.IUIAutomationElement
        Set FindElementByPropetyId = FindElementBy(uia, e, scope, UIAutomationClient.UIA_PropertyIds.UIA_AutomationIdPropertyId, v, errmsg)
    End Function
    
    Private Function FindElementByName(ByVal uia As UIAutomationClient.CUIAutomation8, ByVal e As UIAutomationClient.IUIAutomationElement, ByVal scope As UIAutomationClient.TreeScope, ByVal v As Variant, ByVal errmsg As String) As UIAutomationClient.IUIAutomationElement
        Set FindElementByName = FindElementBy(uia, e, scope, UIAutomationClient.UIA_PropertyIds.UIA_NamePropertyId, v, errmsg)
    End Function
    
    Private Function FindElementByClass(ByVal uia As UIAutomationClient.CUIAutomation8, ByVal e As UIAutomationClient.IUIAutomationElement, ByVal scope As UIAutomationClient.TreeScope, ByVal v As Variant, ByVal errmsg As String) As UIAutomationClient.IUIAutomationElement
        Set FindElementByClass = FindElementBy(uia, e, scope, UIAutomationClient.UIA_PropertyIds.UIA_ClassNamePropertyId, v, errmsg)
    End Function
    
    
    Private Sub SetSpinValue(ByRef spins() As UIAutomationClient.IUIAutomationElement, ByVal name As String, ByVal v As String)
        Dim i As Integer
        For i = LBound(spins) To UBound(spins)
            If (spins(i).CurrentName = name) Then
                Dim spin  As UIAutomationClient.IUIAutomationElement
                Set spin = spins(i)
                
                Dim vp As UIAutomationClient.IUIAutomationValuePattern
                Set vp = spin.GetCurrentPattern(UIAutomationClient.UIA_PatternIds.UIA_ValuePatternId)
                Call vp.SetValue(v)
                Exit Sub
            End If
        Next
        Err.Raise vbObjectError + 512, Description:="スピン(" & name & ")が見つかりません"
    End Sub
    
    Private Function GetBackstageView(ByVal uia As UIAutomationClient.CUIAutomation8) As UIAutomationClient.IUIAutomationElement
        Application.CommandBars.ExecuteMso "PrintPreviewAndPrint"
    
        Dim h As LongPtr
        h = Application.ActiveWindow.Hwnd
    
        Dim root As UIAutomationClient.IUIAutomationElement
        Set root = uia.GetRootElement
        
        Dim eExcel As UIAutomationClient.IUIAutomationElement
        Dim eBackstageView As UIAutomationClient.IUIAutomationElement
        
        Set eExcel = FindElementByHandle(uia, root, TreeScope_Children, h, "エクセルを見つけられませんでした")
        Set GetBackstageView = FindElementByPropetyId(uia, eExcel, TreeScope_Subtree, "BackstageView", "バックステージを見つけられませんでした")
    End Function
    
    Public Sub ShowPrintBackstage _
        (Optional ByVal printRange As PrintRangeType = PrintRangeType.Sheet _
        , Optional ByVal fromPage As Integer = -1 _
        , Optional ByVal toPage As Integer = -1 _
        , Optional ByVal copies As Integer = 1 _
        , Optional ByVal printerName As String)
        
        Dim uia As UIAutomationClient.CUIAutomation8
        Set uia = New UIAutomationClient.CUIAutomation8
        
        Dim eBackstageView As UIAutomationClient.IUIAutomationElement
        Set eBackstageView = GetBackstageView(uia)
    
        Dim timeOut As Date
        timeOut = Now + TimeValue("0:0:5")
        
        On Error Resume Next
        Do
    
            DoEvents
            Err.Clear
            
            Dim spins() As UIAutomationClient.IUIAutomationElement
            spins = FindElementsBy(uia, eBackstageView, TreeScope_Subtree, UIAutomationClient.UIA_PropertyIds.UIA_ControlTypePropertyId, UIAutomationClient.UIA_ControlTypeIds.UIA_SpinnerControlTypeId, "スピンを見つけられませんでした")
            Call SetSpinValue(spins, "部数", copies)
            Call SetSpinValue(spins, "ページ指定", IIf(fromPage > 0, fromPage, ""))
            Call SetSpinValue(spins, "から", IIf(fromPage > 0, toPage, ""))
        
            If (Now > timeOut And Err.Number <> 0) Then
                On Error GoTo 0
                Err.Raise vbObjectError + 512, Description:="スピンが見つからないか操作できませんでした"
            End If
        Loop While Err.Number <> 0
        On Error GoTo 0
    
        Dim eRng As UIAutomationClient.IUIAutomationElement
        Set eRng = FindElementByName(uia, eBackstageView, TreeScope_Subtree, "印刷対象", "印刷対象を見つけられません")
    
        Dim dropdown As UIAutomationClient.IUIAutomationExpandCollapsePattern
        Set dropdown = eRng.GetCurrentPattern(UIAutomationClient.UIA_PatternIds.UIA_ExpandCollapsePatternId)
        dropdown.Expand
        
        Dim items() As UIAutomationClient.IUIAutomationElement
        items = FindElementsBy(uia, eRng, TreeScope_Subtree, UIAutomationClient.UIA_PropertyIds.UIA_ControlTypePropertyId, UIAutomationClient.UIA_ControlTypeIds.UIA_ListItemControlTypeId, "印刷対象の選択項目を見つけられませんでした")
        Dim i As Integer
        i = printRange
        If (UBound(items) >= i) Then
            Dim sel As UIAutomationClient.IUIAutomationSelectionItemPattern
            Set sel = items(i).GetCurrentPattern(UIAutomationClient.UIA_PatternIds.UIA_SelectionItemPatternId)
            sel.Select
        End If
        dropdown.Collapse
    End Sub
    
    Public Function GetPageCount() As Integer
        Dim uia As UIAutomationClient.CUIAutomation8
        Set uia = New UIAutomationClient.CUIAutomation8
        
        Dim eBackstageView As UIAutomationClient.IUIAutomationElement
        Set eBackstageView = GetBackstageView(uia)
        
        Dim eCurrentPage As UIAutomationClient.IUIAutomationElement
        Dim eMaxPage  As UIAutomationClient.IUIAutomationElement
        Set eCurrentPage = FindElementByName(uia, eBackstageView, TreeScope_Subtree, "現在のページ", "現在ページが見つかりません")
        
        Dim w As UIAutomationClient.IUIAutomationTreeWalker
        Set w = uia.CreateTreeWalker(uia.CreateTrueCondition)
        Set eMaxPage = w.GetNextSiblingElement(eCurrentPage)
         
        GetPageCount = CInt(Replace(eMaxPage.CurrentName, "/", ""))
    End Function
    Win8.1+Excel2016でしか確認してません
    #Win7+Excel2013では動かなかった

    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    2018年1月6日 13:54
  • まずはありがとうございます。

    あまりに長いコードで、絶句、かつ大変にお手間をおかけしたこと心苦しく思います。
    まずは御礼まで。
    2018年1月10日 6:36
  • 私の技量不足故ではあるのですが、
    今書いていただいたソースを読んでいるところなのですが、理解が難しいです。
    もしよろしかったらでいいのですが、

    1.各ファンクションの目的
    2.二つあるサブルーチンの概要

    を解説いただくことはできないでしょうか。

    2018年1月12日 1:44