Excel VBA質問箱 IV

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

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


8498 / 76732 ←次へ | 前へ→

【73804】Re:写真挿入のVBA
質問  wen  - 13/2/16(土) 19:10 -

引用なし
パスワード
   ▼kanabun さん:

返信どうもありがとうございます、試してみましたが、リンクではなく貼りこみができました!!
ただ、貼り込まれた写真がどうもサイズがうまくいきません。
いったん切り取って、貼り付けにすると、サイズ指定の命令がうまく効かなくなるといったことはありますか?(まだ自分でコードを理解できていなくて、質問が的外れでしたら申し訳ないです)
セルに合わせたサイズでの挿入ではなく、幅80mm、高さ60mm、指定で写真の挿入というコードで再度試してみたいのですが、

'画像を挿入
  With ActiveSheet.Pictures.Insert(PicFile)
    rX = Target.Width / .Width
    rY = Target.Height / .Height
    If rX > rY Then
      ratio = rY
    Else
      ratio = rX
    End If
    .Width = .Width * ratio
    .Height = .Height * ratio

の部分をどのように書き換えたらいいのかわかりません。

度々すみませんがご教授いただけると助かります。

よろしくお願いいたします。

>▼wen さん:
>
>こういう方法も(一応)あります。
>そのPictures.Insert方式のままで、Excelのバージョンが2010だったら
>いちど「図として切り取り」図の貼り付けをしてやれば、リンクしない
>通常の画像になります。
>
>Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
>                    Cancel As Boolean)
>  Dim PicFile As Variant
>  Dim rX As Double, rY As Double
>  Dim ratio As Double, L As Double, T As Double
>
>  '[ファイルを開く]ダイアログボックスを表示
>  PicFile = Application.GetOpenFilename( _
>            "画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp")
>  If VarType(PicFile) = vbBoolean Then Cancel = True: Exit Sub
>
>
>  Application.ScreenUpdating = False
>
>  '画像を挿入
>  With ActiveSheet.Pictures.Insert(PicFile)
>    rX = Target.Width / .Width
>    rY = Target.Height / .Height
>    If rX > rY Then
>      ratio = rY
>    Else
>      ratio = rX
>    End If
>    .Width = .Width * ratio
>    .Height = .Height * ratio
>
>    'セルの中央(横方向/縦方向の中央)に配置
>    L = Target.Left + (Target.Width - .Width) / 2
>    T = Target.Top + (Target.Height - .Height) / 2
>    
>    Dim is2010 As Boolean
>    is2010 = Val(Application.Version) > 13
>    is2010 = True
>    If is2010 Then 'ver14 = XL2010
>      .CopyPicture 'クリップボードに画像コピー
>      .Delete 'いったん削除
>    Else
>      .Left = L
>      .Top = T
>    End If
>  End With
>  If is2010 Then
>    Target.Activate
>    ActiveSheet.Paste
>    With Selection
>      .Left = L
>      .Top = T
>    End With
>  End If
>  Application.ScreenUpdating = True
>  Cancel = True
>End Sub
>
>参考まで。
1,881 hits

【73797】写真挿入のVBA wen 13/2/15(金) 23:03 質問
【73799】Re:写真挿入のVBA UO3 13/2/16(土) 5:21 発言
【73803】Re:写真挿入のVBA wen 13/2/16(土) 18:53 お礼
【73800】Re:写真挿入のVBA kanabun 13/2/16(土) 9:12 発言
【73801】Re:写真挿入のVBA kanabun 13/2/16(土) 9:14 発言
【73804】Re:写真挿入のVBA wen 13/2/16(土) 19:10 質問
【73806】Re:写真挿入のVBA kanabun 13/2/16(土) 20:53 発言
【73808】Re:写真挿入のVBA kanabun 13/2/17(日) 9:38 発言
【73834】Re:写真挿入のVBA wen 13/2/18(月) 18:16 質問
【73835】Re:写真挿入のVBA kanabun 13/2/18(月) 18:45 発言
【73836】Re:写真挿入のVBA kanabun 13/2/18(月) 20:07 発言

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