みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

EXCEL VBAで画像をトリミング

Excelのワークシート上に画像(pic1)と四角の図形(waku)があります。

pic1にwakuを重ね、トリミングする場所を視覚的に確認したあと、VBAを実行し、wakuと同じ位置・サイズでpic1をトリミングするということを考えています。

とりあえず、実験的に左側をトリミングするマクロを作ってみましたがうまくいきません。

やってみた手順としては・・・
1.wakuの左端位置を取得
2.pic1の左端位置を取得
3.その差分を取得
4.差分と同サイズ、pic1の左側をトリミングする
・・・です。

Sub 左端をトリミング()

'枠の位置を取得
Dim wLeft As Single
wLeft = ActiveSheet.Shapes("waku").Left

'写真の位置を取得
Dim pLeft As Single
pLeft = ActiveSheet.Shapes("pct1").Left

'左側の差分を取得
Dim lTrim As Single

lTrim = wLeft - pLeft

ActiveSheet.Shapes("pct1").Select
Selection.ShapeRange.PictureFormat.CropLeft = lTrim


End Sub

結果としては想定しているものの2倍分くらい、トリミングされてしまいます。

最後の一文が、よくわからないまま、ネットから拾ってきた感じで使用しており、そこに問題があるのかと思うのですが・・・

どのようにするのが正しいのか、教えていただければ幸いです。

最終的には同様に上端を、右端・下端についてはそれぞれの図形のサイズの差からトリミングすべきポイントを抽出して希望のサイズにトリミングするつもりでいます。

ちなみに趣旨は・・・
・PCの知識の少ない人でも出来るようにしたい。
・wakuをリサイズさせないことで、縦横比・画像サイズを固定したい。
・・・というものです。

「VBAなんか使わなくても、こうすれば簡単じゃん!」みたいな方法があればあわせて教えていただ得れば幸いです。

投稿日時 - 2012-08-18 13:06:05

QNo.7650256

困ってます

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(5)

ANo.5

ぁ..Sub try は Doの前に以下3行追加したほうがベターでしたね..orz

sp.Width = 120 '固定したいWidth
sp.Height = 90 '固定したいHeight
sp.ZOrder msoBringToFront '最前面

投稿日時 - 2012-08-20 20:17:26

ANo.4

とりあえず倍率が問題なら
Sub test()
  Dim p As Picture
  Dim s As Shape
  Dim w As Single
  Dim h As Single
  Dim x As Double
  Dim y As Double

  Set p = ActiveSheet.Pictures("pct1")
  Set s = ActiveSheet.Shapes("waku")

  'wakuサイズ固定したいなら姑息ですが結果オーライな?
  's.Width = 400
  's.Height = 300

  '以下pの倍率取得
  w = p.Width
  h = p.Height
  p.ShapeRange.ScaleWidth 1, msoTrue
  p.ShapeRange.ScaleHeight 1, msoTrue
  x = p.Width / w
  y = p.Height / h
  '倍率取得したら戻す
  p.Width = w
  p.Height = h
  'トリム処理。マイナス値は考慮してない。
  With p.ShapeRange.PictureFormat
    .CropLeft = (s.Left - p.Left) * x
    .CropTop = (s.Top - p.Top) * y
    .CropRight = (p.Width - s.Width) * x
    .CropBottom = (p.Height - s.Height) * y
  End With
  s.Left = 0
  s.Top = 0
End Sub
こんな感じで。



以下参考。
四角Shapeにマクロtryを登録し、画像を選択してShapeをクリックすると
マウスカーソルに合わせてShapeが移動します。
トリミング位置に合わせてもう一度Shapeをクリック。

'標準モジュール
Option Explicit
Private Declare Function GetCursorPos Lib "user32" ( _
                   ByRef lpPoint As POINTAPI) As Long
Private Declare Sub Sleep Lib "kernel32" ( _
             ByVal dwMilliseconds As Long)
Private Type POINTAPI
  x As Long
  y As Long
End Type
Private MoP As POINTAPI
Private flg As Boolean
'-------------------------------------------------
'Shapeは透過、最前面配置にしておく。
'このtryをShapeに登録する。
'Pictureを選択してShapeクリックで実行。
'~~~~~~~~~~~~~~~~~
Sub try()
  Const DPI As Long = 96 'Dot per inch 取り敢えず固定
  Const PPI As Long = 72 'Point per inch
  Dim pc  As Picture
  Dim sp  As Shape
  Dim w   As Single
  Dim h   As Single
  Dim x   As Double
  Dim y   As Double

  If flg Or (TypeName(Selection) <> "Picture") Then
    flg = False
    Exit Sub
  End If

  On Error GoTo ErrHandler

  flg = True
  Set pc = Selection
  With pc.ShapeRange
    .Rotation = 0
    With .PictureFormat
      .CropLeft = 0
      .CropTop = 0
      .CropRight = 0
      .CropBottom = 0
    End With
  End With

  With Application
    .ScreenUpdating = False
    'WindowZoom100、分割なし限定。
    With .ActiveWindow
      .Zoom = 100
      .SplitColumn = 0
      .SplitRow = 0
    End With
    .ScreenUpdating = True
    .StatusBar = ""
    .Cursor = xlNorthwestArrow
    Set sp = ActiveSheet.Shapes(.Caller)
  End With

  Do
    DoEvents
    Call Sleep(1)
    If Not flg Then Exit Do
    Call GetCursorPos(MoP)
    With ActiveWindow
      sp.Left = (MoP.x - .PointsToScreenPixelsX(0)) * PPI / DPI - (sp.Width / 2)
      sp.Top = (MoP.y - .PointsToScreenPixelsY(0)) * PPI / DPI - (sp.Height / 2)
    End With
  Loop

  Application.ScreenUpdating = False
  With ActiveSheet
    If Not Intersect(.Range(pc.TopLeftCell, pc.BottomRightCell), _
             .Range(sp.TopLeftCell, sp.BottomRightCell)) Is Nothing Then
      w = pc.Width
      h = pc.Height
      pc.ShapeRange.ScaleWidth 1, msoTrue
      pc.ShapeRange.ScaleHeight 1, msoTrue
      x = pc.Width / w
      y = pc.Height / h
      pc.Width = w
      pc.Height = h
      With pc.ShapeRange.PictureFormat
        .CropLeft = Application.Max(0, (sp.Left - pc.Left) * x)
        .CropTop = Application.Max(0, (sp.Top - pc.Top) * y)
        .CropRight = Application.Max(0, (pc.Width - sp.Width) * x)
        .CropBottom = Application.Max(0, (pc.Height - sp.Height) * y)
      End With
    End If
  End With

  sp.Left = 0
  sp.Top = 0

ErrHandler:
  With Application
    .Cursor = xlDefault
    .StatusBar = False
    .ScreenUpdating = True
  End With
  Set pc = Nothing
  Set sp = Nothing
End Sub

うまくいかない時は捨ててください。

投稿日時 - 2012-08-20 19:35:00

ANo.3

・ wakuをリサイズさせない
たぶんムリ。移動を許すとリサイズもできます。
イベントか何かで(頻繁に)サイズ修復・・・するしか。wakuは図形じゃなく画像にすると、"透過部分を掴める"ので、扱いやすく、縁触らないのでリサイズもされにくいかな、と。

・縦横比・画像サイズを固定
ANo.2の通り、トリミングは拡縮に弱いです。初心者相手は壊されやすいのもあり、しっかりロックして操作制限するならトリミングが一番簡単ですが、うまくいかないよーなら後述の方法で。

・トリミング以外の方法
復元できないけど、「カット」でよければ別の手段も。
 1. セル範囲をコピーして
 2. (Excel2003なら) Shift押しながらメニューの[編集]
   (Excel2007~) ホームタブの[貼り付け]
   → 図として貼り付け
この操作でセル上の画像を切り出せます。
実装は、非表示の作業シートを用意しておきます。まず切り抜くセルがwakuと同じ位置&サイズになるよう調整し、その上に画像を。あとはセルをCopy -> PasteSpecialで画像化。
面倒だけど、拡大縮小や合成などに対応でき、画像処理には向きます。また、カットするのでファイルサイズは小さくなります。

・余談ですが
画像編集なら、Chart.ExportでGIF/PGN出力も簡単にできるので、調べてみるのもよいかと。
目的によるけど。

投稿日時 - 2012-08-18 22:33:44

ANo.2

画像にサイズ(倍率)が指定されてると狂いますよ。
 ・Cropは「元の画像をトリム」、その後に倍率適用。
 ・Crop値も最終画像サイズも1ドット(=0.75pt)単位。

200%の画像だと、CropXX = 0.75 で 1.5ptトリミングされ、コレが最小単位になるってのが致命的。また、最終画像サイズの端数丸めでも歪むので、調整しようにも何かとメンドクサイです。
復旧不能でもよければ、「セルを画像としてコピー」で切り出しては?
ちょっと後で補足しに来ます・・・

★とりあえず、調べ方
MSDN@MicroSoftの開発者向けサイト。細かいパラメータの説明欲しいときは「MSND VBA Crop」とかでググる。
http://msdn.microsoft.com/ja-jp/library/microsoft.office.interop.excel.pictureformat_members(v=office.11)

また、VBE(エディタ)は便利な機能多いので、「ローカルウィンドウ」で変数やオブジェクトの中覗くとか勉強になるかと。
 Set obj = ActiveSheet.Shapes("pct1")
 w = obj.Width '←↑変数の中覗く

投稿日時 - 2012-08-18 19:03:08

ANo.1

ワークシートに貼り付けた集合写真上に顔の部分に合わせて複数の四角を並べ、一斉にトリミングというコードを回答した事があります。ご参考まで。
http://okwave.jp/qa/q6236568.html

投稿日時 - 2012-08-18 18:46:05

あなたにオススメの質問