Excel VBA質問箱 IV

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

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


58728 / 76732 ←次へ | 前へ→

【22727】Re:写真整理したい
お礼  HK  - 05/3/1(火) 12:10 -

引用なし
パスワード
   ▼やす さん:
>あれあれ?(レス確認)・・・あ!
>
>[#22653]で1行コピーし忘れてました。
>申し訳ないです(i = PicCount + 1)
>
>改めて全文を。
>おわびではありませんが、「5」は冒頭の1つにしてみました。
>
>Sub 取込()
>'画像取込み
>  Const z1 As Single = 150 'サイズ指定
>    '↑ここで表示のサイズが変えられます。
>  Const ColChVal As Long = 5 '1列の画像数
>    '↑ここで縦に並べる数が変えられます。
>  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 質問
【22474】Re:写真整理したい IROC 05/2/22(火) 11:36 回答
【22501】Re:写真整理したい HK 05/2/22(火) 23:02 質問
【22504】Re:写真整理したい ponpon 05/2/22(火) 23:52 発言
【22568】Re:写真整理したい HK 05/2/23(水) 23:14 質問
【22572】Re:写真整理したい ponpon 05/2/24(木) 0:13 発言
【22589】Re:写真整理したい こうちゃん 05/2/24(木) 14:01 回答
【22601】Re:写真整理したい ponpon 05/2/24(木) 18:19 発言
【22638】Re:写真整理したい HK 05/2/25(金) 8:58 質問
【22653】Re:写真整理したい やす 05/2/25(金) 16:34 発言
【22661】Re:写真整理したい HK 05/2/25(金) 22:24 質問
【22690】Re:写真整理したい やす 05/2/28(月) 13:59 発言
【22703】Re:写真整理したい HK 05/2/28(月) 21:34 質問
【22718】Re:写真整理したい やす 05/3/1(火) 9:27 回答
【22719】Re:写真整理したい HK 05/3/1(火) 9:44 質問
【22725】Re:写真整理したい やす 05/3/1(火) 11:20 回答
【22727】Re:写真整理したい HK 05/3/1(火) 12:10 お礼

58728 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free