照片引用问题——紧急求助各位高手指点迷津

lheqian

仍然在线等

masterexcel

仅仅针对JPG格式的相片有效，请楼主试用下。

1. 
   
2. Sub Insert_Picture()
   
3.     VarFileName = Application.GetOpenFilename("All Files (*.*), *.*", MultiSelect:=False)
   
4.     VarFileNameArr = Split(VarFileName, "")
   
5.     n = UBound(VarFileNameArr)
   
6.     Debug.Print n, VarFileNameArr(n)
   
7.     l = Len(VarFileNameArr(n))
   
8.     FilePath = Left(VarFileName, Len(VarFileName) - Len(VarFileNameArr(n)))
   
9.     Set tmpRange = ThisWorkbook.Sheets("Sheet1").Range("B1")
   
10.     Application.ScreenUpdating = False
    
11.     t = tmpRange.Top
    
12.     l = tmpRange.Left
    
13.     h = tmpRange.Offset(tmpRange.Rows.Count, 0).Top - tmpRange.Top
    
14.     w = tmpRange.Offset(0, tmpRange.Columns.Count).Left - tmpRange.Left
    
15.     On Error GoTo ErrTrap
    
16.     Debug.Print tmpRange.Parent.Name
    
17.     Set p = tmpRange.Parent.Pictures.Insert(FilePath & Range("A1").Value & ".JPG")
    
18.     With p
    
19.         .Top = t
    
20.         .Left = l
    
21.         .Height = h
    
22.         .Width = w
    
23.     End With
    
24.     Set tmpRange = Nothing
    
25.     Set p = Nothing
    
26. exitsub:
    
27.     Application.ScreenUpdating = True
    
28.     Exit Sub
    
29. ErrTrap:
    
30.     Application.ScreenUpdating = True
    
31.     ErrNumber = Err.Number
    
32.     If ErrNumber = 1004 Then
    
33.     MsgBox "The file selected is not a valid picture!", vbInformation
    
34.     End If
    
35.     Set tmpRange = Nothing
    
36.     Set p = Nothing
    
37.     GoTo exitsub
    
38. End Sub
    

复制代码

sunya_0529

正好以前帮别人做过类似的示例，你稍微调整一下就可以用了。

lheqian

我不懂代码  我把代码复制过去了 然后提示让我选择单元格  不知道可否帮我做下附件

masterexcel

提示让你选择照片所在文件夹的任一个文件！然后就没有手动的了。注意照片格式为JPG！

lheqian

我先研究下 不懂再问您

masterexcel

如果你的相片是固定在一个文件夹下面，不改变路径的，可以更改下代码，更方便。将文件夹路径放在一个单元格里，比如在C1里面。在把这个代码放在工作表change事件里面去。就不用每次手动来选择文件了……

lheqian

引用图片我大概看懂了 但是插入图片我还是没看懂 好像跟断轮回给的代码应该是一个效果
能否帮我调下附件呢  按照我附件中的说明

lheqian

断轮回大侠 我是菜鸟啊 代码一点不懂 可否帮我调整一下啊

masterexcel

文件夹地址放在单元格C1里面，代码放在Sheet1下

1. 
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3.     'VarFileName = Application.GetOpenFilename("All Files (*.*), *.*", MultiSelect:=False)
   
4.     'VarFileNameArr = Split(VarFileName, "")
   
5.     'n = UBound(VarFileNameArr)
   
6.     'Debug.Print n, VarFileNameArr(n)
   
7.     'l = Len(VarFileNameArr(n))
   
8.     'FilePath = Left(VarFileName, Len(VarFileName) - Len(VarFileNameArr(n)))
   
9.    
   
10.     Set tmpRange = ThisWorkbook.Sheets("Sheet1").Range("B1")
    
11.     Application.ScreenUpdating = False
    
12.     t = tmpRange.Top
    
13.     l = tmpRange.Left
    
14.     h = tmpRange.Offset(tmpRange.Rows.Count, 0).Top - tmpRange.Top
    
15.     w = tmpRange.Offset(0, tmpRange.Columns.Count).Left - tmpRange.Left
    
16.     On Error GoTo ErrTrap
    
17.     Debug.Print tmpRange.Parent.Name
    
18.     Set p = tmpRange.Parent.Pictures.Insert(Range("C1").Value & "" & Range("A1").Value & ".JPG")
    
19.     With p
    
20.         .Top = t
    
21.         .Left = l
    
22.         .Height = h
    
23.         .Width = w
    
24.     End With
    
25.     Set tmpRange = Nothing
    
26.     Set p = Nothing
    
27. exitsub:
    
28.     Application.ScreenUpdating = True
    
29.     Exit Sub
    
30. ErrTrap:
    
31.     Application.ScreenUpdating = True
    
32.     ErrNumber = Err.Number
    
33.     If ErrNumber = 1004 Then
    
34.     MsgBox "The file selected is not a valid picture!", vbInformation
    
35.     End If
    
36.     Set tmpRange = Nothing
    
37.     Set p = Nothing
    
38.     GoTo exitsub
    
39. End Sub
    

复制代码