vba获取当前word文件名

word vba 如何通过打开对话框获得打开文件名

Declare Function GetOpenFileName Lib ＂comdlg32.dll＂ Alias _＂GetOpenFileNameA＂ (pOpenfilename As OPENFILENAME) As LongType OPENFILENAMElStructSize As LonghwndOwner As LonghInstance As LonglpstrFilter As StringlpstrCustomFilter As StringnMaxCustFilter As LongnFilterIndex As LonglpstrFile As StringnMaxFile As LonglpstrFileTitle As StringnMaxFileTitle As LonglpstrInitialDir As StringlpstrTitle As Stringflags As LongnFileOffset As IntegernFileExtension As IntegerlpstrDefExt As StringlCustData As LonglpfnHook As LonglpTemplateName As StringEnd TypeSub t()Dim ofn As OPENFILENAMEDim rtn As String ofn.lStructSize = Len(ofn)ofn.lpstrFilter = ＂doc Files (*.doc)＂ & Chr(0) & ＂*.doc＂ & Chr(0)ofn.lpstrFile = Space(254)ofn.nMaxFile = 255ofn.lpstrFileTitle = Space(254)ofn.nMaxFileTitle = 255ofn.lpstrInitialDir = ＂C:＂ofn.lpstrTitle = ＂打开文件＂ofn.flags = 6148 rtn = GetOpenFileName(ofn) If rtn >= 1 ThenMsgBox ofn.lpstrFileElseMsgBox ＂Cancel Was Pressed＂End IfEnd Sub

VBA怎样实现批量选择word文档读取其文件名并填表的功能

Sub Test()Dim f, n, x, wb, fNameOn Error Resume NextCells.Clear'打开文件（可多选）f = Application.GetOpenFilename(＂Word文件，*.docm,＂, 1，＂选择文件＂， MultiSelect:=True)'遍历每个选择的文件For x = 1 To UBound(f)sFile = f(x)'取文件名，并赋值给单元格n = Len(sFile) - InStrRev(sFile, ＂\＂)fName = Right(sFile, n)Cells(x, 1) = Left(fName, InStr(fName, ＂＂) - 1） '取1到空格前的字符'Cells(x, 1) = Left(fname, 9) '取文件名的前9个字符Cells(x, 2) = Mid(fName, InStr(fName, ＂＂) + 1, Len(fName) - InStr(fName, ＂.＂) + 1） '取空格后到点之前的字符'Cells(x, 2) = Mid(fName, 10, Len(fName) - InStr(fName, ＂.＂) + 1） '从10开始取到点之前的字符Next xEnd Sub

EXCEL VBA 获取打开的word文件名

操作步骤。

第一，首先将需要批量替换的多个Word文档放在同一文件夹下面。

第二，新建一空白Word文档，右击空白工具栏，单击“控件工具箱”，就可以看到屏幕上调出的控件工具箱。

第三，在控件工具箱上单击“命令按钮”，文档中就放置了一个按钮了。

第四，双击该按钮，进入VB代码编写模式，将以下代码复制进去。

Private Sub CommandButton1_Click()Application.ScreenUpdating = FalseDim myPas As String, myPath As String, i As Integer, myDoc As DocumentWith Application.FileDialog(msoFileDialogFolderPicker).Title = ＂选择目标文件夹＂If .Show = -1 ThenmyPath = .SelectedItems(1)ElseExit SubEnd IfEnd WithmyPas = InputBox（＂请输入打开密码：＂）With Application.FileSearch.LookIn = myPath.FileType = msoFileTypeWordDocumentsIf .Execute > 0 ThenFor i = 1 To .FoundFiles.CountSet myDoc = Documents.Open(FileName:=.FoundFiles(i), Passworddocument:=myPas)Selection.Find.ClearFormattingSelection.Find.Replacement.ClearFormattingWith Selection.Find.Text = ＂大家好＂.Replacement.Text = ＂你好＂.Forward = True.Wrap = wdFindAsk.Format = False.MatchCase = False.MatchWholeWord = False.MatchByte = True.MatchWildcards = False.MatchSoundsLike = False.MatchAllWordForms = FalseEnd WithSelection.Find.Execute Replace:=wdReplaceAllmyDoc.SavemyDoc.CloseSet myDoc = NothingNextEnd IfEnd WithApplication.ScreenUpdating = TrueEnd Sub第五，保存上面代码，退出VB编辑模式，返回Word文档界面。

第六，单击选中该按钮，再单击控件工具箱的第一个按钮“退出设计模式”。

第七，进行测试：点击按钮，选择要放置多个WORD文档所在的文件夹，确定后即可完成！注意如果WORD文档没有加密的话，密码项就不填，直接确认。

如何通过VBA,获得本文件所在的文件夹路径。

Sub Macro2()Dim r, p, r0, p0, rr, ppp= Selection.Information(wdActiveEndPageNumber) '当前页码r= Selection.Information(wdFirstCharacterLineNumber) '当前行'数行数p0 = prr = rDoSelection.MoveDown Unit:=wdLine, Count:=1pp = Selection.Information(wdActiveEndPageNumber)r0 = Selection.Information(wdFirstCharacterLineNumber)If pp > p Then'退回原处Selection.MoveUp Unit:=wdLine, Count:=(rr - r + 1)Exit DoEnd IfIf rr = r0 Then'退回原处Selection.MoveUp Unit:=wdLine, Count:=(rr - r)Exit DoEnd Ifrr = r0LoopMsgBox ＂当前页码：＂ & p & vbCrLf &amp；＂本页总行数：＂ & rrEnd Sub 申请加悬赏分！！！

Word VBA 如何获得已打开的文档的日期

展开全部Function ShowFileInfo(strPath) As StringDim fso As ObjectDim f As ObjectDim s As StringSet fso = CreateObject(＂Scripting.FileSystemObject＂)Set f = fso.GetFile(strPath)s = f.Name & vbCrs = s & ＂Created: ＂ & f.DateCreated & vbCrs = s & ＂Last Modified: ＂ & f.DateLastModifiedShowFileInfo = sSet f = NothingSet fso = NothingEnd Function...

怎么vba实现word表格批量转为excel

注：vba偶并不太熟（偶一般是用c#和delphi的），VBA只是稍有了解，以下代码大部分是偶google到的内容拼出来的。

。

如下，使用时先更改test下的docpath和xlspath路径设定，docpath即你的word的目录，此目录包括子目录下的所有doc将被读取，xlspath即输出目录，需要存在在VBA窗口中，先在视图下显示立即窗口以观察进度，程序最后的输出类似这样正在读取[1]:->D:\1\Resume.doc正在生成：->d:\2\Resume正在读取[2]:->D:\1\简历（简）.doc正在生成：->d:\2\简历（简）正在读取[3]:->D:\1\计数器说明.doc正在生成：->d:\2\计数器说明共耗时0分41秒Option ExplicitDim docpath As String, xlspath As String'ResultFlag=0 获取路径'ResultFlag=1 获取文件名'ResultFlag=2 获取扩展名Public Function SplitPath(FullPath As String, ResultFlag As Integer) As StringDim SplitPos As Integer, DotPos As IntegerSplitPos = InStrRev(FullPath, ＂\＂)DotPos = InStrRev(FullPath, ＂.＂)Select Case ResultFlag Case 0 SplitPath = Left(FullPath, SplitPos - 1) Case 1 If DotPos = 0 Then DotPos = Len(FullPath) + 1 SplitPath = Mid(FullPath, SplitPos + 1, DotPos - SplitPos - 1) Case 2 If DotPos = 0 Then DotPos = Len(FullPath) SplitPath = Mid(FullPath, DotPos + 1) Case Else Err.Raise vbObjectError + 1, ＂SplitPath Function＂, ＂Invalid Parameter!＂End SelectEnd FunctionPublic Function FileFolderExists(ByVal strFullPath As String) As Boolean On Error GoTo EarlyExit If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = TrueEarlyExit: On Error GoTo 0End FunctionSub Test（) '使用双字典，旨在提高速度 Dim MyName, Dic, Did, I, T, F, TT, MyFileName, Doc, Ke Dim count As Integer count = 0 T = Timedocpath = ＂D:\1\＂xlspath = ＂d:\2\＂ Set Dic = CreateObject(＂Scripting.Dictionary＂) '创建一个字典对象 Set Did = CreateObject(＂Scripting.Dictionary＂) Dic.Add (docpath), ＂＂ I = 0 Do While I ＂＂ If MyName ＂.＂ And MyName ＂..＂ Then If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then '如果是次级目录 Dic.Add (Ke(I) & MyName & ＂\＂），＂＂ '就往字典中添加这个次级目录名作为一个条目 End If End If MyName = Dir '继续遍历寻找 Loop I = I + 1 Loop 'Did.Add （＂文件清单＂），＂＂ '以查找D盘下所有EXCEL文件为例 For Each Ke In Dic.keys MyFileName = Dir(Ke & ＂*.doc＂) Do While MyFileName ＂＂ Doc = Ke & MyFileName Did.Add (Doc), ＂＂ count = count + 1 Debug.Print ＂正在读取[＂ & count & ＂]:->＂ & Doc doc2xls (Doc) MyFileName = Dir Loop Next ' For Each Sh In ThisWorkbook.Worksheets ' If Sh.Name = ＂XLS文件清单＂ Then ' Sheets(＂XLS文件清单＂).Cells.Delete ' F = True ' Exit For ' Else ' F = False ' End If ' Next 'If Not F Then ' Sheets.Add.Name = ＂XLS文件清单＂ 'End If 'Sheets(＂XLS文件清单＂).[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys) TT = Time - T Debug.Print ＂共耗时＂ & Minute(TT) & ＂分＂ & Second(TT) & ＂秒＂End SubSub doc2xls(filename As String)Dim xlApp As Object, xlSheet As Object, outfile As String, c As ObjectSet xlApp = CreateObject(＂Excel.Application＂)Set xlSheet = xlApp.Workbooks.Add.Sheets(1)Dim Wapp As Object, Doc As Object, GetDocText As Object 'Word Application 对象、Document 对象Set Wapp = CreateObject(＂Word.Application＂) '创建Word Application 对象Set Doc = Wapp.Documents.Open(filename, ReadOnly:=True) '打开文档，返回一个文档对象'xlSheet.Range(＂A1＂) = Doc.Content.TextDoc.Application.Selection.WholeStory ''''全选Doc.Application.Selection.Copy ''''''''''复制xlSheet.Range(＂A1＂).SelectxlSheet.Pasteoutfile = xlspath + Replace(SplitPath(filename, 1), ＂.doc＂, ＂.xls＂)Debug.Print ＂正在生成：->＂ & outfilexlSheet.Parent.SaveAs outfilexlApp.QuitSet xlSheet = NothingSet xlApp = NothingWapp.QuitSet Doc = NothingSet Wapp = NothingEnd Sub