[[20200423111700]]　『選択範囲を画像でコピーすると小さくなる』（アクア）　ページの最後に飛ぶ

『選択範囲を画像でコピーすると小さくなる』（アクア）

sheet1の左上から、縦にtatemasu数（およそ300行）、横にyokomasu数（およそ1200列）の範囲をコピーし、chartオブジェクトに貼り付ける、ということを以下のVBAで実行しようとしました。
しかし、クリップボードに貼り付けられた範囲は、とても小さなものとなってしまい、chartオブジェクトに貼られた画像も小さくなってしまいます。
Copypictureを実行した直後のクリップボードの画像は既に予期したものより小さく、作成したchartオブジェクトの大きさは予期した画像のサイズと同じになっておりました。以上のことから、クリップボードへのコピーが何らかの理由でおかしいと思うのですが…。
何卒、改善策をご教授下さいませ。

Set rg = Sheets("sheet1").Range(Sheets("sheet1").Cells(1, 1), Sheets("sheet1").Cells(tatemasu, yokomasu))
rg.CopyPicture appearance:=xlScreen, Format:=xlPicture
Set cht = Sheets("sheet1").ChartObjects.Add(0, 0, rg.Width, rg.Height).Chart
cht.Parent.Select
cht.Paste

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

 こんばんは！
以下はHelpからですが、、
xlScreenは、
ピクチャは画面の表示にできる限り近い形でコピーされます。 
とあります。
画面の表示サイズを変えてみてはどうでしょうか？

 または、、xlPrinterにしてみるとか。。。

 XlPictureAppearance 列挙 
ピクチャをコピーする方法を指定します。
バージョン情報
 追加バージョン:  Excel 2007

 名前 値 説明 
xlPrinter 2 ピクチャは印刷するときと同じ形でコピーされます。 
xlScreen 1 ピクチャは画面の表示にできる限り近い形でコピーされます。 
（SoulMan） 2020/04/23(木) 20:21

趣旨とは違う可能性が大きいのですが、

1200列選択しても、私のexcel環境上ではCopyPictureとしては約24570points（標準幅でQM列）までしか貼り付けられませんでした。
当然、セルコピーでは貼り付けられるので、PAINTに貼り付けてみましたが、やはり、QM列まででしか貼りつきませんでした。
QM列サイズから余裕を見て、A:QL幅の24516ポイントずつまでに分割して貼り付けてみました。
分割を跨いでobjectがあるとこの方法ではだめな場合があるかもしれません。
chartの右に余裕が無いと全ては貼り付けられないようなので4ポイント大きくしました。

Sub test()

    Dim sp As Chart
    Dim r As Range
    Dim ret
    Dim wMax As Double
    Dim c As Long, l As Long
    Dim lpic As Double, hosei As Double
    On Error Resume Next
    ActiveSheet.ChartObjects.Delete
    ActiveSheet.Shapes(1).Delete
    On Error GoTo 0
    wMax = 24516    '24571.5
    Cells.ClearContents
    With Range("A1").Resize(300, 1200)
        For Each r In .Rows(1).Cells
            r.Value = Split(r.Address(0, 0), "1")(0)
            r.Offset(.Rows.Count - 1).Value = r.Value
        Next
        ActiveSheet.Shapes.AddShape msoShapeOval, 20, 42, .Width, 200
        Set sp = ActiveSheet.ChartObjects.Add(.Offset(, .Columns.Count + 5).Left, 0, .Width + 4, .Height).Chart
        sp.ChartArea.Format.Line.Visible = msoFalse
        sp.ChartArea.Format.Fill.Visible = msoFalse
        c = 1
        Set r = .Resize(, c)
        Do Until .Columns.Count < c
            For i = c To .Columns.Count - 1
                l = l + 1
                If wMax < r.Resize(, l).Width Then Exit For
            Next
            If l < 2 Then Exit Do
            Set r = r.Resize(, l - 1)
            ret = r.CopyPicture(xlScreen, xlPicture)
            Debug.Print r.Address(0, 0), r.Columns.Count,
            l = 0
            sp.Parent.Select
            sp.Paste
            If lpic = 0 Then
                Selection.ShapeRange.IncrementLeft -20
                lpic = Selection.ShapeRange.Left
                hosei = -1.5        '不明現物合わせ
            Else
                Selection.Left = lpic + hosei
                hosei = hosei * 2   '不明現物合わせ
            End If
            lpic = lpic + Selection.Width '+ hosei
            c = i - 1
            Set r = r.Offset(, r.Columns.Count).Resize(, 1)
            Application.Goto r
            Debug.Print r(1).Address(0, 0)
        Loop
        sp.Parent.Left = 0
        sp.Parent.Top = .Offset(1).Top
    End With
    Application.Goto Range("QL1")   '最初の分割点の手前
 End Sub

＜使用 Excel：Excel2016、使用 OS：Windows10(32)＞

（kazuo） 2020/04/24(金) 07:43

お二方、お答え頂きまして誠に有難うございました。

あまり大きな横幅は自動ではクリップボードにコピーできないものとして考えます。
また、kazuo様のマクロは非常に参考になりました。今回の件では使用できませんでしたが、似たような案件で参考にさせて頂きたく存じます。
（アクア） 2020/04/24(金) 16:33

コメント返信：

[ 一覧(最新更新順) ]

[[20200423111700]] 『選択範囲を画像でコピーすると小さくなる』（アクア） ページの最後に飛ぶ

[[20200423111700]]　『選択範囲を画像でコピーすると小さくなる』（アクア）　ページの最後に飛ぶ