戻る  □一般操作のサロン  □ 使用方法  □ 新着記事  □ 新規に質問する!  □ トピック一覧  □ 検索  □ 過去ログ
[ 親トピックをトピックトップへ ]
このトピックに書きこむ
Name/
E-Mail/

└>このツリーのレス記事をメールで受信しますか? YES/ NO/
Title/
URL/
Comment/ 通常モード->  図表モード-> (←の場合適当に改行を入れて下さい)
タグが使用できます。例 ⇒ <font color="blue">文字</font>
解決!!ありがとうございました! 解決       保留中です・・・ 保留        迷宮入りorほかあたって見ます・・ 迷宮入       すいませ〜ん。誰か〜! Help! ←※回答者専用
解決したらチェック       保留(コードテスト中など・・)         解決不可orレスが全く付かなくてほかのサイトに行くときなど・・
削除キー/
(半角8文字以内) 

このトピック参照回数 :
Re[1]: ファイル名

    [196096] Re[1]: ファイル名-

    解決!!ありがとうございました! / 記事引用/メール受信=OFF■

    □投稿者/ jdsk -(2024/01/26(10:10))
    □U R L/

      解決できました
      ありがとうございます




    [196091] ファイル名-

    ■親トピック/記事引用/メール受信=OFF■

    □投稿者/ jdsk -(2024/01/23(23:30))
    □U R L/
      こんばんは
      JPEGのファイル名をそのまま記入する方法はありますか?
      今は自動でナンバーです
      
      
      
      Sub ()
          Dim s As String, ss As String
          Dim sn As Long
          Dim Pic As Shape
          Dim x As Long, y As Long, z As Long
          Const cRows As Long = 19
          Const cCols As Long = 5
          Const iyMax As Long = 3
          Const sPath As String = "C:\写真\"
          Dim fNum() As Long
          Dim i As Long, j As Long, k As Long
          Dim rngArea As Range
          
          s = Dir(sPath & "*.jpg")
          Do Until s = ""
              If CLng(Val(s)) > 0 Then
                  i = i + 1
                  ReDim Preserve fNum(1 To i)
                  fNum(i) = CLng(Val(s))
              End If
              s = Dir()
          Loop
          If i > 0 Then
              ShellSort fNum
              ActiveSheet.DrawingObjects.Delete
              ActiveSheet.UsedRange.Clear
              
              Set rngArea = Range("A1:U54")
              z = 0
              For j = 1 To i Step 12
                  y = 0: x = 0
                  For k = j To WorksheetFunction.Min(j + 11, i)
                      If fNum(k) < 10 Then ss = "0" Else ss = ""
                      s = ss & fNum(k) & ".jpg"
                      
                      Set Pic = ActiveSheet.Shapes.AddPicture(Filename:=sPath & s, LinkToFile:=False, SaveWithDocument:=True, _
                                Left:=0, Top:=0, Width:=-1, Height:=-1)
                      
                      With rngArea.offset(z * rngArea.Rows.Count).Cells( _
                          y * cRows + 2, x * cCols + 1).Resize(cRows - 4, cCols)
      
                          Pic.Left = .Left
                          Pic.Top = .Top
                          If ((.Width - 3) / (.Height - 3)) > _
                                  ((Pic.Width) / (Pic.Height)) Then
                              Pic.Height = .Height - 3
                          Else
                              Pic.Width = .Width - 3
                          End If
                          
              
              .Cells(0, 1).Value = "'" & Split(s, ".")(0)
              .Cells(0, 1).Font.Name = "MS ゴシック" ' フォントをMSゴシックに
              .Cells(0, 1).Font.size = 20 ' フォントのサイズを 20 に
                  
                      End With
                      y = y + 1
                      If iyMax <= y Then
                          y = 0
                          x = x + 1
                      End If
                  Next k
                  z = z + 1
              Next
              Set rngArea = Nothing
              Erase fNum
          Else
              MsgBox sPath & " に JPG ファイルはありません"
          End If
      End Sub
      
      Private Sub ShellSort(MyAry() As Long)
          Dim i As Long, j As Long
          Dim MyMid As Long
          Dim MyTmp As Long
          Dim MyMin As Long
          Dim MyMax As Long
          
          MyMin = LBound(MyAry)
          MyMax = UBound(MyAry)
          MyMid = 1
          Do While MyMid < (MyMax - MyMin + 1) \ 3
              MyMid = 3 * MyMid + 1
          Loop
          Do Until MyMid <= 0
              For i = MyMid + MyMin To MyMax
                  MyTmp = MyAry(i)
                  For j = i To MyMid + MyMin Step -MyMid
                      If MyAry(j - MyMid) <= MyTmp Then
                          Exit For
                      End If
                      MyAry(j) = MyAry(j - MyMid)
                  Next j
                  MyAry(j) = MyTmp
              Next i
              MyMid = MyMid \ 3
          Loop
      End Sub
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他



      ++++++++++++++++++++
      OS      ⇒Windows XP
      Version⇒Excel 2007
      ++++++++++++++++++++



このトピック内容の全ページ数 / [0]

- Child Forum -
Edit:ゆう-G