| |
たびたびの回答を有り難うございます。
いくつか説明不足でした。職場のパソコンは富士通製のノートパソコンで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カードからコピー）また、回転等はしていません。
削除については、ルールがわかっていませんでした。申し訳ありませんでした。
|
|
β
- 17/4/17(月) 19:30 -
トキノハジメ
- 17/4/17(月) 18:32 -
ひでとし
- 17/4/15(土) 9:58 -
ペーターパン
- 17/4/14(金) 14:59 -
