| |
Sub Sample1()
Dim pic As Picture
Dim f As Variant
Dim Target As Range
'A1の画像を削除
For Each pic In ActiveSheet.Pictures
If pic.TopLeftCell.Address = "$A$2" Then pic.Delete
Next
Set Target = Range("A2:A10")
f = Application.GetOpenFilename _
("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
If f <> False Then
With ActiveSheet.Shapes.AddPicture(Filename:=f, LinkToFile:=False, _
SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
Width:=-1, Height:=-1) '-1 元の大きさで貼り付け
'===============タテヨコの縮尺を保持して拡大または縮小
.LockAspectRatio = True '縦横比率の維持（念のため）
.Height = Target.Height
End With
End If
End Sub
Sub Sample2()
Dim pic As Picture
Dim f As Variant
Dim Target As Range
'A1の画像を削除
For Each pic In ActiveSheet.Pictures
If pic.TopLeftCell.Address = "$A$12" Then pic.Delete
Next
Set Target = Range("A12:A20")
f = Application.GetOpenFilename _
("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
If f <> False Then
With ActiveSheet.Shapes.AddPicture(Filename:=f, LinkToFile:=False, _
SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
Width:=-1, Height:=-1) '-1 元の大きさで貼り付け
'===============タテヨコの縮尺を保持して拡大または縮小
.LockAspectRatio = True '縦横比率の維持（念のため）
.Height = Target.Height
End With
End If
End Sub
というＶＢＡを使っているのですが、Excel2007で使用すると、A2に貼られたPICは
よいのですが、A12に貼られたPICはA12のセル左隅から少し下に、さらにA22では
ズレがおおきくなり、最終的にA301ではとんでもなくズレが生じてしまいます。
環境は以下の通りです
PC:FUJITSU D751/C win7 Excel2010 14.0.7177.5000(32bit)
Printer:Canon LBP-3600
PC:FUJITSU CE227D win10 Excel2010 14.0.4760.1000(32bit)
Printer:Canon LBP-8620
余白は共に左2.5、上・下・右1.0
|
|
acs
- 16/12/19(月) 15:49 -
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
