Solved: problem with coping file address to clipboard

[dschmitt]

I have an Excel VBA script (see below) that copies the path of a file to the clipboard. Unfortunately this script does not work in PowerPoint.

Does anybody know how to modify this script so that it will work in PowerPoint?


Sub GetLink()
' Requires a reference to Microsoft Forms Object Library
Dim oDO As DataObject
Dim sFile As String

sFile = Application.GetOpenFilename
If sFile = "False" Then Exit Sub

sFile = Path2UNC(sFile)
If Len(sFile) Then
MsgBox sFile
Set oDO = New DataObject
oDO.SetText sFile
oDO.PutInClipboard
Beep ' the sound of success
Else
MsgBox "No UNC path!"
End If
End Sub

Function Path2UNC(sFullName As String) As String
' Converts the mapped drive path in sFullName to a UNC path if one exists.
' If not, returns a null string
Dim sDrive As String
Dim i As Long
sDrive = UCase(Left(sFullName, 2))
With CreateObject("WScript.Network").EnumNetworkDrives
For i = 0 To .Count - 1 Step 2
If .Item(i) = sDrive Then
Path2UNC = .Item(i + 1) & Mid(sFullName, 3)
Exit For
End If
Next
End With
End Function

[John Wilson]

Does making this change work?
sFile = Application.ActivePresentation.FullName
If sFile = "" Then Exit Sub

[dschmitt]

John, using your script results in the macro giving me the address of the open PowerPoint file.

Therefore in principle the macro is working. However I don't want the address of the open PowerPoint file. I want the macro to open a window that lets me select the file for which I want the address of.

I need this for the following application. I create PowerPoint files with lots of references to publications. I have these publications on a harddisk. The macro would allow me to get the address quickly to subsequently create a hyperlink to the publication in PowerPoint.

[Cosmo]

John, using your script results in the macro giving me the address of the open PowerPoint file.

Therefore in principle the macro is working. However I don't want the address of the open PowerPoint file. I want the macro to open a window that lets me select the file for which I want the address of.

I need this for the following application. I create PowerPoint files with lots of references to publications. I have these publications on a harddisk. The macro would allow me to get the address quickly to subsequently create a hyperlink to the publication in PowerPoint.

This is what I use to select a file in PPT. Should work in all versions of Office applications to my knowledge:
Option Explicit

Public Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Public Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
"GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Public Const OFN_ALLOWMULTISELECT = &H200&
Public Const OFN_EXPLORER = &H80000
Public Const OFN_FILEMUSTEXIST = &H1000&
Public Const OFN_HIDEREADONLY = &H4&
Public Const OFN_PATHMUSTEXIST = &H800&
Public Function ShowFileOpenDialog(ByRef FileList As Collection, _
Optional Dialogtitle As String = "Open a PowerPoint File:", _
Optional initialDirectory As String = "", _
Optional fileExtension As String = ".pptx", _
Optional allowMultipleSelection As Boolean = True)
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim FileDir As String
Dim FilePos As Long
Dim PrevFilePos As Long
With OpenFile
.lStructSize = Len(OpenFile)
.hwndOwner = 0
.hInstance = 0
.lpstrFilter = "PowerPoint File" + Chr(0) + "*" + fileExtension + _
Chr(0) + "All Files (*.*)" + Chr(0) + "*.*" + Chr(0) + Chr(0)
.nFilterIndex = 1
.lpstrFile = String(4096, 0)
.nMaxFile = Len(.lpstrFile) - 1
.lpstrFileTitle = .lpstrFile
.nMaxFileTitle = .nMaxFile
.lpstrInitialDir = initialDirectory
.lpstrTitle = Dialogtitle
If allowMultipleSelection Then
.Flags = OFN_HIDEREADONLY + _
OFN_PATHMUSTEXIST + _
OFN_FILEMUSTEXIST + _
OFN_EXPLORER + _
OFN_ALLOWMULTISELECT
Else
.Flags = OFN_HIDEREADONLY + _
OFN_PATHMUSTEXIST + _
OFN_FILEMUSTEXIST + _
OFN_EXPLORER
End If
lReturn = GetOpenFileName(OpenFile)
If lReturn <> 0 Then
FilePos = InStr(1, .lpstrFile, Chr(0))
If Mid(.lpstrFile, FilePos + 1, 1) = Chr(0) Then
FileList.Add .lpstrFile
'Set FileList(1) = .lpstrFile
Else
FileDir = Mid(.lpstrFile, 1, FilePos - 1)
Do While True
PrevFilePos = FilePos
FilePos = InStr(PrevFilePos + 1, .lpstrFile, Chr(0))
If FilePos - PrevFilePos > 1 Then
FileList.Add FileDir + "\" + _
Mid(.lpstrFile, PrevFilePos + 1, _
FilePos - PrevFilePos - 1)
Else
Exit Do
End If
Loop
End If
End If
End With
End Function
Sub TestSelectFiles()
' Demonstration routine
Dim FileList As Collection
Dim i As Long
Dim S As String

Set FileList = New Collection
ShowFileOpenDialog FileList
With FileList
If .Count > 0 Then
S = "The following files were selected:" + vbCrLf
For i = 1 To .Count
S = S + .Item(i) + vbCrLf
Next
MsgBox S
Else
MsgBox "No files were selected!"
End If
End With
End Sub


The 'TestSelectFiles' function will give you an idea of how to use the code. The 'ShowFileOpenDialog' function has a few different optional parameters you can use to allow you to alter the properties of the open dialog.

Hope this helps.

[dschmitt]

Cosmo, thanks for your script. I will try it next Wednesday. We got a very long weekend in Japan.

[John Wilson]

What version of PowerPoint do you have. There are easier ways to open a file selection dialog after 2002

Anyway I don't really see what you are trying to do you can quickly create links by inserting the text, selecting it and ctrl K to open a file dialog. If you need the text to be the link address you can leave it selected and run this one liner.

Sub linktext()
With ActiveWindow.Selection.TextRange
.Text = .ActionSettings(ppMouseClick).Hyperlink.Address
End With
End Sub

Sorry if I'm completely misunderstanding

[dschmitt]

I am using PowerPoint 2007.

I know about the method you explained (selecting the text, ctrl K, etc.). This works well and is quick. However the links that are created are the problem.

If I make e.g. a link in PowerPoint to a file on my V drive which is a network disk (V\Documents\file.txt) than I can open the file on my computer with the PowerPoint link. However, on somebody else computer my V drive may be his O drive. In that case the PowerPoint link will fail for that person.

For that reason the Excel macro was created. It creates a universal link. Currently I am going back and forth between PowerPoint and Excel to get the universal links I need.

To make life simpler I would like to have the macro working from the PowerPoint menubar. However the macro is not working in PowerPoint because the macro crashes on the following line


sFile = Application.GetOpenFilename

Try my Excel code in Excel to see what it does. Just copy and paste it.

[John Wilson]

Does this help:
Sub getfilelocation()
Dim fd As FileDialog
Dim sfilename As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
'change to suit
.InitialFileName = "C:\Books"
.InitialView = msoFileDialogViewList
On Error Resume Next
.AllowMultiSelect = False
.Title = "Please browse for your file"
.Filters.Clear
.Filters.Add "Files", "*.*"
If .Show = True Then sfilename = .SelectedItems(1)
MsgBox sfilename
End With
End Sub

[dschmitt]

that looks promising. I will try that on Wednesday. I can't do it any earlier.

[dschmitt]

John, I merged your script with mine. It is working.
Below is the merged script. And attached is a PPTM file that includes a Ribbon button to execute the macro. Save the file as PPAM file to obtain an addin.


Sub GetLink()
' Requires a reference to Microsoft Forms Object Library
Dim oDO As DataObject
Dim sFile As String
Dim fd As FileDialog

Set fd = Application.FileDialog(msoFileDialogFilePicker)

With fd
'change to suit
.InitialFileName = "C:\Books"
.InitialView = msoFileDialogViewList
On Error Resume Next
.AllowMultiSelect = False
.Title = "Please browse for your file"
.Filters.Clear
.Filters.Add "Files", "*.*"
If .Show = True Then sFile = .SelectedItems(1)
End With

sFile = Path2UNC(sFile)
If Len(sFile) Then
MsgBox sFile
Set oDO = New DataObject
oDO.SetText sFile
oDO.PutInClipboard
Beep ' the sound of success
Else
MsgBox "No UNC path!"
End If
End Sub
Function Path2UNC(sFullName As String) As String
' Converts the mapped drive path in sFullName to a UNC path if one exists.
' If not, returns a null string
Dim sDrive As String
Dim i As Long
sDrive = UCase(Left(sFullName, 2))
With CreateObject("WScript.Network").EnumNetworkDrives
For i = 0 To .Count - 1 Step 2
If .Item(i) = sDrive Then
Path2UNC = .Item(i + 1) & Mid(sFullName, 3)
Exit For
End If
Next
End With
End Function

[John Wilson]

Thats good!

.InitialFileName needs to point at a folder and end with \ (my mistake)

Exanple if the intial folder is Books on C

.InitialFileName = "C:\Books\"

[dschmitt]

Thanks for the correction. I changed my macro accordingly.