写真を2分割する

以前にトリミングもどきでも紹介したが、今回はシートに写真を挿入し、その写真を2分割してみた。
e0080122_8345186.gif

コード的にはベタベタでもっとスッキリさせる必要もあるが・・・。あまり糞の役にも立ちそうにないのでこのままで実行させた。

Sub 分割()
 Dim mypic As Object, mypic1 As Shape, mypic2 As Shape
 Dim picW As Single, picBW As Single
 Dim myFname As String
  myFname = Application.GetOpenFilename(FileFilter:="すべての図(*.jpg),*.jpg")

   If myFname = "False" Then Exit Sub

   Set mypic = ActiveSheet.Pictures.Insert(myFname)

     picW = mypic.Width
     picBW = mypic.Width / 2

  mypic.Copy
  ActiveSheet.Paste
  Selection.Name = "mypic1"
    Set mypic1 = ActiveSheet.Shapes("mypic1")
     With mypic1.PictureFormat
       .CropRight = picBW
     End With

     With mypic1
       .Top = 20
       .Left = 20
       .IncrementRotation 350
     End With

  ActiveSheet.Paste
  Selection.Name = "mypic2"
    Set mypic2 = ActiveSheet.Shapes("mypic2")
     With mypic2.PictureFormat
       .CropLeft = picBW
     End With

    With mypic2
       .Top = 20
       .Left = 20 + picBW + 10
       .IncrementRotation 10
    End With
      mypic.Delete
    ActiveSheet.Shapes.Range(Array("mypic1", "mypic2")).Group
End Sub

こうしてみると、Withをネストすればよかったが・・・かなりメチャクチャだ。
しかし目的のものが出来たのでよしとする。
e0080122_849619.gif

[PR]
by slayer0210 | 2006-01-12 08:49 | マクロ


<< 任意の数で写真を分割する シート名の一部を入力すると選択する >>