[[20120310224144]]　『図の位置を調整』（ぽん）　ページの最後に飛ぶ

『図の位置を調整』（ぽん）

 図のいちを微妙に調整したいのですがコードを教えてください。
 Sub ボタン426_Click()

'
Dim i As Variant, x As Double, y As Double
i = Application.InputBox _

        ("1～500の値を指定して下さい。" & vbLf & _
        "最後に「-」をつけると、左に並びます。", Type:=2)
i = StrConv(i, vbNarrow)
    If 0 < Val(i) And Val(i) < 500 Then
        If TypeName(Selection) = "Range" Then
            With ActiveCell
                x = .Offset(, IIf(Right(i, 1) = "-", 1, 0)).Left
                y = .Offset(1).Top
            End With
        Else
            With Selection.ShapeRange
                x = .Left + IIf(Right(i, 1) = "-", 0, .Width)
                y = .Top + .Height
            End With
        End If
            Sheets("倉庫").Shapes("Picture " & Val(i)).Copy
            ActiveSheet.Paste
            With Selection.ShapeRange
                .Left = x - IIf(Right(i, 1) = "-", .Width, 0)
                .Top = y - .Height
            End With
    ElseIf i <> "False" Then
        MsgBox "入力した値が不正です。"
    End If
End Sub

 ベストの図の調整位置のコードです。

 ActiveSheet.Unprotect
Dim pic As Picture
ActiveSheet.Paste
    For Each pic In ActiveSheet.Pictures
    Selection.ShapeRange.PictureFormat.Brightness = 0.5
    Selection.ShapeRange.PictureFormat.Contrast = 0.5
    Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic
    Selection.ShapeRange.PictureFormat.CropLeft = 2
    Selection.ShapeRange.PictureFormat.CropRight = 0#
    Selection.ShapeRange.PictureFormat.CropTop = 4
    Selection.ShapeRange.PictureFormat.CropBottom = 0#
        pic.Height = 43
        pic.Width = 130
    Next
 ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False
 End Sub

 前半のコードは
[[20091106222909]]『棚割りソフト』（みさ）
 この時に私が作ったものと似ている様に思いますが。。。
 今回のなさりたい事と　どの程度一致しているのでしょう？

 ＞ベストの図の調整位置のコードです。
 のコードでは、図形の位置が決まっている様ですが。。。

 マクロで、番号を入れることによって
 　Sheets("倉庫").Shapes("Picture " & Val(i))の図を一枚だけ
 　ベストの図の位置に貼り付けたい
 って事でしょうか？

 その場合、図形を削除する部分が無いので　実行するたびに重なってしまう事に成りそうですが。。。

 仕様の説明をしていただいた方が良い様に思います。

 (HANA)

前回HANAさんにお世話になりましたコードです。
例えばセルをG2の結合セルに合わせるとここのセルに画像が調整され張り付く感じです。Ｇ2　Ｇ5と結合セルは下に続きます。結合セルの詳細はＧ2がG2:H4の結合になります。
イメージだとこんなコードです。

 Dim rng As Range
    Dim orng As Range
    On Error Resume Next
    Set rng = Selection
    If Err.Number = 0 Then
       Set orng = Application.InputBox("貼り付けるセルの範囲をドラック選択又は直接入力して下さい。", , , , , , , 8)
       If Err.Number = 0 Then
    Application.GoTo orng
          With ActiveSheet.Pictures.Paste(link:=True)
             .Interior.ColorIndex = xlColorIndexAutomatic
             .Left = orng.Left
             .Top = orng.Top
             .Width = orng.Width
             .Height = orng.Height
          End With
       End If
    End If
    On Error GoTo 0
    Dim myFileName As String
    If TypeName(Selection) <> "Range" Then
        MsgBox "セルを選択して実行して下さい。"
        Exit Sub
    End If
    myFileName = Application.GetOpenFilename( _
                    FileFilter:="画像 ,*.jpg; *.gif; *.bmp", MultiSelect:=False)
    If myFileName <> "False" Then
        With ActiveSheet.Pictures.Insert(myFileName)
            .Left = Selection.Left
            .Top = Selection.Top
            .Width = Selection.Width
            .Height = Selection.Height
        End With
    End If
End Sub

この上のコードと組合したイメージで先ほどのHANAさんが理解していただいた※マクロで、番号を入れることによって

 　Sheets("倉庫").Shapes("Picture " & Val(i))の図を一枚だけ
 　ベストの図の位置に貼り付けたい
この作業を組み合わせたいのですがお願いできませんでしょうか？（ぽん）

 実際には前回のHANAさんコードが一番いいのですが結合セルにあわせてマクロ実行すると微妙に枠線に重なってしまいます。希望はこのままのコードがいいのですがイメージでコードを載せておきました。
もし前回のコードを調整可能であれば調整していただけないでしょうか？（ぽん）

 同じ方でしたか。
 お名前が違うので、違う方かと思っていました。

 問題は
 ＞微妙に枠線に重なってしまいます。
 だけで、サイズ変更等は必要無いのですよね？

 また、基本仕様として
 　１．実行前にセルが選択されていた場合
 　　　　セルの左下を基準に貼り付ける
 　２．実行前に画像が選択されていた場合
 　　　　画像の右下を基準に貼り付ける
 と成っていると思いますが、
 思った位置でないのは　１のパターンでのみだと思えば良いでしょうか？

 ずれれば良い大きさは、どのセルで実行した時も一定でしょうか？

 図形はセルの左下を基準に（セルの枠を基準に）貼りつきます。
 ですから、ぴったり重なっているのが正常ですが
 単純に、「枠の内側から配置される様にしたい」と言う事だったでしょうか？

 と、言う事であれば
                x = .Offset(, IIf(Right(i, 1) = "-", 1, 0)).Left
                y = .Offset(1).Top
 ここの所を調整してみて貰えると良いのではないかと思います。
 上にずらしたい場合は、y = .Offset(1).Top - 10
 の様に。

 右にずらしたい場合は、マイナスするのかプラスにするのか判断が必要なので
 少し長く成りますが
   x = .Offset(, IIf(Right(i, 1) = "-", 1, 0)).Left + 10 * IIf(Right(i, 1) = "-", -1, 1)
 こんな感じで、「10」の所を調整して下さい。

 (HANA)

 HANAさんまたの回答ありがとうございました。みさです。
教えていただいたコードで調整出来ました。今回も大変お世話になりました。ありがとうございました。
（ぽん）

 そこの調整で良かったですか。
 でしたら、簡単な変更で済んで良かったですね。

 動きに変わりは有りませんが
 調整の数字は他の場合に変更する事も有ると思いますので
   x = .Offset(, IIf(Right(i, 1) = "-", 1, 0)).Left + IIf(Right(i, 1) = "-", -1, 1) * 10
 の様に後ろに持って行っておいた方が良かったかもしれません。

 まだご覧になっておられましたら、お手数ですが
 変更しておいて頂けると良いと思います。

 (HANA)

 HANAさんご親切に再度ご指導いただきありがとうございます。
書き換えときました。有難うございました。（ぽん）

 もう一つ質問お願いします。
エクセル2003と2007だと図のサイズの縦の寸法が違うのはなぜでしょうか？
図を合わせる時のコードですがエクセル2007だと横はＯＫですが縦が大きくなつてしまいます。
 ActiveSheet.Unprotect
Dim pic As Picture
ActiveSheet.Paste
    For Each pic In ActiveSheet.Pictures
    Selection.ShapeRange.PictureFormat.Brightness = 0.5
    Selection.ShapeRange.PictureFormat.Contrast = 0.5
    Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic
    Selection.ShapeRange.PictureFormat.CropLeft = 2
    Selection.ShapeRange.PictureFormat.CropRight = 0#
    Selection.ShapeRange.PictureFormat.CropTop = 4
    Selection.ShapeRange.PictureFormat.CropBottom = 0#
        pic.Height = 43
        pic.Width = 130
    Next

 End Sub
色々数値を変えましたがわかりません？よろしくお願いします。（ぽん）

 pic.Height = 43
この部分で調整できませんなぜでしょうか？（ぽん）

 ちょっとよく分かっていませんが
 図のサイズを変更するのですよね？

 pic.ShapeRange.Height = ○○
 としてみるとどうですか？

 (HANA)

何度もすみませんです。
エクセル2007で入れて試しましたがだめでした。
エクセル2007ではだめなんですかね？？（ぽん）

 2007でやってみました。

 原因はおそらく
 　図形を選択して、右クリック→サイズとプロパティ(Z)
 の「拡大/縮小」の所に
 　■縦横比を固定する(A)
 にチェックが入っている事だと思います。

 サイズを変更する前に
   pic.ShapeRange.LockAspectRatio = msoFalse
 で、チェックを外すと個別に指定が出来る様に成ると思います。

 ただ、このマクロを実行すると　そのシートに有る
 すべての図が同じ大きさに成ってしまうと思いますが
 それで良いのでしょうか？

 また、サイズ変更以外の設定は　貼り付けたものに関してのみ実行されますが
 それもそれで　意図している事なのでしょうか？

 (HANA)

 HANAさん回答ありがとうございます。
今日夜試して見ます。
確かに全ての図が同じ大きさになります。
できればサイズ変更以外の設定は　※貼り付けたものに関してのみ実行のが理想的です。
（ぽん）

 ＞確かに全ての図が同じ大きさになります。
 と言う印象からは、意図していない結果に成っている印象を受けますが

 ＞できればサイズ変更以外の設定は　
 ＞※貼り付けたものに関してのみ実行のが理想的です。
 でしたら、理想通りと言う事ですか？？

 (HANA)

 こんばんわ！
 pic.ShapeRange.LockAspectRatio = msoFalse
を入力して実行したら解決しました。
何度も何度もすみませんでした。
HANAさんありがとうございました。（ぽん）

コメント返信：

[ 一覧(最新更新順) ]

[[20120310224144]] 『図の位置を調整』（ぽん） ページの最後に飛ぶ

[[20120310224144]]　『図の位置を調整』（ぽん）　ページの最後に飛ぶ