none
【ご教示ください】Excel2016 VBAを利用したPNG画像排出について RRS feed

  • 質問

  • お世話になります。

    以下をご教示頂けないでしょうか。

    ■環境

    Excel2016(Office365内)

    OS:Windows10

    ■問題点

    VBAを利用し、Excelのセル範囲を画像で保存(PNG)を行っております。

    Office2013環境では問題なく動作するのですが、2016では動作の一部に問題が発生しております。

    発生している問題:排出画像が真っ白になる

    これの解決方法をご教示ください。
    ※ステップイン実行を行うと問題なく動作します
     自動で動かすと排出される画像が真っ白になります
     動作から推測すると、空のチャートオブジェクトに画像を貼り付けする際
     白い画像が貼られてしまっていることが要因だと思っております

    <VBAコードは以下のようになっております>
    Sub 画像01()

    Dim tempBoolean As Boolean
    Dim Folname As String
    Dim FSO
    Dim Myfile
    Dim fil As String
    Dim cnt As Integer
    Dim Myfol, C As String
    Dim gazof As String
    Dim actsheetname As String
    Dim oShape As Shape

    actsheetname = "Sheet1"
    ThisWorkbook.Sheets(actsheetname).Select

    tempBoolean = ActiveWindow.DisplayGridlines

    '枠線
    ActiveWindow.DisplayGridlines = False

    '画像作成
    Range("D1:AP213").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    ActiveWindow.DisplayGridlines = tempBoolean

    Sheets("画像用").Select

    '画像貼付先
    ActiveSheet.Paste Destination:=Range("A1")
    Selection.ShapeRange.LockAspectRatio = msoTrue
    Selection.ShapeRange.Width = 900

    'png保存
    m_SavePath = dtop & "photo101" & ".png"
    Call SaveSelectionAsImage(m_SavePath)

    '画像削除
     For Each oShape In ActiveSheet.Shapes
       oShape.Delete
     Next

    End Sub

    '画像保存部分

    Public Sub SaveSelectionAsImage(ByVal argSavePath As String)
        Dim m_Width As Double
        Dim m_Height As Double
        
        If Len(argSavePath) > 0 Then
            Application.ScreenUpdating = False
            Selection.CopyPicture xlScreen, xlPicture
            
            DoEvents
            
            ActiveSheet.Paste
            With Selection
                m_Width = .Width + 8: m_Height = .Height + 8
                .CopyPicture xlScreen, xlBitmap
                .Delete
            End With
            On Error Resume Next
            With ActiveSheet.ChartObjects.Add(0, 0, m_Width, m_Height).Chart
                .Paste
                .ChartArea.Border.LineStyle = 0
                .Width = 1000
                .Export argSavePath, "PNG"
                .Parent.Delete
            End With
            On Error GoTo 0
            Application.ScreenUpdating = True
        End If
    End Sub

    以上です。

    2018年2月1日 6:35

回答

  • "chartObj.Activate  '追加" を入れたら動きました。
    改造してますが、きれいにしていると確認作業に時間が掛かりますので、そのままです。
    変更は SaveSelectionAsImage(ByVal argSavePath As String)マクロだけです。
    "ActiveSheet.Paste" が二重に入っていますので停止させています。
    画像の出力場所を変更しています。 "C:\var\photo101.png"

    Public Sub SaveSelectionAsImage(ByVal argSavePath As String)
        Dim m_Width As Double
        Dim m_Height As Double
         Dim chartObj As ChartObject
       
        If Len(argSavePath) > 0 Then
           ' Application.ScreenUpdating = False '停止
            Selection.CopyPicture xlScreen, xlPicture
            'DoEvents  '停止
           
           'ActiveSheet.Paste '停止
            With Selection
                m_Width = .Width + 8: m_Height = .Height + 8
                .CopyPicture xlScreen, xlBitmap
                'DoEvents  '追加
                .Delete
            End With
           
            On Error GoTo ERROR_DISP 'エラー捕捉開始
            Set chartObj = ActiveSheet.ChartObjects.Add(0, 0, m_Width, m_Height)
            chartObj.Activate  '追加
            With chartObj
               .Chart.Paste
               'DoEvents  '追加
               .Chart.Refresh  '追加
               .Chart.ChartArea.Border.LineStyle = 0
               '.Width = 1000  '停止
               .Chart.Export "C:\var\photo101.png", "PNG"
               .Chart.Parent.Delete
            End With
            Application.ScreenUpdating = True
        End If
        Exit Sub
    ERROR_DISP:
        MsgBox Err.Description
    End Sub

    2018年2月2日 2:14

すべての返信

  • "chartObj.Activate  '追加" を入れたら動きました。
    改造してますが、きれいにしていると確認作業に時間が掛かりますので、そのままです。
    変更は SaveSelectionAsImage(ByVal argSavePath As String)マクロだけです。
    "ActiveSheet.Paste" が二重に入っていますので停止させています。
    画像の出力場所を変更しています。 "C:\var\photo101.png"

    Public Sub SaveSelectionAsImage(ByVal argSavePath As String)
        Dim m_Width As Double
        Dim m_Height As Double
         Dim chartObj As ChartObject
       
        If Len(argSavePath) > 0 Then
           ' Application.ScreenUpdating = False '停止
            Selection.CopyPicture xlScreen, xlPicture
            'DoEvents  '停止
           
           'ActiveSheet.Paste '停止
            With Selection
                m_Width = .Width + 8: m_Height = .Height + 8
                .CopyPicture xlScreen, xlBitmap
                'DoEvents  '追加
                .Delete
            End With
           
            On Error GoTo ERROR_DISP 'エラー捕捉開始
            Set chartObj = ActiveSheet.ChartObjects.Add(0, 0, m_Width, m_Height)
            chartObj.Activate  '追加
            With chartObj
               .Chart.Paste
               'DoEvents  '追加
               .Chart.Refresh  '追加
               .Chart.ChartArea.Border.LineStyle = 0
               '.Width = 1000  '停止
               .Chart.Export "C:\var\photo101.png", "PNG"
               .Chart.Parent.Delete
            End With
            Application.ScreenUpdating = True
        End If
        Exit Sub
    ERROR_DISP:
        MsgBox Err.Description
    End Sub

    2018年2月2日 2:14
  • 返信頂いていたのに気がついておらず大変失礼致しました。
    ※メール通知がオンになっておりませんでした。

    頂いたコードを実行致しました。
    問題なく画像排出できました!

    本当に助かりました。
    また、回答が遅れてしまい本当に失礼致しました。
    今後とも宜しくお願い致します。

    2018年2月13日 2:29