Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

58736 / 76738

←次へ　｜　前へ→


	【22725】Re:写真整理したい

やす - 05/3/1(火) 11:20 -


	引用なし

	パスワード

あれあれ？（レス確認）・・・あ！

[#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

0 hits

▼

【22472】写真整理したい KH 05/2/22(火) 10:38