| |
▼こうちゃん さん：
>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
お礼の言葉を差し上げながらまことに失礼いたしました。
マクロを使わせてもらって気がついたのですが、2回目以降は、画像がダブってしまうので取り出して別のセルに移動しなくてはなりません。最後のお願いです、ご指導よろしくお願いします。
|
|
HK
- 05/2/25(金) 8:58 -
