Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


5088 / 13644 ツリー ←次へ | 前へ→

【52673】画像の位置取得 07/11/25(日) 20:42 質問[未読]
【52682】Re:画像の位置取得 n 07/11/26(月) 11:59 発言[未読]
【52687】Re:画像の位置取得 07/11/26(月) 14:14 お礼[未読]
【52691】Re:画像の位置取得 n 07/11/26(月) 17:42 発言[未読]
【52692】Re:画像の位置取得 n 07/11/26(月) 20:16 発言[未読]
【52696】Re:画像の位置取得 07/11/26(月) 21:21 お礼[未読]
【52688】Re:画像の位置取得 Lindy 07/11/26(月) 14:30 発言[未読]
【52689】Re:画像の位置取得 Lindy 07/11/26(月) 15:25 発言[未読]
【52690】Re:画像の位置取得 07/11/26(月) 16:06 お礼[未読]

【52673】画像の位置取得
質問    - 07/11/25(日) 20:42 -

引用なし
パスワード
   お世話になっております。
初心者ですが、勉強のために下記方法を試してみました。

画像保存機能を使えば写真のトリミングが出来るのでは?と思いやってみました。
1.写真を壁紙として表示
2.範囲を設定して画像保存
と、やってみたら、設定した範囲と異なる画像が保存されていました。
ネットを見てると画像処理にはよくTopとかLeftなどが出てくるので、これかな?と思い
本を見ながら適当に試してみましたが、うまくいきません。
下記コードは、普通に作成した表を画像保存する時に使っているコードを、★に変更して試したものです。

【現象】
どの場所を範囲設定しても、保存された画像はいつも
Range(”A1”)に近い部分が保存される(縦横サイズはOKです)。

【質問】
設定範囲した部分を、そのまま保存するためには、どうしたらいいのか教えて下さい。

Sub トリミングTEST()

Dim slcRng As Range
Dim crtObj As Chart
Dim strMsg As String, intMsg As String

ActiveWindow.DisplayGridlines = False
  strMsg = "保存ファイル名は?"
      intMsg = InputBox(strMsg)
      If intMsg = "" Then Exit Sub
    intMsg = "\" & intMsg

Set slcRng = Selection
  slcRng.CopyPicture appearance:=xlScreen, Format:=xlPicture

Set crtObj = ActiveSheet.ChartObjects.Add _
    (slcRng.Top, slcRng.Left, slcRng.Width, slcRng.Height).Chart '★試した箇所
  
'Set crtObj = ActiveSheet.ChartObjects.Add(0, 0, slcRng.Width, slcRng.Height).Chart '★元々のコード

  With crtObj
    .Paste
    .Export Filename:=ActiveWorkbook.Path & intMsg & ".gif", filtername:="GIF"
    .Parent.Delete
  End With

MsgBox "ブックが保存されているフォルダに保存されました"

End Sub

【52682】Re:画像の位置取得
発言  n  - 07/11/26(月) 11:59 -

引用なし
パスワード
   こんにちは。
『シートの背景』を利用...とは、良いアイデアですね。でも
>どの場所を範囲設定しても、保存された画像はいつも
>Range(”A1”)に近い部分が保存される(縦横サイズはOKです)。
これは仕様のようです。(詳しくないので間違っているかもしれません)

いきなり代替案で申し訳ないですが
普通に写真ファイルをシート上に読み込んで、右クリック[図ツールバーの表示]にある
[トリミング]機能を使うわけにはいかないのですか?
( ┘ と ┌ が重なったようなアイコン)

【52687】Re:画像の位置取得
お礼    - 07/11/26(月) 14:14 -

引用なし
パスワード
   ▼n さん:
ご回答ありがとうございます。

「写真のトリミン」で特に困っているわけではないんです。
あくまで、VBAの練習のためにやってみました。
シートで扱う数値・文字データーについては、だいたい分ってきたので
これまで経験の少ない(無い)画像やフォームについて勉強しようかなと思って
やって見ました。


>『シートの背景』を利用...とは、良いアイデアですね
初心者のため、少ない知識でも、知恵でなんとかならないかと思ってます。
実は図形に壁紙を取り込んで、綺麗な表題をつけたいと思ったのですが
図形への壁紙の取り込みが分らず、質問したコードを作って見ました
(この時は、普通の壁紙なので、取得位置に関係ないため、うまく行きました)
質問は、これを応用しようとしたものです。

今後とも宜しくお願いします。
ありがとうございました。

【52688】Re:画像の位置取得
発言  Lindy  - 07/11/26(月) 14:30 -

引用なし
パスワード
   ▼岳 さん:
こんにちは

背景ですとどこの範囲でもその範囲の左上を基準として背景がセットされるので
(たとえばA1から数行非表示にしてみてもちゃんと表示されます)
背景表示でセル範囲を取得、その後に図として切り取る感じでどうでしょうか?

以下サンプルです

Sub トリミングTEST()

Dim slcRng As Range, intMsg As String
Dim strPic As Variant, myPic As Object

strPic = Application.GetOpenFilename(, , "画像ファイルを選択")
If VarType(strPic) = vbBoolean Then Exit Sub
With Workbooks.Add
 Application.ScreenUpdating = False
 With ActiveSheet
  .Cells.ColumnWidth = 0.38
  .Cells.RowHeight = 3.75
  .SetBackgroundPicture strPic
  Set myPic = .Pictures.Insert(strPic)
  myPic.Visible = False
 End With
 ActiveWindow.DisplayGridlines = False
 Application.ScreenUpdating = True
 Set slcRng = Application.InputBox("切り取り範囲を選択", Type:=8)
 intMsg = InputBox("保存ファイル名は?")
 If intMsg = "" Or slcRng Is Nothing Then GoTo ErrHdl
 intMsg = "\" & intMsg
 myPic.Visible = True
 Application.ScreenUpdating = False
 slcRng.CopyPicture xlScreen, xlPicture
 With ActiveSheet.ChartObjects.Add(0, 0, slcRng.Width, slcRng.Height).Chart
  .Paste
  .Export Filename:=ThisWorkbook.Path & intMsg & ".gif", filtername:="GIF"
  .Parent.Delete
 End With
 MsgBox "ブックが保存されているフォルダに保存されました"
ErrHdl:
 .Close False
 Application.ScreenUpdating = True
End With
End Sub

【52689】Re:画像の位置取得
発言  Lindy  - 07/11/26(月) 15:25 -

引用なし
パスワード
   ▼岳 さん:
すみません、1箇所ミスがあったので訂正します。

Sub トリミングTEST()

Dim slcRng As Range, intMsg As String
Dim strPic As Variant, myPic As Object

strPic = Application.GetOpenFilename(, , "画像ファイルを選択")
If VarType(strPic) = vbBoolean Then Exit Sub
With Workbooks.Add
 Application.ScreenUpdating = False
 With .ActiveSheet
  .Cells.ColumnWidth = 0.38
  .Cells.RowHeight = 3.75
  .SetBackgroundPicture strPic
  Set myPic = .Pictures.Insert(strPic)
  myPic.Visible = False
 End With
 ActiveWindow.DisplayGridlines = False
 Application.ScreenUpdating = True
 Set slcRng = Application.InputBox("切り取り範囲を選択", Type:=8)
 intMsg = InputBox("保存ファイル名は?")
 If intMsg = "" Or slcRng Is Nothing Then GoTo ErrHdl
 intMsg = "\" & intMsg
 myPic.Visible = True
 Application.ScreenUpdating = False
 slcRng.CopyPicture xlScreen, xlPicture
 With ActiveSheet.ChartObjects.Add(0, 0, slcRng.Width, slcRng.Height).Chart
  .Paste
  .Export Filename:=ThisWorkbook.Path & intMsg & ".gif", filtername:="GIF"
  .Parent.Delete
 End With
 MsgBox "ブックが保存されているフォルダに保存されました"
ErrHdl:
 .Close False
 Application.ScreenUpdating = True
End With
End Sub

【52690】Re:画像の位置取得
お礼    - 07/11/26(月) 16:06 -

引用なし
パスワード
   ▼Lindy さん:
ありがとうございました。意図した通りの結果が得られました。
普段、質問投稿すると数時間のうちに何らかの回答を頂いていたので、nさんの言うように無理なのかなと思ってしまいました。

嬉しかったのは、写真の取得方法と範囲の設定方法が、私のとった方法と全く同じだったことです。
(質問投稿には、その前の基本の部分を掲示しました)
初心者にとっては、なにか、ものすごく励みになりました。

まだコードの内容の確認をしていませんが、教えて頂いたコードで勉強させて頂きます。
私の実験では最初のコードで問題ありませんでした。改良版と比較しながら再度確かめてみます。
お礼が遅くなり、申し訳ありませんでした。
今後とも宜しくお願いいたします。

【52691】Re:画像の位置取得
発言  n  - 07/11/26(月) 17:42 -

引用なし
パスワード
   >「写真のトリミン」で特に困っているわけではないんです。
そうでしたか。
一応、トリミング案としてはRectangleを使ってこんなイメージでした。

Sub try1()
  If Application.Dialogs(xlDialogInsertPicture).Show = False Then Exit Sub
  MsgBox "トリミング範囲ドラッグ後、写真クリック。"
  Application.CommandBars.FindControl(ID:=1111).Execute
  Selection.OnAction = "try2"
End Sub

Sub try2()
  Dim sp As Shape
  Dim pc As Picture

  With ActiveSheet
    Set pc = .Pictures(Application.Caller)
    Set sp = .Shapes(.Shapes.Count)
    If sp.Name <> pc.Name Then
      With pc.ShapeRange.PictureFormat
        .CropLeft = sp.Left - pc.Left
        .CropTop = sp.Top - pc.Top
        .CropRight = (pc.Left + pc.Width) - (sp.Left + sp.Width)
        .CropBottom = (pc.Top + pc.Height) - (sp.Top + sp.Height)
      End With
      sp.Delete
    End If
    pc.OnAction = ""
    'pc.CopyPicture appearance:=xlScreen, Format:=xlPicture
    '.Paste pc.TopLeftCell
    'pc.Delete
  End With
  
  Set pc = Nothing
  Set sp = Nothing
End Sub

でもLindyさんの案が基本路線に沿ってるので良さそうですね。
何かの参考になれば幸いです。

【52692】Re:画像の位置取得
発言  n  - 07/11/26(月) 20:16 -

引用なし
パスワード
   >.CropRight = (pc.Left + pc.Width) - (sp.Left + sp.Width)
>.CropBottom = (pc.Top + pc.Height) - (sp.Top + sp.Height)
すみません。この部分ムダな事やってましたorz
.CropRight = pc.Width - sp.Width
.CropBottom = pc.Height - sp.Height

【52696】Re:画像の位置取得
お礼    - 07/11/26(月) 21:21 -

引用なし
パスワード
   ▼n さん:
最後まで面倒を見ていただき、ありがとうございました。
Lindyさんのコードは私の質問、そのものズバリの回答だったんですが
内容理解のためと、取得できた写真がかなり荒れる(ちょっと拡大するとセルの罫線の痕跡が現われる)ために、それを直そうとしていたんで、nさんからの再度の回答に気が付くのが遅くなりました。
申し訳ありませんでした。

nさんの方法、初めて経験しました。
「トリミングに困っていない」というのは別のソフトがあるからなんですが
nさんから教えて頂いた方が、かなり使いやすいです。得した気分です。

初めて見るコードもあるため。これから1行1行、動作確認しながら勉強して行きます。
本当に有難うございました。

5088 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free