一個圖片問題

周大偉

請教大大前輩們,
小弟有一插入圖片問題, 懇請大大們協助, 小弟把問題寫於付件內, 希望能有回應, 謝謝!!
dd.rar (142.67 KB)

下載次數: 7

2016-6-23 21:50

stillfish00

回復 1# 周大偉

1. Sub Test()
   
2.     Dim v, pic As Object, currentCell As Range
   
3.     If StrComp(TypeName(Selection), "Range", vbTextCompare) <> 0 Then MsgBox "Please select a cell to insert picture": Exit Sub
   
4.     Set currentCell = Selection
   
5.    
   
6.     v = Application.GetOpenFilename("All Files (*.*), *.*,Pictures (*.jpg;*.bmp;*.png;*.gif),*.jpg;*.bmp;*.png;*.gif", 2, "Select Insert Pictures")
   
7.     If StrComp(TypeName(v), "Boolean", vbTextCompare) = 0 Then Exit Sub
   
8.    
   
9.     Set pic = ActiveSheet.Pictures.Insert(v)
   
10.     If pic Is Nothing Then Exit Sub
    
11.     With pic
    
12.         .Left = currentCell.Left
    
13.         .Top = currentCell.Top
    
14.         .ShapeRange.LockAspectRatio = msoFalse
    
15.         .ShapeRange.ScaleWidth currentCell.Width / .Width, msoFalse, msoScaleFromTopLeft
    
16.         .ShapeRange.ScaleHeight currentCell.Height / .Height, msoFalse, msoScaleFromTopLeft
    
17.     End With
    
18. End Sub

複製代碼

周大偉

回復 2# stillfish00

謝謝前輩，