Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

3344 / 76735

←次へ　｜　前へ→


	【79022】Re:エクセルへの写真画像の貼り付け

ひでとし

- 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カードからコピー）また、回転等はしていません。

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

0 hits

▼

【79005】エクセルへの写真画像の貼り付け ひでとし 17/4/10(月) 21:34