双击单元格 插入选择文件的完整路径

hhlyd

各位高手，最近用到excel，需要以下功能，请各位i高手出手帮助：
1、双击某个单元格 例如A1，出现文件选择提示
2、浏览文件夹，选择要文件
3、选择文件后，在A1单元格里，插入该文件的完整路径，包含扩展名。
4、A列所有都有这个功能

谢谢大家

取得文件完整路径.zip (5.56 KB, 下载次数: 7)

2013-12-19 21:08 上传

点击文件名下载附件

zhaogang1960

请测试：

1. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
2.     If Target.Count > 1 Then Exit Sub
   
3.     If Target.Column <> 1 Then Exit Sub
   
4.     f = Application.GetOpenFilename("所有文件 (*.*),*.*", , "Get list")
   
5.     If TypeName(f) <> "Boolean" Then Target.Value = f
   
6.     Cancel = True
   
7. End Sub
   

复制代码

zhaogang1960

请看附件
取得文件完整路径.rar (11.29 KB, 下载次数: 25)

2013-12-19 21:59 上传

点击文件名下载附件

hhlyd

zhaogang1960 发表于 2013-12-19 21:59
请看附件

谢谢帮助哈，我试了非常好用。
请问如何把这个代码嵌套到别的代码里？

hhlyd

zhaogang1960 发表于 2013-12-19 21:59
请看附件

详细说下，我用网上的代码，做了个群发邮件的宏。
实现以下功能：
群发邮件，主题不同，正文不同，附件不同。

其中附件需要插入完整路径，我不会把代码嵌套到目前的代码里。
麻烦帮忙处理下。

附件见附件~~~


先谢谢了

群发邮件 - 副本.rar (18.03 KB, 下载次数: 9)

2013-12-20 17:09 上传

点击文件名下载附件

zhaogang1960

hhlyd 发表于 2013-12-20 17:10
详细说下，我用网上的代码，做了个群发邮件的宏。
实现以下功能：
群发邮件，主题不同，正文不同，附件 ...

有很大变化，请说明具体要求

hhlyd

zhaogang1960 发表于 2013-12-20 17:16
有很大变化，请说明具体要求

你好
我上传的群发邮件那个附件；
E列是要插入附件路径和文件名的地方，比如双击E1，选择文件，插入所选文件的完整路径（含文件名）
就想实现这样的功能

zhaogang1960

hhlyd 发表于 2013-12-20 21:30
你好
我上传的群发邮件那个附件；
E列是要插入附件路径和文件名的地方，比如双击E1，选择文件，插入所 ...

从第1列改为第5列即可：
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Count > 1 Then Exit Sub
    If Target.Column <> 5 Then Exit Sub
    f = Application.GetOpenFilename("所有文件 (*.*),*.*", , "Get list")
    If TypeName(f) <> "Boolean" Then Target.Value = f
    Cancel = True
End Sub

hhlyd

zhaogang1960 发表于 2013-12-20 21:35
从第1列改为第5列即可：
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As B ...

谢谢回复
我现在的问题，您发的这段代码，如何和我原来的那段代码合在一起。
还得麻烦在帮帮忙

zhaogang1960

hhlyd 发表于 2013-12-21 10:46
谢谢回复
我现在的问题，您发的这段代码，如何和我原来的那段代码合在一起。
还得麻烦在帮帮忙

我这里没有OoutLook，请自己测试吧：

1. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
2.     If Target.Count > 1 Then Exit Sub
   
3.     If Target.Column <> 5 Then Exit Sub
   
4.     f = Application.GetOpenFilename("所有文件 (*.*),*.*", , "Get list")
   
5.     If TypeName(f) <> "Boolean" Then Target.Value = f
   
6.     Cancel = True
   
7.     On Error Resume Next
   
8.     Dim rowCount, endRowNo
   
9.     Dim objOutlook As New Outlook.Application
   
10.     Dim objMail As MailItem
    
11.     Dim arr, n&
    
12.     n = Target.Row
    
13.     Set objOutlook = New Outlook.Application
    
14.     Set objMail = objOutlook.CreateItem(olMailItem)
    
15.     With objMail
    
16.         .To = Cells(n, 2).Value      '"邮件的地址"
    
17.         .Subject = Cells(n, 3).Value      '"邮件主题"
    
18.         .Body = Cells(n, 4).Value      '"邮件内容"
    
19.         arr = Split(Cells(n, 5).Value, ";")
    
20.         For n = LBound(arr) To UBound(arr)
    
21.             .Attachments.Add (arr(n))      '"邮件的附件完整路径"
    
22.         Next
    
23.         .send
    
24.     End With
    
25.     Set objMail = Nothing
    
26.     Set objOutlook = Nothing
    
27.     MsgBox "邮件已发送", vbInformation
    
28. End Sub
    

复制代码