Excel VBA質問箱 IV

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

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


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

【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 発言[未読]

【73797】写真挿入のVBA
質問  wen  - 13/2/15(金) 23:03 -

引用なし
パスワード
   エクセルで写真集を作るためのVBAですが、以下のVBAでは画像がリンク貼り付けになってしまいます。どうしたらエクセルファイルに画像を貼りこみで保存できるのでしょうか?
よろしくお願いいたします。

やりたいことは、まずダブルクリックでダイアログボックスを表示させ、挿入したい写真を選択、写真がセルに合わせた大きさに縮小、セルの中央に写真を配置。以上です。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
                    Cancel As Boolean)
  Dim PicFile As Variant
  Dim rX As Double, rY 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
      .Height = .Height * rY
    Else
      .Width = .Width * rX
    End If

    'セルの中央(横方向/縦方向の中央)に配置
    .Left = Target.Left + (Target.Width - .Width) / 2
    .Top = Target.Top + (Target.Height - .Height) / 2
  End With
  
  Application.ScreenUpdating = True
  Cancel = True
End Sub

【73799】Re:写真挿入のVBA
発言  UO3  - 13/2/16(土) 5:21 -

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

おはようございます

エクセルは2010でしょうか?
2007までは、Pictures.Insert で問題なかったのですが、2010 からはリンク貼付になってしまいます。

これはバグだと言われていますが、しょうがないので、皆さん、ActiveSheet.Shapes.AddPictureを使って回避しておられるようです。

「画像 Insert リンク貼付になってしまう」あたりで検索しますとコード例がたくさんヒットするかと思います。

【73800】Re:写真挿入のVBA
発言  kanabun  - 13/2/16(土) 9:12 -

引用なし
パスワード
   ▼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

参考まで。

【73801】Re:写真挿入のVBA
発言  kanabun  - 13/2/16(土) 9:14 -

引用なし
パスワード
   ごめん。

>    is2010 = Val(Application.Version) > 13
>    is2010 = True ← 不要

下は不要です

(XL2003 上で 疑似2010実験をしてました m(_ _)m )

【73803】Re:写真挿入のVBA
お礼  wen  - 13/2/16(土) 18:53 -

引用なし
パスワード
   UO3 さん

ありがとうございます。

はい、こちらで使用しているのはエクセル2010です。
ヴァージョンによってこういったバグ的なものがあるんですね。

まだVBAは慣れなくてわからないことが多いのですが、返信ありがとうございました。

>▼wen さん:
>
>おはようございます
>
>エクセルは2010でしょうか?
>2007までは、Pictures.Insert で問題なかったのですが、2010 からはリンク貼付になってしまいます。
>
>これはバグだと言われていますが、しょうがないので、皆さん、ActiveSheet.Shapes.AddPictureを使って回避しておられるようです。
>
>「画像 Insert リンク貼付になってしまう」あたりで検索しますとコード例がたくさんヒットするかと思います。

【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
>
>参考まで。

【73806】Re:写真挿入のVBA
発言  kanabun  - 13/2/16(土) 20:53 -

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

>返信どうもありがとうございます、試してみましたが、リンクではなく貼りこみができました!!
>ただ、貼り込まれた写真がどうもサイズがうまくいきません。
>いったん切り取って、貼り付けにすると、サイズ指定の命令がうまく効かなくなるといったことはありますか?

>'画像を挿入
>  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

は、当初のコードとは変えています。

当初のコードは
>  '画像を挿入
>  With ActiveSheet.Pictures.Insert(PicFile)
>    rX = Target.Width / .Width
>    rY = Target.Height / .Height
>    If rX > rY Then
>      .Height = .Height * rY
>    Else
>      .Width = .Width * rX
>    End If
でした。これは、rX と rY の値によって、
高さ方向か 横幅方向か、どちらか一方だけをサイズ変更しています。

ちょっと手持ちのデジカメ画像で試したところ、
高さ方向で セルの高さに縮小され、 横幅は元の画像のまま、の
「思いっきりひしゃげた」画像が挿入されてしまいましたので、
上のように、
高さ方向も横幅方向も「同じ比率でサイズ縮小する」コードに変えました。

wen さんのほうで、その部分はうまくいっていたのなら、そこは元通りに
直してみてください。

【73808】Re:写真挿入のVBA
発言  kanabun  - 13/2/17(日) 9:38 -

引用なし
パスワード
   ▼wen さん:すみません。
Excel2010 上で動かしてみておっしゃってることが呑み込めました。

>ただ、貼り込まれた写真がどうもサイズがうまくいきません。

>'画像を挿入
>  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
>
>の部分をどのように書き換えたらいいのかわかりません。

ステップ実行(トレース)していきますと、

   (たとえば ratio が 0.5 だったとします)

こちらの【2003】 では
>    .Width = .Width * ratio
を実行すると、横方向だけ 1/2 に縮小され、一時的に ひしゃげた
図になります。
そして
>    .Height = .Height * ratio
を実行して、高さも 1/2に縮小され、元の縦横比が維持された図に
縮小されます。

ところが【2010】では、そうならないんですね!

>    .Width = .Width * ratio
を実行すると、Widthはもちろん高さも 1/2 に縮小されます。
そして
>    .Height = .Height * ratio
を実行すると、1/2に縮小された図が 【さらに 1/2】に縮小され、
とてつもなく小さな図になってしまいました!!

おそらく、この不具合をおっしゃってたのだろうと解せました。

改訂版です


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
                    Cancel As Boolean)
  Dim PicFile As Variant
  Dim rX#, rY#, Ratio# ' (ratioX, ratioY, ratio)
  Dim L#, T#, W#, H#  '(Left, Top, Width, Height)

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

【73834】Re:写真挿入のVBA
質問  wen  - 13/2/18(月) 18:16 -

引用なし
パスワード
   ▼kanabun さん:
改訂版、ありがとうございます!!2010でうまく行きました!

イメージしていた通りの作業が、可能になりました。大変勉強になりました。

続けての質問で恐縮なのですが、写真のサイズを指定するコードの書き方がわかれば、ご教授いただけませんでしょうか?

改定版の、「'画像を挿入」「'セルの中央(横方向/縦方向の中央)に配置」のぶ宇文について、
・挿入する写真のサイズを「縦60mmに変更」、「横80mmに変更」もしくは「横は縦の縮小と同じ倍率に縮小」
・挿入するセルの中央に配置

以上のコードについて、可能であればご教授ください。

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


>▼wen さん:すみません。
>Excel2010 上で動かしてみておっしゃってることが呑み込めました。
>
>>ただ、貼り込まれた写真がどうもサイズがうまくいきません。
>
>>'画像を挿入
>>  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
>>
>>の部分をどのように書き換えたらいいのかわかりません。
>
>ステップ実行(トレース)していきますと、
>
>   (たとえば ratio が 0.5 だったとします)
>
>こちらの【2003】 では
>>    .Width = .Width * ratio
>を実行すると、横方向だけ 1/2 に縮小され、一時的に ひしゃげた
>図になります。
>そして
>>    .Height = .Height * ratio
>を実行して、高さも 1/2に縮小され、元の縦横比が維持された図に
>縮小されます。
>
>ところが【2010】では、そうならないんですね!
>
>>    .Width = .Width * ratio
>を実行すると、Widthはもちろん高さも 1/2 に縮小されます。
>そして
>>    .Height = .Height * ratio
>を実行すると、1/2に縮小された図が 【さらに 1/2】に縮小され、
>とてつもなく小さな図になってしまいました!!
>
>おそらく、この不具合をおっしゃってたのだろうと解せました。
>
>改訂版です
>
>
>Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
>                    Cancel As Boolean)
>  Dim PicFile As Variant
>  Dim rX#, rY#, Ratio# ' (ratioX, ratioY, ratio)
>  Dim L#, T#, W#, H#  '(Left, Top, Width, Height)
>
>  '[ファイルを開く]ダイアログボックスを表示
>  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 = Target.Width / W
>    rY = Target.Height / H
>    If rX > rY Then
>      Ratio = rY
>    Else
>      Ratio = rX
>    End If
>    .Width = W * Ratio
>    .Height = H * 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

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

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

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

画像サイズは(セルのサイズや図形のサイズと同じく)ポイント単位なのです。
ですから、縦60mm とか 横80mm とかを ポイント単位に換算する方法を調べて
教えてください。
そうすれば、これまでのコードで、なんとかなると思いますよ。

【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

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

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