Excel VBA質問箱 IV

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

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


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

58728 / 76732

←次へ　｜　前へ→


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

HK - 05/3/1(火) 12:10 -


	引用なし

	パスワード

▼やすさん：
>あれあれ？（レス確認）・・・あ！
>
>[#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
有難うございました。感謝、感謝
これで、完璧に実用することができました。

本当にお手間を取らせて申し訳ありませんでした。

1 hits

▼

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