需要VBA代码到用于图形填充的相对文件引用

Question

使用Windows 7、Excel 2013我是VBA的新手，花了几个小时尝试不同于其他问题的解决方案。

这是我目前正在使用的代码，用于将我的数字签名插入用作表单的excel文档中

ActiveSheet.Shapes.AddShape(msoShapeRectangle, 208.3333070866, 659.1666929134, _
        243.3333858268, 38.3333070866).Select
    Selection.ShapeRange.ScaleWidth 1.0787668906, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 1.0217405147, msoFalse, _
        msoScaleFromBottomRight
    Selection.ShapeRange.Line.Visible = msoFalse
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .UserPicture "C:UsersmsporneyDocumentsSignature.jpg"
        .TextureTile = msoFalse
        .RotateWithObject = msoTrue

我的问题：当我工作时，代码运行良好。我与其他用户共享此工作簿。我们的文档文件夹中都有相同的文件"signature.jpg"，但这段代码只是指我的机器（msporney）。我需要一个文件位置的相对引用（C:\users\anyone）。

我试过：

.UserPicture "C:users\DocumentsSignature.jpg"
.UserPicture "C:users.DocumentsSignature.jpg"
.UserPicture "C:users\DocumentsSignature.jpg"
.UserPicture "..DocumentsSignature.jpg"

我总是会遇到同样的错误：运行时错误"-2147024893（800700003）"：对象"FillFormat"的方法"UserPicture"失败

Answer 1

如果您不必担心支持多种语言（它将始终是Windows的英语版本），您可以使用以下代码（来自这个SO问题）：

Public Function MyDocsPath() As String
    MyDocsPath = Environ$("USERPROFILE") & "My Documents"
End Function    

只需创建一个变量并将返回值MyDocsPath分配给它，然后连接文件夹位置的其余部分。

如果您需要支持国际化（Windows的多种语言版本），您将需要使用Windows API（代码来自Office开发人员中心的这篇文章）：

Public Declare Function SHGetSpecialFolderLocation _
    Lib "shell32" (ByVal hWnd As Long, _
    ByVal nFolder As Long, ppidl As Long) As Long
Public Declare Function SHGetPathFromIDList _
    Lib "shell32" Alias "SHGetPathFromIDListA" _
    (ByVal Pidl As Long, ByVal pszPath As String) As Long
Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)
Public Const CSIDL_PERSONAL = &H5
Public Const CSIDL_DESKTOPDIRECTORY = &H10
Public Const MAX_PATH = 260
Public Const NOERROR = 0
Public Function SpecFolder(ByVal lngFolder As Long) As String
  Dim lngPidlFound As Long
  Dim lngFolderFound As Long
  Dim lngPidl As Long
  Dim strPath As String
  strPath = Space(MAX_PATH)
  lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
  If lngPidlFound = NOERROR Then
    lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
    If lngFolderFound Then
        SpecFolder = Left$(strPath, _
            InStr(1, strPath, vbNullChar) - 1)
    End If
  End If
  CoTaskMemFree lngPidl
End Function