[求助]如何用宏直接在改文件名

cmhlcm

下面的命令是在用WORD时，把“标题”作为文件名”另存”到指定目录

但还是美中不足，麻烦那位高手帮我改成符合以下要求？

再三感谢！！！！

1、把“标题”作为文件名，直接改成文件名（则原有文件名删去）

2、保存的时候，保存到相对路径，也就是原文件所在的目录，而不是默认目录或指定目录。

3、解决文件开头有空行而造成无法改名的问题。

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Sub 另存标题名退出()
'
' NO1 Macro
' 宏在 2008-6-9 由 微软用户 录制
    Selection.WholeStory
    Selection.HomeKey Unit:=wdLine
    Selection.Expand wdLine
    Dim myRange As Range
    Set myRange = Selection.Range
    myRange.SetRange myRange.Start, myRange.End - 1
    myRange.Select
    ActiveDocument.SaveAs FileName:="C:\\" & Selection & ".doc"
    Application.Quit
End Sub

-------------------------------------------------------------------------------------------

JSJ0811

Sub 另存标题名退出()
'
' NO1 Macro
' 宏在 2008-6-9 由 微软用户 录制
    Selection.WholeStory
    Selection.HomeKey Unit:=wdLine
    Selection.Expand wdLine
    Dim myRange As Range
    Set myRange = Selection.Range
    myRange.SetRange myRange.Start, myRange.End - 1
    myRange.Select
    ActiveDocument.SaveAs FileName:="C:\" & VBA.Trim(myRange.Text) & ".doc"
    Application.Quit
End Sub

JSJ0811

Sub 另存标题名退出()
'
' NO1 Macro
' 宏在 2008-6-9 由 微软用户 录制
    Selection.WholeStory
    Selection.HomeKey Unit:=wdLine
    Selection.Expand wdLine
    Dim myRange As Range
    Set myRange = Selection.Range
    myRange.SetRange myRange.Start, myRange.End - 1
    myRange.Select
    ActiveDocument.SaveAs FileName:="C:\" & VBA.Trim(myRange.Text) & ".doc"
    Application.Quit
End Sub

cmhlcm

试了，不行哦

1、还是保存到了C：、

2、原文件名没有被删去

wdwc

你录的这段程序似曾相识啊，很长时间以前我和你遇到一样的问题，参考：

http://club.excelhome.net/viewthread.php?tid=270732&replyID=&skin=0

http://club.excelhome.net/viewthread.php?tid=320142&replyID=&skin=0

简单改了一下，改进后的代码如下：

Sub Word文件改名()
    Dim myS, myP As String
    myP = ActiveDocument.Path
    Selection.HomeKey wdStory
    Do Until Len(myS) >= 1
        Selection.EndKey wdLine
        Selection.HomeKey wdLine, wdExtend
        myS = Selection.Range.Text
        Selection.MoveDown wdLine, 1
    Loop
    ActiveDocument.SaveAs FileName:=myP & "\" & myS & ".doc"
    ActiveWindow.Close
End Sub

[此贴子已经被作者于2008-6-9 22:09:19编辑过]

JSJ0811

Sub 另存标题名退出()
'
' NO1 Macro
' 宏在 2008-6-9 由 微软用户 录制
   Selection.WholeStory
    Selection.HomeKey Unit:=wdLine
    Selection.Expand wdLine
    Dim myRange As Range
    Set myRange = Selection.Range
    myRange.SetRange myRange.Start, myRange.End - 1
    myRange.Select
    ActiveDocument.SaveAs FileName:=ActiveDocument.Path & "\" & VBA.Trim(myRange.Text) & ".doc"
    Application.Quit
End Sub

昨天没明白你的意思,是要保存当表所在的文件夹内是吧.

但是要删除原来的文件,就有问题了,另存后的文件名与原来的一样,那么就会把新生成这个文件删了.除非改名后的文件与原来没改名的不同才可以这样做.

JSJ0811

Sub 另存标题名退出()
Dim AD1 As String
AD1 = ActiveDocument.FullName

' NO1 Macro
' 宏在 2008-6-9 由 微软用户 录制
   Selection.WholeStory
    Selection.HomeKey Unit:=wdLine
    Selection.Expand wdLine
    Dim myRange As Range
    Set myRange = Selection.Range
    myRange.SetRange myRange.Start, myRange.End - 1
    myRange.Select
    ActiveDocument.SaveAs FileName:=ActiveDocument.Path & "\" & VBA.Trim(myRange.Text) & ".doc"
    On Error Resume Next
    VBA.Kill (AD1)
    Application.Quit
End Sub

试试这样了.

wdpfox

正需要，下载试用，感谢老师无私分享！

常扬帆

wdwc 发表于 2008-6-9 19:58
你录的这段程序似曾相识啊，很长时间以前我和你遇到一样的问题，参考：http://club.excelhome.net/viewthre ...

我的是office 2016，实验了您的，成功！谢谢！