麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 關鍵字抓圖片 [打印本頁]

作者: whirlwind963 時間: 2012-12-11 23:18 標題: 關鍵字抓圖片

請問一個資料夾裡面有很多的圖片
我從C2開始輸入檔名
但我只知道關鍵字
例如:ABCD123456  我只輸入ABCD
這樣也能抓到圖片
下面的程式碼哪裡有錯嗎
麻煩各位~幫我看一下
Sub Macro1()
j = 2
MyPath = "C:\My Pictures\"
MyFile = Dir(MyPath & Cells(j, "C") & "*.jpg")
While Cells(j, "C") <> ""
      NN = Cells(j, "C")
      Cells(j, "D").Select
      On Error Resume Next
      ActiveSheet.Pictures.Insert(MyFile).Select
      Selection.ShapeRange.LockAspectRatio = msoTrue
      Selection.ShapeRange.Height = 100#
      Selection.ShapeRange.Width = 100#
      Selection.ShapeRange.Rotation = 0#
      With Selection
      .Placement = xlMoveAndSize
      .PrintObject = True
      End With
j = j + 1
Wend
Range("C2").Select
End Sub

作者: GBKEE 時間: 2012-12-12 07:57

本帖最後由 GBKEE 於 2012-12-12 11:24 編輯

回復 1# whirlwind963

Option Explicit
Sub Ex()
Dim j As Integer, MyPath As String
j = 2
MyPath = "C:\My Pictures\"
While Cells(j, "C") <> ""
If UCase(Cells(j, "C")) Like "*ABCD*" Then '字串中有"ABCD"
'UCase 函數傳回一個 Variant (String)，所含為轉成大寫之字串。
Cells(j, "D").Select
If Dir(MyPath & Cells(j, "C")) <> "" Then
With ActiveSheet.Pictures.Insert(MyPath & Cells(j, "C"))
' .ShapeRange.LockAspectRatio = msoTrue
' 在調整圖案大小時，可以分別地調整圖案的長度和寬度
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100
.ShapeRange.Width = 200,
.ShapeRange.Rotation = 0
.Placement = xlMoveAndSize
.PrintObject = True
End With
End If
End If
j = j + 1
Wend
Range("C2").Select
End Sub

複製代碼

作者: c_c_lai 時間: 2012-12-12 09:48

回復 2# GBKEE

.ShapeRange.Height = 100#
.ShapeRange.Width = 100#
.ShapeRange.Rotation = 0#

複製代碼

請教版大，上面所述 "高度"、"寬度"的設定問題。
假設我圖片的大小不一，我如何能將其匯入隻大小限制，
(如 .ShapeRange.Height = 100# 之告示)
謝謝您！
[attach]13497[/attach]

作者: GBKEE 時間: 2012-12-12 10:48

回復 3# c_c_lai

Option Explicit
Sub Ex()
With ActiveSheet
.Pictures.Delete
.Cells(5, "D").Select
With .Pictures.Insert("d:\ex1.gif")
.ShapeRange.LockAspectRatio = msoFalse '在調整圖案大小時，可以分別地調整圖案的長度和寬度
.ShapeRange.Height = IIf(.ShapeRange.Height > 100, 100, .ShapeRange.Height)
.ShapeRange.Width = IIf(.ShapeRange.Width > 200, 200, .ShapeRange.Width)
End With
End With
End Sub

複製代碼

作者: c_c_lai 時間: 2012-12-12 11:01

回復 4# GBKEE
真不好意思，狀況依舊，如附件：
[attach]13498[/attach]

作者: GBKEE 時間: 2012-12-12 11:27

回復 5# c_c_lai
2# 有誤已更正

Option Explicit
Sub Ex()
Dim j As Integer, MyPath As String
j = 2
MyPath = "D:\My Pictures\"
While Cells(j, "C") <> ""
If UCase(Cells(j, "C")) Like "*ABCD*" Then '字串中有"ABCD"
'UCase 函數傳回一個 Variant (String)，所含為轉成大寫之字串。
Cells(j, "D").Select
Selection.RowHeight = 82
If Dir(MyPath & Cells(j, "C")) <> "" Then
With ActiveSheet.Pictures.Insert(MyPath & Cells(j, "C"))
' .ShapeRange.LockAspectRatio = msoTrue
' 在調整圖案大小時，可以分別地調整圖案的長度和寬度
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = IIf(.ShapeRange.Height > 100, 100, .ShapeRange.Height)
.ShapeRange.Width = IIf(.ShapeRange.Width > 200, 200, .ShapeRange.Width)
.ShapeRange.Rotation = 0#
.Placement = xlMoveAndSize
.PrintObject = True
End With
End If
End If
j = j + 1
Wend
Range("C2").Select
End Sub

複製代碼

作者: c_c_lai 時間: 2012-12-12 12:34

回復 6# GBKEE
我已經修正完成，如圖，謝謝您！

Option Explicit
Sub Ex()
Dim j As Integer, MyPath As String
j = 2
MyPath = "C:\My Pictures\"
While Cells(j, "C") <> ""
If UCase(Cells(j, "C")) Like "*ABCD*" Then '字串中有"ABCD"
'UCase 函數傳回一個 Variant (String)，所含為轉成大寫之字串。
Cells(j, "D").Select
Selection.RowHeight = 100
Selection.ColumnWidth = 25
On Error Resume Next
If Dir(MyPath & Cells(j, "C")) <> "" Then
With ActiveSheet.Pictures.Insert(MyPath & Cells(j, "C"))
' .ShapeRange.LockAspectRatio = msoTrue
' 在調整圖案大小時，可以分別地調整圖案的長度和寬度
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = IIf(.ShapeRange.Height > 98, 98, .ShapeRange.Height)
.ShapeRange.Width = IIf(.ShapeRange.Width > 150, 150, .ShapeRange.Width)
.ShapeRange.Rotation = 0#
.Placement = xlMoveAndSize
.PrintObject = True
End With
End If
End If
j = j + 1
Wend
Range("C2").Select
End Sub

複製代碼

[attach]13501[/attach]

作者: whirlwind963 時間: 2012-12-12 14:09

回復 6# GBKEE
不好意思
我想要的正好是相反的
假設檔名為ABCD123456.jpg
我在C2輸入ABCD
D2能顯示ABCD123456.JPG的圖片

作者: c_c_lai 時間: 2012-12-12 15:59

回復 8# whirlwind963

Option Explicit
Sub Ex()
Dim j As Integer, MyPath As String, MyFile As String
j = 2
MyPath = "C:\My Pictures\"
While Cells(j, "C") <> ""
If UCase(Cells(j, "C")) Like "*ABCD*" Then '字串中有"ABCD"
' UCase 函數傳回一個 Variant (String)，所含為轉成大寫之字串。
Cells(j, "D").Select
Selection.RowHeight = 100
Selection.ColumnWidth = 25
On Error Resume Next
MyFile = Dir(MyPath & "*" & Cells(j, "C") & "*.*") ' C2 = "ABCD" ->"1AABCD.png"
If MyFile <> "" Then
With ActiveSheet.Pictures.Insert(MyPath & MyFile)
' .ShapeRange.LockAspectRatio = msoTrue
' 在調整圖案大小時，可以分別地調整圖案的長度和寬度
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = IIf(.ShapeRange.Height > 98, 98, .ShapeRange.Height)
.ShapeRange.Width = IIf(.ShapeRange.Width > 150, 150, .ShapeRange.Width)
.ShapeRange.Rotation = 0#
.Placement = xlMoveAndSize
.PrintObject = True
End With
End If
End If
j = j + 1
Wend
Range("C2").Select
End Sub

複製代碼

[attach]13502[/attach]

作者: GBKEE 時間: 2012-12-12 20:49

回復 8# whirlwind963

Option Explicit
Sub Ex() '傳回資料夾中符合[C2] 的檔案
Dim j As Integer, MyPath As String, xlJpg As String
j = 2
ActiveSheet.Pictures.Delete
MyPath = "C:\My Pictures\"
'Dir 函數傳回一個 String ，用以表示合乎條件、檔案屬性、磁碟標記的一個檔案名稱、或目錄、檔案夾名稱。
xlJpg = Dir(MyPath & [C2] & "*.JPG") '開頭= [C2]的字串
'xlJpg = Dir(MyPath & "*" & [C2] & "*.JPG") '包含[C2]的字串
'xlJpg = Dir(MyPath & "*" & [C2] & ".JPG") '包含[C2]的字串在尾端
Do While xlJpg <> ""
Cells(j, "D").Select
With ActiveSheet.Pictures.Insert(MyPath & xlJpg)
' .ShapeRange.LockAspectRatio = msoTrue
' 在調整圖案大小時，可以分別地調整圖案的長度和寬度
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = IIf(.ShapeRange.Height > 98, 98, .ShapeRange.Height)
.ShapeRange.Width = IIf(.ShapeRange.Width > 150, 150, .ShapeRange.Width)
.ShapeRange.Rotation = 0#
.Placement = xlMoveAndSize
.PrintObject = True
End With
j = j + 1
xlJpg = Dir
Loop
Range("C2").Select
End Sub

複製代碼

作者: whirlwind963 時間: 2012-12-15 09:45

回復 9# c_c_lai
幫我看一下
我想要在A欄B欄放位址
C欄為圖片檔名
D欄為顯示A的圖片
E欄顯示B的圖片
使用FOR 迴圈
圖片會在D欄重疊
該怎麼改呢
   Option Explicit

Sub Ex()
      Dim j As Integer, MyPath As String, MyFile As String, k, l

      For k = 1 To 2
         For l = 4 To 5
      j = 2
      While Cells(j, "C") <> "" 'C2為檔名
      MyPath = Cells(j, k)  'A2 B2為位址
         If UCase(Cells(j, "C")) Like "*W*" Then  '字串中有"ABCD"
            '  UCase 函數傳回一個 Variant (String)，所含為轉成大寫之字串。
            Cells(j, l).Select 'D2 E2為圖片
            On Error Resume Next
            MyFile = Dir(MyPath & "*" & Cells(j, "C") & "*.*")    '  C2 = "ABCD" ->"1AABCD.png"

            If MyFile <> "" Then
                  With ActiveSheet.Pictures.Insert(MyPath & MyFile)
                     '  .ShapeRange.LockAspectRatio = msoTrue
                     '  在調整圖案大小時，可以分別地調整圖案的長度和寬度
                     .ShapeRange.LockAspectRatio = msoFalse
                     .ShapeRange.Height = 100#
                     .ShapeRange.Width = 100#
                     .ShapeRange.Rotation = 0#
                     .Placement = xlMoveAndSize
                     .PrintObject = True
                  End With
            End If
         End If
         j = j + 1
      Wend
      Range("C2").Select
      Next
      Next
End Sub

作者: c_c_lai 時間: 2012-12-15 11:19

回復 c_c_lai
幫我看一下
我想要在A欄B欄放位址
C欄為圖片檔名
D欄為顯示A的圖片
E欄顯示B的圖片
使 ...
whirlwind963 發表於 2012-12-15 09:45

你的迴圈處理地非常奇怪，

For k = 1 To 2
For l = 4 To 5
j = 2
While Cells(j, "C") <> ""
' ......
j = j + 1
Wend ' 每次迴圈都從頭跑一次
Next
Next

複製代碼

你把此檔案上傳，我實地演練一次。

作者: GBKEE 時間: 2012-12-15 11:28

回復 11# whirlwind963

Option Explicit
Sub Ex()
Dim j As Integer, MyPath As String, MyFile As String, k, L
For k = 1 To 2 'A,B欄
For L = 4 To 5 'D,E欄
j = 2
While Cells(j, "C") <> "" 'C欄為檔名
MyPath = Cells(j, k) 'A欄,B欄為位址
If UCase(Cells(j, "C")) Like "*W*" Then '字串中有"ABCD"
On Error Resume Next
MyFile = Dir(MyPath & "*" & Cells(j, "C") & "*.*") ' C2 = "ABCD" ->"1AABCD.png"
If MyFile <> "" Then
Cells(j, L).Select 'D,E欄
With ActiveSheet.Pictures.Insert(MyPath & MyFile)
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 100#
.ShapeRange.Rotation = 0#
.Placement = xlMoveAndSize
.PrintObject = True
End With
End If
End If
j = j + 1
Wend
Range("C2").Select
Next
Next
End Sub

複製代碼

作者: c_c_lai 時間: 2012-12-16 10:33

回復 11# whirlwind963
回復 13# GBKEE
星期日無聊，便動筆修改了 GBKEE 大大的程式： (望不要介意)

Option Explicit
Sub Ex2()
Dim j As Integer, k As Integer, MyPath As String, MyFile As String
Application.ScreenUpdating = False
ActiveSheet.Pictures.Delete
j = 2
While Cells(j, "C") <> "" ' C欄為檔名
For k = 1 To 2
MyPath = Cells(j, k)
' A欄,B欄為位址例如: D:\My Pictures\15\ 、及 E:\Amazing Pictures\16\ 等等。
If UCase(Cells(j, "C")) Like "*ABCD*" Then ' 字串中有"ABCD"
On Error Resume Next
MyFile = Dir(MyPath & "*" & Cells(j, "C") & "*.*")
If MyFile <> "" Then
Cells(j, IIf(k = 1, 4, 5)).Select ' D,E欄
With ActiveSheet.Pictures.Insert(MyPath & MyFile)
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 100#
.ShapeRange.Rotation = 0#
.Placement = xlMoveAndSize
.PrintObject = True
End With
End If
End If
Next
j = j + 1
Wend
Range("C2").Select
Application.ScreenUpdating = True
End Sub

複製代碼

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)