Excel VBA質問箱 IV

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

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


50 / 73441 ←次へ | 前へ→

【79022】Re:エクセルへの写真画像の貼り付け
回答  ひでとし E-MAIL  - 17/4/15(土) 9:58 -

引用なし
パスワード
   たびたびの回答を有り難うございます。

いくつか説明不足でした。職場のパソコンは富士通製のノートパソコンでwin10 64bit Office Professional Plus 2016 64bit が組み込まれた状態で従業員全員に1台ずつ与えられています。その環境ですとAddPictureの命令がうまく機能してくれません。下記のマクロです。自宅は、win10 32bit office2016 32bitで動きますが、最初の投稿と同様で画像が少し小さく取り込まれてしまいます。

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

Dim fd As FileDialog
Dim Shp As Shape
Dim cell_r As Double, gazou_r As Double

Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Filters.Clear
fd.Filters.Add "画像ファイル", "*.bmp; *.gif; *.jpg; *.jpeg; *.png", 1
If fd.Show Then
   Set Shp = Me.Shapes.AddPicture(fd.SelectedItems(1), _
           msoFalse, msoTrue, Target.Left, Target.Top, 1, 1)
  
   Shp.ScaleHeight 1, msoTrue
   Shp.ScaleWidth 1, msoTrue
   Shp.LockAspectRatio = msoTrue
   With Shp
     cell_r = Target.Height / Target.Width
    gazou_r = .Height / .Width
    
    If cell_r < gazou_r Then
      .Height = Target.Height
    Else
      .Width = Target.Width
    End If

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

End Sub

取り込む画像は、ほとんどが顔写真です。したがってデジカメを縦にして写真を撮りそのファイルをそのままパソコンに取り込んでいます。(ソフトは使わずに直接SDカードからコピー)また、回転等はしていません。

削除については、ルールがわかっていませんでした。申し訳ありませんでした。

37 hits

【79005】エクセルへの写真画像の貼り付け ひでとし 17/4/10(月) 21:34 質問[未読]
【79016】Re:エクセルへの写真画像の貼り付け ひでとし 17/4/14(金) 20:43 発言[未読]
【79018】Re:エクセルへの写真画像の貼り付け β 17/4/14(金) 20:57 発言[未読]
【79019】Re:エクセルへの写真画像の貼り付け γ 17/4/14(金) 23:18 発言[未読]
【79020】Re:エクセルへの写真画像の貼り付け ひでとし 17/4/15(土) 3:43 質問[未読]
【79021】Re:エクセルへの写真画像の貼り付け β 17/4/15(土) 8:55 発言[未読]
【79022】Re:エクセルへの写真画像の貼り付け ひでとし 17/4/15(土) 9:58 回答[未読]

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