Excel VBA質問箱 IV

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

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


58736 / 76738 ←次へ | 前へ→

【22725】Re:写真整理したい
回答  やす  - 05/3/1(火) 11:20 -

引用なし
パスワード
   あれあれ?(レス確認)・・・あ!

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

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