[[20190111213246]]　『画像の保存』（狭山）　ページの最後に飛ぶ

『画像の保存』（狭山）

お世話になります。
前回教えていただきましたコードとは違うのですが
エクセル画像を画像処理（後）というファイルに保存となるのですが
エクセル2013ではＪＰＧとして保存されるのですが
2016でエラーが出ないのですが画像が”真っ白状態”になってしまいます。
2013と2016の両方で実行して画像を保存することは可能であれば
ご教授をお願いいたします。

Sub PictureSave()

    Dim objFile As Object
    Dim Fname As String
    Dim ACWidth As Single
    Dim ACHeight As Single
    Dim TCht As Object
    Dim TargetRow As String
    For Each objFile In ActiveSheet.Shapes
        If objFile.Name Like "AddGroup*" Then
            objFile.CopyPicture
            TargetRow = Replace(objFile.Name, "AddGroup", "")
            TargetRow = (TargetRow - 1) * 29 + 2
            If Cells(TargetRow, 8).Value <> "" Then
                Fname = Cells(TargetRow, 8).Value
            Else
                Fname = "H" & TargetRow & "_NoData" & ".jpg"
            End If
            ACWidth = 499  tobj.Width
            ACHeight = 674  tobj.Height
            Set TCht = ActiveSheet.ChartObjects.Add(0, 0, ACWidth * 0.8, ACHeight * 0.8).Chart
            TCht.Paste
            TCht.Export Filename:=ThisWorkbook.Path & "\" & "画像処理（後）" & "\" & Fname, filtername:="JPG"
            TCht.Parent.Delete
        End If
    Next
End Sub

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

申し訳ございません。
前回ご教授いただきましたサイトを入れ忘れました。

http://www.excel.studio-kazu.jp/kw/20181207212356.html
（狭山） 2019/01/11(金) 21:42

＞TCht.Paste

の直前に、

TCht.parent.select

を追加してください。

（マナ） 2019/01/11(金) 22:09

（マナ）様
ありがとうございました。
画像として見れたのですがバージョンの関連で画像の大きさが変更（小さく）なるみたいです
やはり2013で行ってみたいと思います。
2013の方で画像を取り込み、エクセル内でJ列のセルを
取り込んだ画像に貼り付けてグループ化にして
画像処理（後）というファイルに保存と問題なくいくのですが
画像を拡大して見ますと右端の縦に線らしきものが出てしまい
コードのどこかに問題があるのかと思い下記に入れました。
ご教授をお願いいたします。

J列を画像化して貼り付けです。
Sub CreateCellData()

    Dim i As Long
    Dim j As Long
    Dim EndRow As Long
    EndRow = Cells(Rows.Count, 7).End(xlUp).Row
    j = 0
    Call Module1.GroupClear
    Call Module1.AddCellPictureDelete
'    Columns("J:J").ClearContents
    For i = 2 To EndRow Step 29
            j = j + 1
        If Cells(i, 7).Value <> "" And Cells(i + 1, 12).Value = "○" And Cells(i, 13).Value <> "" Then
'            Call Module1.SubCreateCellData1(i)
            Call Module1.SubCreateCellData2(j)
            Call Module1.ShapesIncrementop
            Call Module1.SubCreateCellData3(j)
        End If
    Next
End Sub

セルを画像化して貼り付けです。
Sub SubCreateCellData2(CellPicture As Long)

    Dim Row1 As Long
    Dim Row2 As Long
    Dim Row3 As Long
    Row1 = (CellPicture - 1) * 29 + 1
    Row2 = Row1 + 11
    Row3 = Row1 + 19
    Range(Cells(Row1, 10), Cells(Row2, 10)).CopyPicture
    Cells(Row3, 2).PasteSpecial
    Selection.Name = "AddCellPicture" & CellPicture

'---------------------------------------------

    '高さを5.2に調整
    Selection.ShapeRange.LockAspectRatio = msoFalse  '縦横比を非固定にする
    Selection.ShapeRange.Height = 149.2              '149=5.19  149.2=5.2  150=5.23
'---------------------------------------------

End Sub
（狭山） 2019/01/12(土) 11:39

これでどうなりますか

 Set TCht = ActiveSheet.ChartObjects.Add(0, 0, ACWidth * 0.8, ACHeight * 0.8).Chart
 TCht.ChartArea.Border.LineStyle = xlLineStyleNone

（マナ） 2019/01/12(土) 12:35

（マナ）様
有難うございます。
2013にて先ほどのを入れ変更してみましたら

Set TCht = ActiveSheet.ChartObjects.Add(0, 0, ACWidth * 0.8, ACHeight * 0.8).Chart

            TCht.Paste

↓

Set TCht = ActiveSheet.ChartObjects.Add(0, 0, ACWidth * 0.8, ACHeight * 0.8).Chart

 TCht.ChartArea.Border.LineStyle = xlLineStyleNone

移行後の画像が真っ白で表示されてしまいます。
ご教授をお願いいたします。
（狭山） 2019/01/12(土) 20:32

TCht.Paste

は、必要ですよ。

（マナ） 2019/01/12(土) 21:00

（マナ）様
大変失礼いたしました。
追加入力して画像として見えました。
変更する前よりは縦線が見えなくなりましたが
拡大をすると薄らと残ってしまいます。
ご教授をお願い出来ませんでしょうか
（狭山） 2019/01/12(土) 21:17

そうですか。これ以上は、わたしには無理そうです。

（マナ） 2019/01/12(土) 22:15

（マナ）様

ありがとうございました。
また、宜しくお願い致します。
（狭山） 2019/01/12(土) 22:21

コメント返信：

[ 一覧(最新更新順) ]

[[20190111213246]] 『画像の保存』（狭山） ページの最後に飛ぶ

[[20190111213246]]　『画像の保存』（狭山）　ページの最後に飛ぶ