| |
▼やす さん：
>あれあれ？（レス確認）・・・あ！
>
>[#22653]で１行コピーし忘れてました。
>申し訳ないです（i = PicCount + 1）
>
>改めて全文を。
>おわびではありませんが、「5」は冒頭の１つにしてみました。
>
>Sub 取込()
>'画像取込み
> Const z1 As Single = 150 'サイズ指定
> '↑ここで表示のサイズが変えられます。
> Const ColChVal As Long = 5 '１列の画像数
> '↑ここで縦に並べる数が変えられます。
> Dim TopSetVal As Long
> Dim LeftSetVal As Long
> Dim PicCount 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
>
> PicCount = ActiveSheet.Shapes.Count
> TopSetVal = 30 + (PicCount Mod ColChVal) * (z1 + 10) '最上位の位置
> LeftSetVal = Int(PicCount / ColChVal) * (z1 + 10) '左の位置
>
> i = PicCount + 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
>
> Selection.Left = LeftSetVal '左位置指定
> Selection.Top = TopSetVal '上位置指定
>
> TopSetVal = TopSetVal + z1 + 10 '間隔指定
>
> 'ColChVal個目で列変え
> If i Mod ColChVal = 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
有難うございました。感謝、感謝
これで、完璧に実用することができました。
本当にお手間を取らせて申し訳ありませんでした。
|
|
HK
- 05/3/1(火) 12:10 -
