Excel VBA質問箱 IV

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

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


8467 / 76732 ←次へ | 前へ→

【73836】Re:写真挿入のVBA
発言  kanabun  - 13/2/18(月) 20:07 -

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

>・挿入する写真のサイズを「縦60mmに変更」、「横80mmに変更」もしくは「横は縦の縮小と同じ倍率に縮小」
>・挿入するセルの中央に配置
>
>以上のコードについて、

mm単位をポイント単位に変換する方法は調べていただくとして、
たとえばですが
よこサイズを 200ポイント、たてサイズを150 ポイント

>  Const MyX = 200, MyY = 150 '(挿入後画像サイズ:単位ポイント)

にしたい、としますと、
こんな感じでしょうかね?


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
  Dim W As Double, H As Double
  Const MyX = 200, MyY = 150 '(挿入後画像サイズ:単位ポイント)

  '[ファイルを開く]ダイアログボックスを表示
  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)
    W = .Width
    H = .Height
    rX = MyX / W
    rY = MyY / H
    If rX > rY Then
      Ratio = rY
    Else
      Ratio = rX
    End If
    .Width = W * Ratio
    .Height = H * Ratio

    'セルの中央(横方向/縦方向の中央)に配置
    L = Target.Left ' + (MyX - .Width) / 2
    T = Target.Top '+ (MyY - .Height) / 2
    
    Dim is2010 As Boolean
    is2010 = Val(Application.Version) > 13
    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

↑このばあい、セルのたて×よこ サイズは無関係になりますので、
> 'セルの中央(横方向/縦方向の中央)に配置
の部分の処理はありません。

2,021 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 発言

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