c_c_lai

回復 4# GBKEE
真不好意思，狀況依舊，如附件：
My Pictures.rar (315.17 KB)

下載次數: 8

2012-12-12 11:01

GBKEE

回復 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.                     

複製代碼

c_c_lai

回復 2# GBKEE

1.                     .ShapeRange.Height = 100#
   
2.                     .ShapeRange.Width = 100#
   
3.                     .ShapeRange.Rotation = 0#

複製代碼

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

下載 (459.19 KB)

2012-12-12 09:48

GBKEE

回復 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

複製代碼