[[20180508202448]]　『画像のトリミングのマクロをご指導ください。』（ほういち）　ページの最後に飛ぶ

『画像のトリミングのマクロをご指導ください。』（ほういち）

 こんにちは。マクロ初心者の芳一と申します。

 会社のシステムの画面をコピーしExcelに貼り付けてその画像をトリミング
 するマクロを登録したのですが、2回目に実行したところデバックが表示
 されました。
 原因はActiveSheet.Shapes("Picture 28").Selectのコード化と思われます。
 複数の画像を１つずつ指定してトリミングをするのですが、どのように修正
 をしたらよいかご指導いただけませんでしょうか?

    ActiveSheet.Shapes("Picture 28").Select
    Selection.ShapeRange.PictureFormat.Brightness = 0.5
    Selection.ShapeRange.PictureFormat.Contrast = 0.5
    Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic
    Selection.ShapeRange.PictureFormat.CropLeft = 0#
    Selection.ShapeRange.PictureFormat.CropRight = 0#
    Selection.ShapeRange.PictureFormat.CropTop = 17.01
    Selection.ShapeRange.PictureFormat.CropBottom = 0#
    Selection.Cut
    Range("B3").Select
    ActiveSheet.Paste
End Sub

＜使用 Excel：Excel2007、使用 OS：WindowsXP ＞

 マクロ初心者の芳一です。

 いろいろとネットで検索をしておりまして、なんとなく自分で解決できそう な感じと
 なりました。
 もしダメでしたらまた書き込みいたしますのでその時は皆さまご教授くださ い。

 よろしくお願いします。
（ほういち） 2018/05/08(火) 21:47

 すみません。ほういちです。

 自力で解決しようと思ったのですが、やっぱり力及ばずでした。(◞‸◟)
 皆さま。ご教授いただけますでしょうか?

 やりたい作業の流れは次の通りです。

 エクセルのシートに会社のシステムの画面コピーしたものを２画面貼り付けます。
 ※ここは手動です。

 ここからマクロで作業したいのですが・・・
 １つ目の画面コピーの図を指定してトリミングを設定します。
 トリミングの加工後の図を指定してB2セルに移動します。
 次に２つ目の画面コピーの図を指定してトリミングを設定します。
 トリミングの加工後の図を指定してB15セルに移動します。

 とりあえずここまでのマクロをどのようにコードを組んだらよいか、ご教授いただけ
 ませんでしょうか?

（ほういち） 2018/05/08(火) 22:27

 アクティブシート上にあるpictureタイプのシェープを順に取得して加工後に
 B2,B15,B28…と移動させるコードです。
 参考まで。

 Sub TEST()

    Dim Shp As Shape
    Dim RW As Long
    Dim TopVal As Long

    RW = 2
    For Each Shp In ActiveSheet.Shapes
        If Shp.Type = msoPicture Then
            With Shp
                With .PictureFormat
                    .Brightness = 0.5
                    .Contrast = 0.5
                    .ColorType = msoPictureAutomatic
                    .CropTop = 17.01
                End With
                .Top = Rows(RW).Top
                .Left = Columns(2).Left
            End With
        End If
        RW = RW + 13
    Next Shp

 End Sub
（ろっくん） 2018/05/09(水) 08:45

ALT+PRINTSCREENしてウィンドウ画像を作成し、Excelに貼った後にマクロ実行すると、タイトル部分を削除した画像を生成するコードですかね？

CutしてからPasteすると、それは新しい画像を追加した事になりますよね。だけど、その画像は既に処理済みなので、また処理してはいけません。なので、複数画像の後の方から先頭までをループする事で、追加分を処理しないようにしましょう。

 Sub test()
    Dim i As Long

    For i = ActiveSheet.Shapes.Count To 1 Step -1
        With ActiveSheet.Shapes(i)
            If .Type = msoPicture Then
                With .PictureFormat
                    .Brightness = 0.5
                    .Contrast = 0.5
                    .ColorType = msoPictureAutomatic
                    .CropLeft = 0#
                    .CropRight = 0#
                    .CropTop = 17.01
                    .CropBottom = 0#
                End With
                .Cut
                ActiveSheet.Cells(i * 13 - 11, "B").PasteSpecial
            End If
        End With
    Next i
 End Sub
（???） 2018/05/09(水) 10:31

ろっくんさん
？？？さん
マクロご指導いただきありがとうございました。
なんとか自分の作業したいマクロができそうです。

（ほういち） 2018/05/09(水) 22:53

コメント返信：

[ 一覧(最新更新順) ]

[[20180508202448]] 『画像のトリミングのマクロをご指導ください。』（ほういち） ページの最後に飛ぶ

[[20180508202448]]　『画像のトリミングのマクロをご指導ください。』（ほういち）　ページの最後に飛ぶ