| |
ponponさん、HKさん、こんにちは
そのままだと「ファイルサイズを小さくしたい」になっていない
ようなので、少しだけ手を入れてみました。
こんな感じです・・
変数名の変更は自分なりの整理ですので、気にしないでください。
Sub 取込()
'画像取込み
Const z1 As Single = 100 'サイズ指定
'↑ここで表示のサイズが変えられます。
Dim TopSetVal As Long
Dim LeftSetVal As Long
Dim Stc As Variant
Dim Selnm As Variant
Dim x1 As Single
Dim y1 As Single
Dim xx As Single
Dim yy As Single
Dim i As Long
'ChDir "D:\Other
Selnm = Application.GetOpenFilename(Title:="Ctrl、矢印ドラッグで複数選択", _
MultiSelect:=True)
If Not IsArray(Selnm) Then MsgBox "キャンセルされました": Exit Sub
TopSetVal = 30 '最上位の位置
LeftSetVal = 0 '左の位置
i = 1
On Error Resume Next
With ActiveSheet 'Sheet指定
For Each Stc In Selnm
With .Shapes(.Pictures.Insert(Stc).Name)
If Err.Number = 0 Then
.Name = Dir(Stc, vbNormal) '名前付け
.LockAspectRatio = msoTrue '固定
x1 = .Width '横取得
y1 = .Height '縦取得
If x1 > y1 Then '縦横判定
xx = z1 '横形
yy = y1 * z1 / x1
Else
yy = z1 '縦形
xx = x1 * z1 / y1
End If
.Width = xx
.Height = yy
'------------------------------------------------ここから
'一旦切り取って、形式を指定して貼り付け
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Select
Selection.Cut
ActiveSheet.PasteSpecial Format:="図 (JPEG)", _
Link:=False, DisplayAsIcon:=False
TopSetVal = TopSetVal + z1 + 10 '間隔指定
Selection.Left = LeftSetVal '左位置指定
Selection.Top = TopSetVal '上位置指定
'5個目で列変え
If i Mod 5 = 0 Then
LeftSetVal = LeftSetVal + xx + 10
TopSetVal = 30
End If
i = i + 1
'------------------------------------------ここまでを追加
Else
Err.Clear 'ErrReset
End If
End With
Next
End With
End Sub
|
|
こうちゃん
- 05/2/24(木) 14:01 -
