12
返回列表 上一主題 發帖

[發問] 關鍵字抓圖片

whirlwind963

帖子
29 
主題
7 
精華
0 
積分
42 
點名
0  
作業系統
XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
註冊時間
2012-9-22 
最後登錄
2013-1-9 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 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

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2012-12-12 07:57 | 只看該作者
本帖最後由 GBKEE 於 2012-12-12 11:24 編輯

回復 1# whirlwind963
  1. Option Explicit
  2. Sub Ex()
  3.     Dim j As Integer, MyPath As String
  4.     j = 2
  5.     MyPath = "C:\My Pictures\"
  6.     While Cells(j, "C") <> ""
  7.         If UCase(Cells(j, "C")) Like "*ABCD*" Then  '字串中有"ABCD"
  8.            'UCase 函數 傳回一個 Variant (String)，所含為轉成大寫之字串。
  9.             Cells(j, "D").Select
  10.            If Dir(MyPath & Cells(j, "C")) <> "" Then
  11.                 With ActiveSheet.Pictures.Insert(MyPath & Cells(j, "C"))
  12.                     '  .ShapeRange.LockAspectRatio = msoTrue
  13.                     '  在調整圖案大小時，可以分別地調整圖案的長度和寬度
  14.                     .ShapeRange.LockAspectRatio = msoFalse
  15.                     .ShapeRange.Height =  100
  16.                     .ShapeRange.Width =  200,
  17.                     .ShapeRange.Rotation = 0
  18.                     .Placement = xlMoveAndSize
  19.                     .PrintObject = True
  20.                 End With
  21.             End If
  22.         End If
  23.         j = j + 1
  24.     Wend
  25.     Range("C2").Select
  26. End Sub
複製代碼

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
3#
發表於 2012-12-12 09:48 | 只看該作者
回復 2# GBKEE
  1.                     .ShapeRange.Height = 100#
  2.                     .ShapeRange.Width = 100#
  3.                     .ShapeRange.Rotation = 0#
複製代碼
請教版大，上面所述 "高度"、"寬度"的設定問題。
假設我圖片的大小不一，我如何能將其匯入隻大小限制，
(如 .ShapeRange.Height = 100# 之告示)
謝謝您！

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2012-12-12 10:48 | 只看該作者
回復 3# c_c_lai
  1. Option Explicit
  2. Sub Ex()
  3.     With ActiveSheet
  4.         .Pictures.Delete
  5.         .Cells(5, "D").Select
  6.         With .Pictures.Insert("d:\ex1.gif")
  7.             .ShapeRange.LockAspectRatio = msoFalse '在調整圖案大小時，可以分別地調整圖案的長度和寬度
  8.             .ShapeRange.Height = IIf(.ShapeRange.Height > 100, 100, .ShapeRange.Height)
  9.             .ShapeRange.Width = IIf(.ShapeRange.Width > 200, 200, .ShapeRange.Width)
  10.             End With
  11.     End With
  12. End Sub
  13.                     
複製代碼

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
5#
發表於 2012-12-12 11:01 | 只看該作者
回復 4# GBKEE
真不好意思，狀況依舊，如附件：
My Pictures.rar (315.17 KB)

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 2012-12-12 11:27 | 只看該作者
回復 5# c_c_lai
2# 有誤 已更正
  1. Option Explicit
  2. Sub Ex()
  3.     Dim j As Integer, MyPath As String
  4.     j = 2
  5.     MyPath = "D:\My Pictures\"
  6.     While Cells(j, "C") <> ""
  7.         If UCase(Cells(j, "C")) Like "*ABCD*" Then  '字串中有"ABCD"
  8.            'UCase 函數 傳回一個 Variant (String)，所含為轉成大寫之字串。
  9.             Cells(j, "D").Select
  10.             Selection.RowHeight = 82
  11.            If Dir(MyPath & Cells(j, "C")) <> "" Then
  12.                 With ActiveSheet.Pictures.Insert(MyPath & Cells(j, "C"))
  13.                     '  .ShapeRange.LockAspectRatio = msoTrue
  14.                     '  在調整圖案大小時，可以分別地調整圖案的長度和寬度
  15.                     .ShapeRange.LockAspectRatio = msoFalse
  16.                     .ShapeRange.Height = IIf(.ShapeRange.Height > 100, 100, .ShapeRange.Height)
  17.                     .ShapeRange.Width = IIf(.ShapeRange.Width > 200, 200, .ShapeRange.Width)
  18.                     .ShapeRange.Rotation = 0#
  19.                     .Placement = xlMoveAndSize
  20.                     .PrintObject = True
  21.                 End With
  22.             End If
  23.         End If
  24.         j = j + 1
  25.     Wend
  26.     Range("C2").Select
  27. End Sub
複製代碼

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
7#
發表於 2012-12-12 12:34 | 只看該作者
回復 6# GBKEE
我已經修正完成，如圖，謝謝您！
  1. Option Explicit
  2. Sub Ex()
  3.     Dim j As Integer, MyPath As String
  4.    
  5.     j = 2
  6.     MyPath = "C:\My Pictures\"
  7.    
  8.     While Cells(j, "C") <> ""
  9.         If UCase(Cells(j, "C")) Like "*ABCD*" Then  '字串中有"ABCD"
  10.            'UCase 函數 傳回一個 Variant (String)，所含為轉成大寫之字串。
  11.             Cells(j, "D").Select
  12.             
  13.             Selection.RowHeight = 100
  14.             Selection.ColumnWidth = 25
  15.             
  16.             On Error Resume Next
  17.             If Dir(MyPath & Cells(j, "C")) <> "" Then
  18.                 With ActiveSheet.Pictures.Insert(MyPath & Cells(j, "C"))
  19.                     '  .ShapeRange.LockAspectRatio = msoTrue
  20.                     '  在調整圖案大小時，可以分別地調整圖案的長度和寬度
  21.                     .ShapeRange.LockAspectRatio = msoFalse
  22.                     .ShapeRange.Height = IIf(.ShapeRange.Height > 98, 98, .ShapeRange.Height)
  23.                     .ShapeRange.Width = IIf(.ShapeRange.Width > 150, 150, .ShapeRange.Width)
  24.                     .ShapeRange.Rotation = 0#
  25.                     .Placement = xlMoveAndSize
  26.                     .PrintObject = True
  27.                 End With
  28.             End If
  29.         End If
  30.         j = j + 1
  31.     Wend
  32.     Range("C2").Select
  33. End Sub
複製代碼

TOP

whirlwind963

帖子
29 
主題
7 
精華
0 
積分
42 
點名
0  
作業系統
XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
註冊時間
2012-9-22 
最後登錄
2013-1-9 
8#
發表於 2012-12-12 14:09 | 只看該作者
回復 6# GBKEE
不好意思
我想要的正好是相反的
假設檔名為ABCD123456.jpg
我在C2輸入ABCD
D2能顯示ABCD123456.JPG的圖片

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
9#
發表於 2012-12-12 15:59 | 只看該作者
回復 8# whirlwind963
  1. Option Explicit

  3. Sub Ex()
  4.     Dim j As Integer, MyPath As String, MyFile As String
  5.    
  6.     j = 2
  7.     MyPath = "C:\My Pictures\"
  8.    
  9.     While Cells(j, "C") <> ""
  10.         If UCase(Cells(j, "C")) Like "*ABCD*" Then  '字串中有"ABCD"
  11.            '  UCase 函數 傳回一個 Variant (String)，所含為轉成大寫之字串。
  12.             Cells(j, "D").Select
  13.             
  14.             Selection.RowHeight = 100
  15.             Selection.ColumnWidth = 25
  16.             
  17.             On Error Resume Next
  18.             MyFile = Dir(MyPath & "*" & Cells(j, "C") & "*.*")       '  C2 = "ABCD" ->"1AABCD.png"

  20.             If MyFile <> "" Then
  21.                 With ActiveSheet.Pictures.Insert(MyPath & MyFile)
  22.                     '  .ShapeRange.LockAspectRatio = msoTrue
  23.                     '  在調整圖案大小時，可以分別地調整圖案的長度和寬度
  24.                     .ShapeRange.LockAspectRatio = msoFalse
  25.                     .ShapeRange.Height = IIf(.ShapeRange.Height > 98, 98, .ShapeRange.Height)
  26.                     .ShapeRange.Width = IIf(.ShapeRange.Width > 150, 150, .ShapeRange.Width)
  27.                     .ShapeRange.Rotation = 0#
  28.                     .Placement = xlMoveAndSize
  29.                     .PrintObject = True
  30.                 End With
  31.             End If
  32.         End If
  33.         j = j + 1
  34.     Wend
  35.     Range("C2").Select
  36. End Sub
複製代碼

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
10#
發表於 2012-12-12 20:49 | 只看該作者
回復 8# whirlwind963
  1. Option Explicit
  2. Sub Ex() '傳回資料夾中符合[C2] 的檔案
  3.     Dim j As Integer, MyPath As String, xlJpg As String
  4.     j = 2
  5.     ActiveSheet.Pictures.Delete
  6.     MyPath = "C:\My Pictures\"
  7.     'Dir 函數 傳回一個 String ，用以表示合乎條件、檔案屬性、磁碟標記的一個檔案名稱、或目錄、檔案夾名稱。
  8.     xlJpg = Dir(MyPath & [C2] & "*.JPG")       '開頭= [C2]的字串
  9.    'xlJpg = Dir(MyPath & "*" & [C2] & "*.JPG")  '包含[C2]的字串
  10.    'xlJpg = Dir(MyPath & "*" & [C2] & ".JPG")   '包含[C2]的字串在尾端
  11.     Do While xlJpg <> ""
  12.        Cells(j, "D").Select
  13.         With ActiveSheet.Pictures.Insert(MyPath & xlJpg)
  14.             '  .ShapeRange.LockAspectRatio = msoTrue
  15.             '  在調整圖案大小時，可以分別地調整圖案的長度和寬度
  16.             .ShapeRange.LockAspectRatio = msoFalse
  17.             .ShapeRange.Height = IIf(.ShapeRange.Height > 98, 98, .ShapeRange.Height)
  18.             .ShapeRange.Width = IIf(.ShapeRange.Width > 150, 150, .ShapeRange.Width)
  19.             .ShapeRange.Rotation = 0#
  20.             .Placement = xlMoveAndSize
  21.             .PrintObject = True
  22.         End With
  23.         j = j + 1
  24.         xlJpg = Dir
  25.     Loop
  26.     Range("C2").Select
  27. End Sub
複製代碼

TOP

        靜思自在 : 是非當教育，讚美作警惕。
12
返回列表 上一主題