[[20181105111656]]　『写真貼り付け縦横比解除』（ちーず）　ページの最後に飛ぶ

『写真貼り付け縦横比解除』（ちーず）

B列のセルにカーソルを合わせ、そのカーソルが選択しているセルに、
コピーしていた写真をペーストし、その写真を縦横比を固定でなく、
縦と横それぞれに縮尺を変えられるように
するコードを作ったのですが、msoFalseにしても、うまくいきません。
どのように修正したらよいですか？

また、本当はB2だけでなく、Bの列のどこの行にカーソルを合わせても
動くようにしたいのですが、、、
ご教授宜しくお願いします。

Sub B列写真貼り付け()
Range("B2").Select

  Dim shp As Shape
  Dim rng As Range

   If TypeName(Selection) <> "Range" Then Exit Sub

   For Each shp In ActiveSheet.Shapes
    Set rng = Range(shp.TopLeftCell, shp.BottomRightCell)
     If Not (Intersect(rng, Selection) Is Nothing) Then
      shp.ScaleWidth 0.3506469727, msoFalse, msoScaleFromTopLeft
    End If
   Next
 End Sub

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

命令が判らないときは、マクロの自動記録を使ってみると良いですよ。

      shp.LockAspectRatio = msoFalse
（???） 2018/11/05(月) 12:00

???さんありがとうございます。
shp.ScaleWidth 0.3506469727, msoFalse, msoScaleFromTopLeft
のどこに、shp.LockAspectRatio = msoFalse
を足せばよいのでしょうか？

（ちーず） 2018/11/05(月) 13:02

いや、足すのではなく、ScaleWidthを設定している前の行にでも1行挿入してみてください。
（???） 2018/11/05(月) 13:05

 ちょっと作ってみました。

 Sub B列写真貼り付け()

    Dim Shp As Shape
    Dim Rng As Range
    Dim ClipB
    Dim i As Long

    Set Rng = ActiveCell
    If Rng.Column <> 2 Then
        MsgBox "B列を選択して実行してください", vbCritical
        Exit Sub
    End If

    ClipB = Application.ClipboardFormats
    If ClipB(1) = xlClipboardFormatPICT Or ClipB(1) = xlClipboardFormatBitmap Then
        Rng.PasteSpecial
        For Each Shp In Selection.ShapeRange
            Shp.LockAspectRatio = msoFalse
            Shp.ScaleWidth 0.3506469727, msoFalse, msoScaleFromTopLeft
        Next
    Else
        MsgBox "画像をクリップボードに格納してください。", vbCritical
        Exit Sub
    End If

 End Sub
（ろっくん） 2018/11/05(月) 13:13

 あ、ペーストからではないんですね・・。
 勘違いしました。
（ろっくん） 2018/11/05(月) 13:18

ろっくんさんありがとうございます。
？？？さんもありがとうございます。

ろっくんさん、いただいたコードで試してみたのですが
貼りつけた写真はそのまま残ったまま、新たにリサイズされた写真が
B列の右に少しずれたところに写真が作成されてしまいます。

貼りつけた写真はB列の左上に置いたまま
貼りつけた写真をリサイズしたいのですが
どのようにしたらよいのでしょうか。

また、幅は Shp.ScaleWidth 0.3506469727で変更できるのですが
Heightの数字も指定したいのですが、どのようにしたらいいですか？

質問ばかりですみません。

（ちーず） 2018/11/05(月) 13:37

高さも、マクロの自動記録で必要なキーワードが得られますよ。と言うより、既に ScaleWidth メソッドが判っている訳で、高さなら ScaleHeight を幅と同じようにしてみろ、としか…。（幅指定する1行とは別に、もう1行追加ですよ？）
（???） 2018/11/05(月) 13:56

 すみません、ちょっと整理させてください。
 写真は既に貼り付けてある状態でマクロを実行、でいいですか？
 次にセルを選択？
 貼り付けてある写真をそのセルにリサイズしてコピー？移動？
 写真が複数ある場合はどうするんでしょう？

 てっきりクリップボードに写真を格納している状態からスタートかと
 思い込んでしまってたので、ちーずさんの意図とズレてしまったかも
 しれません。。
（ろっくん） 2018/11/05(月) 13:58

 連投すみません。
 こんな感じでしょうか。

 Sub B列写真貼り付け()

    Dim Shp As Shape
    Dim Rng As Range

    Set Rng = ActiveCell
    If Rng.Column <> 2 Then
        MsgBox "B列を選択して実行してください", vbCritical
        Exit Sub
    End If

    For i = 1 To ActiveSheet.Shapes.Count
        Set Shp = ActiveSheet.Shapes(i)
        Shp.Copy
        Rng.PasteSpecial
        For Each Shp In Selection.ShapeRange
            Shp.LockAspectRatio = msoFalse
            Shp.ScaleWidth 0.3506469727, msoFalse, msoScaleFromTopLeft
            Shp.ScaleHeight 0.5, msoFalse, msoScaleFromTopLeftmsoScaleFromTopLeft
        Next Shp
    Next

 End Sub
（ろっくん） 2018/11/05(月) 14:37

ろっくんさん、コードをありがとうございます。
やりたいことに近づいてきました！！＾＾

説明下手でごめんなさい
＞写真は既に貼り付けてある状態でマクロを実行、でいいですか？
はい、そうです。

まず先に、
１・クリップボードの写真をコピーしておいてからエクセルにうつります。
２・貼り付けしたいＢ列のセルにカーソルを置きます。
　　貼付けるのは、ｶｰｿﾙを置いたセルです。
３・ctrl+Vで貼付けしたら、縦横比固定でなく、なおかつ横（幅）と縦（高さ）を
　　個別に数字で指定したサイズで貼り付けられる
↓
同じように、１から３を繰り返し（貼付けしたいところにカーソルを置き、ペーストしたら指定のサイズで貼り付けられる）で、行いたいです。

伝わりずらい文章で大変すみません。

（ちーず） 2018/11/05(月) 15:39

 説明文からみると、画像はクリップボードにある状態で、エクセルへ 貼り付け時にサイズ変更、
 でしょうか？
 画像をctrl+vで貼付したときのイベントの書き方はちょっとわかりませんので代案で・・。

 1.画像をクリップボードに格納
 2.貼り付け先のB列のセルをダブルクリック

 コードを書いておきます。

 シートモジュールに
 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim Shp As Shape
    Dim ClipB
    Dim i As Long
    Dim ClipBObj As Object

    ClipB = Application.ClipboardFormats
    If Target.Column = 2 And ClipB(1) = xlClipboardFormatPICT Or ClipB(1) = xlClipboardFormatBitmap Then
        Set ClipBObj = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        Target.PasteSpecial
        For Each Shp In Selection.ShapeRange
            Shp.LockAspectRatio = msoFalse
            Shp.ScaleWidth 0.3506469727, msoFalse, msoScaleFromTopLeft
            Shp.ScaleHeight 0.5, msoFalse, msoScaleFromTopLeftmsoScaleFromTopLeft
        Next
        With ClipBObj
            .SetText ""
            .PutInClipboard
        End With
        Set ClipBObj = Nothing
    End If

 End Sub
（ろっくん） 2018/11/05(月) 17:32

ろっくんさん、めちゃすごコードをありがとうございます！！
やりたいことができました！！！！

大変ずうずうしいお願いなのですが
下記２点もできればお返事もらえるとうれしいです

■元の写真の大きさから拡縮率でサイズ入力していますが
元の写真サイズに関係なく、指定したサイズに収める（縦と横両方）にしたい

■写真のプレビュー画面（大アイコンや特大アイコンなど）のサムネイルをコピーしても
貼りつけることってできるのでしょうか？
今のクリップボードから貼り付けの仕様はそのままに、サムネイルからコピーしても貼りつくようにしたいのです（Ｔ＿Ｔ）

（ちーず） 2018/11/06(火) 11:17

 .ScaleWidthと.ScaleHeightは元サイズからの拡縮率を指定するものです。
 サイズを直に指定する場合は.Widthと.Heightプロパティに値をポイントで指定します。

 サムネイルのコピーからの貼付については私はできません。
 代案ですが、B列をダブルクリック時にクリップボードに画像が格納されている場合は
 そのまま貼付、クリップボードに画像が格納されていない場合は画像を選択する
 ダイアログから画像を選択する、というのはどうでしょう。
 画像の幅と高さは任意で変えてください。

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Const ShpWidth = 150   '幅
    Const ShpHeight = 100  '高さ

    Dim Shp As Shape
    Dim ClipB
    Dim i As Long
    Dim ClipBObj As Object
    Dim PictF

    ClipB = Application.ClipboardFormats
    If Target.Column = 2 And ClipB(1) = xlClipboardFormatPICT Or ClipB(1) = xlClipboardFormatBitmap Then
        Set ClipBObj = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        Target.PasteSpecial
        With ClipBObj
            .SetText ""
            .PutInClipboard
        End With
        Set ClipBObj = Nothing
    ElseIf Target.Column = 2 Then
        PictF = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp")
        If VarType(PictF) = vbBoolean Then
            Cancel = True
            Exit Sub
        End If
        ActiveSheet.Pictures.Insert(PictF).Select
        Cancel = True
    End If
    For Each Shp In Selection.ShapeRange
        Shp.LockAspectRatio = False
        Shp.Width = ShpWidth
        Shp.Height = ShpHeight
    Next

 End Sub
（ろっくん） 2018/11/06(火) 12:55

コメント返信：

[ 一覧(最新更新順) ]

[[20181105111656]] 『写真貼り付け縦横比解除』（ちーず） ページの最後に飛ぶ

[[20181105111656]]　『写真貼り付け縦横比解除』（ちーず）　ページの最後に飛ぶ