vba - Excel VBA中的相对而不是绝对路径

Question

我编写了一个 Excel VBA 宏，它在对数据执行计算之前从 HTML 文件（本地存储）导入数据。

目前 HTML 文件是用绝对路径引用的：

Workbooks.Open FileName:="C:\Documents and Settings\Senior Caterer\My Documents\Endurance Calculation\TRICATEndurance Summary.html"

但是，我想使用相对路径而不是绝对路径来引用它（这是因为我想将电子表格分发给可能不使用相同文件夹结构的同事）。由于 html 文件和 excel 电子表格位于同一个文件夹中，我不会认为这会很困难，但是我完全无法做到。我在网上搜索过，建议的解决方案都显得非常复杂。

我在工作中使用 Excel 2000 和 2002，但是当我计划分发它时，我希望它可以与尽可能多的 Excel 版本一起使用。

任何建议都非常感激。

Answer 1

只是为了澄清 yalestar 所说的，这将为您提供相对路径：

Workbooks.Open FileName:= ThisWorkbook.Path & "\TRICATEndurance Summary.html"

Answer 2

您可以将其中之一用于相对路径根：

ActiveWorkbook.Path
ThisWorkbook.Path
App.Path

Answer 3

我认为问题是只有在正确设置“当前目录”的情况下才能打开没有路径的文件。

尝试在即时窗口中键入“Debug.Print CurDir” - 这应该会显示在工具...选项中设置的默认文件的位置。

我不确定我对它是否完全满意，也许是因为它有点像一个遗留的 VB 命令，但你可以这样做：

ChDir ThisWorkbook.Path

我想我更喜欢使用 ThisWorkbook.Path 来构造 HTML 文件的路径。我是 Scripting Runtime 中 FileSystemObject 的忠实粉丝（它似乎总是被安装），所以我会更乐意做这样的事情（在设置对 Microsoft Scripting Runtime 的引用之后）：

Const HTML_FILE_NAME As String = "my_input.html"

With New FileSystemObject
    With .OpenTextFile(.BuildPath(ThisWorkbook.Path, HTML_FILE_NAME), ForReading)
        ' Now we have a TextStream object that we can use to read the file
    End With
End With

Answer 4

如果操作系统的当前目录是您正在使用的工作簿的路径，Workbooks.Open FileName:= "TRICATEndurance Summary.html"就足够了。如果您正在使用路径进行计算，您可以参考当前目录.，然后\告诉文件在该目录中，如果您必须将操作系统的当前目录更改为工作簿的路径，您可以使用ChDrive并ChDir这样做.

ChDrive ThisWorkbook.Path
ChDir ThisWorkbook.Path
Workbooks.Open FileName:= ".\TRICATEndurance Summary.html"

Answer 5

您可以通过向用户提供浏览器按钮来为用户提供更多灵活性

Private Sub btn_browser_file_Click()
Dim xRow As Long
Dim sh1 As Worksheet
Dim xl_app As Excel.Application
Dim xl_wk As Excel.Workbook
Dim WS As Workbook
Dim xDirect$, xFname$, InitialFoldr$
InitialFoldr$ = "C:\"
With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = Application.DefaultFilePath & "\"
    .Title = "Please select a folder to list Files from"
    .InitialFileName = InitialFoldr$
    .Show
    Range("H13").Activate
    If .SelectedItems.Count <> 0 Then
        xDirect$ = .SelectedItems(1) & "\"
         Range("h12").Value = xDirect$
        xFname$ = Dir(xDirect$, 7)
        Do While xFname$ <> ""
         If (Format(FileDateTime(xDirect$ & "\" & xFname$), "MM/DD/YYYY") > Format(Range("H10").Value, "MM/DD/YYYY")) Then
            ActiveCell.Offset(xRow) = xFname$
            xRow = xRow + 1
            xFname$ = Dir
            Else
            xFname$ = Dir
            xRow = xRow
        End If
        Loop
    End If
End With

使用这段代码，您可以轻松实现这一目标。测试代码

Answer 6

这是我从相对路径获取绝对路径的快速简单的函数。

与接受的答案不同的是，此函数可以处理向上移动到父文件夹的相对路径。

例子：

Workbooks.Open FileName:=GetAbsolutePath("..\..\TRICATEndurance Summary.html")

代码：

' Gets an absolute path from a relative path in the active workbook
Public Function GetAbsolutePath(relativePath As String) As String
    
    Dim absPath As String
    Dim pos As Integer
    
    absPath = ActiveWorkbook.Path
    
    ' Make sure paths are in correct format
    relativePath = Replace(relativePath, "/", "\")
    absPath = Replace(absPath, "/", "\")
    
    Do While Left$(relativePath, 3) = "..\"
    
        ' Remove level from relative path
        relativePath = Mid$(relativePath, 4)
        
        ' Remove level from absolute path
        pos = InStrRev(absPath, "\")
        absPath = Left$(absPath, pos - 1)
    
    Loop
    
    GetAbsolutePath = PathCombine(absPath, relativePath)
    
End Function

Answer 7

我认为这可能会有所帮助。下面的宏检查文件夹是否存在，如果不存在则创建文件夹并以 xls 和 pdf 格式保存在该文件夹中。碰巧该文件夹与相关人员共享，因此每个人都得到了更新。

Sub PDF_laudo_e_Prod_SP_Sem_Ajuste_Preco()
'
' PDF_laudo_e_Prod_SP_Sem_Ajuste_Preco Macro
'

'


Dim MyFolder As String
Dim LaudoName As String
Dim NF1Name As String
Dim OrigFolder As String

MyFolder = ThisWorkbook.path & "\" & Sheets("Laudo").Range("C9")
LaudoName = Sheets("Laudo").Range("K27")
NF1Name = Sheets("PROD SP sem ajuste").Range("Q3")
OrigFolder = ThisWorkbook.path

Sheets("Laudo").Select
Columns("D:P").Select
Selection.EntireColumn.Hidden = True

If Dir(MyFolder, vbDirectory) <> "" Then
Sheets("Laudo").ExportAsFixedFormat Type:=xlTypePDF, filename:=MyFolder & "\" & LaudoName & ".pdf", Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False

Sheets("PROD SP sem ajuste").ExportAsFixedFormat Type:=xlTypePDF, filename:=MyFolder & "\" & NF1Name & ".pdf", Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False

ThisWorkbook.SaveAs filename:=MyFolder & "\" & LaudoName

Application.DisplayAlerts = False

ThisWorkbook.SaveAs filename:=OrigFolder & "\" & "Entregas e Instrucao Barter 2015 - beta"

Application.DisplayAlerts = True

Else
MkDir MyFolder
Sheets("Laudo").ExportAsFixedFormat Type:=xlTypePDF, filename:=MyFolder & "\" & LaudoName & ".pdf", Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False

Sheets("PROD SP sem ajuste").ExportAsFixedFormat Type:=xlTypePDF, filename:=MyFolder & "\" & NF1Name & ".pdf", Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False

ThisWorkbook.SaveAs filename:=MyFolder & "\" & LaudoName

Application.DisplayAlerts = False

ThisWorkbook.SaveAs filename:=OrigFolder & "\" & "Entregas e Instrucao Barter 2015 - beta"

Application.DisplayAlerts = True

End If

Sheets("Laudo").Select
Columns("C:Q").Select
Selection.EntireColumn.Hidden = False
Range("A1").Select

End Sub

Answer 8

这可能不是最好的方法。但是我发现获得绝对路径的唯一方法是计算语法 .. 在字符串中出现了多少次，然后使用函数 gotoparent 与语法出现在超链接地址中的次数一样多。（在我的情况下，我的字段是一个超链接地址。ps：此代码需要引用microsoft scripting runtime

Function AbsolutePath(strRelativePath As String, strCurrentFileName As String) As String
Dim fso As Object
Dim strCurrentProjectpath As String
Dim strGoToParentFolder As String
Dim strOrigineFolder As String
Dim strPath As String
Dim lngParentFolder As Long


''Pour retrouver le répertoire parent
Set fso = CreateObject("Scripting.FileSystemObject")

'' détermine le répertire du projet actif
strCurrentProjectpath = CurrentProject.Path

'' détermine le nom du répertoire dans lequel le fichier d'origine se trouve
strOrigineFolder = Replace(Replace(Replace(strRelativePath, strCurrentFileName, ""), "..", ""), "\", "")

''Extraction du chemin relatif (ex. ..\..\..)
strGoToParentFolder = Replace(Replace(strRelativePath, strOrigineFolder, ""), strCurrentFileName, "")

''retourne le nombre de fois qu'il faut remonter au répertoire parent
lngParentsFolder = Len(Replace(strGoToParentFolder, "\", "")) / 2

''détermine la valeur d'origine du répertoire du début
strPath = strCurrentProjectpath

Vérifie s 'il faut aller au répertoire parent
If lngParentsFolder < 1 Then
    'si non, alors répertoire parent et répertoire d'origine du fichier
    strPath = strCurrentProjectpath & "\" & strOrigineFolder
Else
    ''si oui, nous faisons la boucle pour retourner au répertoire d'origine
    For i = 1 To lngParentsFolder
        strPath = fso.GetParentFolderName(strPath)
    Next i
End If

''retournons le répertoire parent du fichier et son répertoire d'origine [le OUTPUT]
AbsolutePath = strPath & strOrigineFolder & "\"

End Function