VBAで画像整理したい！

こんにちは。この記事では、excel/ppt vbaで画像整理する際に便利なコードを作って備忘録的に保存しておきます。

Excel:セル中に合わせて画像を移動させる。

エクセルで画像を並べたい！というとき、位置を調整できます。
（悪名高い）方眼紙形式のネ申エクセルで画像をいい感じに配置し、資料を作成する際に便利。
利用する際は、十字キーを別途フォームで作成して各マクロを登録し、微調整するのに便利。
画像を選択→各マクロ（を登録したボタン）を実行！

位置合わせ

Sub gazomain_nochange()
On Error GoTo errlabel
Dim ToRight As Long, ToUpper As Long
ToRight = 0
ToUpper = 0
Call gazoChange(ToUpper, ToRight)
errlabel:
End Sub

→

Sub gazomain_Right()
On Error GoTo errlabel
Dim ToRight As Long, ToUpper As Long
ToRight = 1
ToUpper = 0
Call gazoChange(ToUpper, ToRight)
errlabel:
End Sub

←

Sub gazomain_Left()
On Error GoTo errlabel
Dim ToRight As Long, ToUpper As Long
ToRight = -1
ToUpper = 0
Call gazoChange(ToUpper, ToRight)
errlabel:
End Sub

↑

Sub gazomain_Up()
On Error GoTo errlabel
Dim ToRight As Long, ToUpper As Long
ToRight = 0
ToUpper = -1
Call gazoChange(ToUpper, ToRight)
errlabel:
End Sub

↓

Sub gazomain_Down()
On Error GoTo errlabel
Dim ToRight As Long, ToUpper As Long
ToRight = 0
ToUpper = 1
Call gazoChange(ToUpper, ToRight)
errlabel:
End Sub

本体

Sub gazoChange(RRR As Long, UUU As Long)
Dim shp1, shp As Shape
Dim TrgtT, TrgtL As Long
Dim changeT, changeL As Long
Dim nextrange As Range

For Each shp In Selection.ShapeRange
    targetname = shp.Name
    With shp.TopLeftCell
        Set nextrange = Cells((.Row + RRR), (.Column + UUU))
        For Each shp1 In ActiveSheet.Shapes
            If ((shp1.TopLeftCell.Row = .Row + UUU) And (shp1.TopLeftCell.Column = .Column + RRR)) Then
                shp1.Top = Cells(.Row, (.Column)).Top
                shp1.Left = Cells(.Row, (.Column)).Left
            End If
        Next shp1
    End With
    shp.Top = nextrange.Top
    shp.Left = nextrange.Left
Next shp

End Sub

PPT:画像の左右をくっつける（作成中）

パワーポイントでポンチ絵や図を並べるとき、図をきれいに接触させたい！時に使用する。
図が少なければ、ガイドラインに合わせればいいけども、パワポがだんだん込み入ってくると、どれに合わせればいいのかわからない。
そんな時に利用するとよいかも？（図を非表示にすればある程度はましになりますが、とはいえ面倒ですし）
ただ書き下しただけなので、後程清書したい思い。

a

Sub 基準の右に接する()
On Error GoTo errlabel

Dim i As Long, j As Long
Dim MaxLeft As Long
Dim champ As Long
Dim shpcount As Long

With ActiveWindow.Selection.ShapeRange
    shpcount = .Count
    MaxLeft = .Item(1).Left
    MaxTop = .Item(1).Top
    champ = 1

  For j = 1 To shpcount
    For i = 1 To shpcount
      If i <> champ Then
        If .Item(i).Left > MaxLeft Then
          .Item(i).Left = (.Item(champ).Left + .Item(champ).Width)
        Else
          MaxLeft = .Item(i).Left
          champ = i
        End If
      End If
    Next i
  Next j
End With

errlabel:
End Sub

Sub 基準の左に接する()
On Error GoTo errlabel

Dim i As Long, j As Long
Dim MaxLeft As Long
Dim champ As Long
Dim shpcount As Long

With ActiveWindow.Selection.ShapeRange
    shpcount = .Count
    MaxLeft = .Item(1).Left
    MaxTop = .Item(1).Top
    champ = 1

  For j = 1 To shpcount
    For i = 1 To shpcount
      If i <> champ Then
        If .Item(i).Left < MaxLeft Then
          .Item(i).Left = (.Item(champ).Left - .Item(i).Width)
        Else
          MaxLeft = .Item(i).Left
          champ = i
        End If
      End If
    Next i
  Next j
End With

errlabel:
End Sub
Sub 基準の上に接する()
  On Error GoTo errlabel
Dim i As Long, j As Long
Dim MaxTop As Long
Dim champ As Long
Dim shpcount As Long

With ActiveWindow.Selection.ShapeRange
    shpcount = .Count
    MaxTop = .Item(1).Top
    champ = 1

  For j = 1 To shpcount
    For i = 1 To shpcount
      If i <> champ Then
        If .Item(i).Top < MaxTop Then
          .Item(i).Top = (.Item(champ).Top - .Item(i).Height)
        Else
          MaxTop = .Item(i).Top
          champ = i
        End If
      End If
    Next i
  Next j
End With

errlabel:
End Sub

Sub 基準の下に接する()
On Error GoTo errlabel

Dim i As Long, j As Long
Dim MaxTop As Long
Dim champ As Long
Dim shpcount As Long

With ActiveWindow.Selection.ShapeRange
    shpcount = .Count
    MaxTop = .Item(1).Top
    champ = 1

  For j = 1 To shpcount
    For i = 1 To shpcount
      If i <> champ Then
        If .Item(i).Top > MaxTop Then
          .Item(i).Top = (.Item(champ).Top + .Item(champ).Height)
        Else
          MaxTop = .Item(i).Top
          champ = i
        End If
      End If
    Next i
  Next j
End With

errlabel:
End Sub