VBS Save File From Link - excel

I wonder whether someone can help me please.
I wanting to use this solution in a script I'm trying to put together, but I'm a little unsure about how to make a change which needs to be made.
You'll see in the solution that the file type which is opened is a Excel and indeed it's saved as such. But I the files I'd like to open and save are a mixture of .docx and .dat (Used by Dragon software) files.
Could someone possible tell me please is there a way by which I can amend the code so it opens and saves the files in file types other than Excel workbooks.
The reason behind this question because I'm currently using a script which creates a list of files in a Excel spreadsheet from a given folder. For each file that is retrieved there is a hyperlink, which I'd like to add fucntionality to which enables the user to copy the file and save it to a location of their choice.
To help this is the code which I use to create the list of files.
Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)
Dim LastRow As Long
Dim fName As String
On Error Resume Next
For Each FileItem In SourceFolder.Files
' display file properties
Cells(iRow, 3).Formula = iRow - 12
Cells(iRow, 4).Formula = FileItem.Name
Cells(iRow, 5).Formula = FileItem.Path
Cells(iRow, 6).Select
Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
FileItem.Path, TextToDisplay:="Click Here to Open"
iRow = iRow + 1 ' next row number
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
For Each Cell In Range("C13:F" & LastRow) ''change range accordingly
If Cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
Cell.Interior.Color = RGB(232, 232, 232) ''color to preference
Else
Cell.Interior.Color = RGB(141, 180, 226) 'color to preference or remove
End If
Next Cell
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Many thanks and kind regards
Chris

Miguel provided a fantastic solution which on initial testing appeared to work 100%. But as you will see from the comments at the end of the post there were some issues when the user cancelled the operation, so I made another post at this link where the problems were ironed out. Many thanks and kind regards. Chris

The code below shows how to retrieve the extension of a file, define an array with “allowed” extensions, and match the extension of the file to the array.
This is the outline for file manipulation, you'll just need to tailor it to you needs
Dim MinExtensionX
Dim Arr() As Variant
Dim lngLoc As Variant
'Retrieve extension of file
MinExtensionX = Mid(MyFile.Name, InStrRev(MyFile.Name, ".") + 1)
Arr = Array("xls", "xlsx", "docx", "dat") 'define which extensions you want to allow
On Error Resume Next
lngLoc = Application.WorksheetFunction.Match(MinExtensionX, Arr(), 0)
If Not IsEmpty(lngLoc) Then '
'check which kind of extension you are working with and create proper obj manipulation
If MinExtensionX = "docx" then
Set wApp = CreateObject("Word.Application")
wApp.DisplayAlerts = False
Set wDoc = wApp.Documents.Open (Filename:="C:\Documents\SomeWordTemplate.docx", ReadOnly:=True)
'DO STUFF if it's an authorized file. Then Save file.
With wDoc
.ActiveDocument.SaveAs Filename:="C:\Documents\NewWordDocumentFromTemplate.docx"
End With
wApp.DisplayAlerts = True
End if
End If
For files .Dat its a bit more complex, specially if you need to open/process data from the file, but this might help you out.
Edit:
2: Comments added
Hi IRHM,
I think you want something like this:
'Worksheet_FollowHyperlink' is an on click event that occurs every time you click on an Hyperlink within a Worksheet, You can find more here
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'disable events so the user doesn't see the codes selection
Application.EnableEvents = False
Dim FSO
Dim sFile As String
Dim sDFolder As String
Dim thiswb As Workbook ', wb As Workbook
'Define workbooks so we don't lose scope while selecting sFile(thisworkbook = workbook were the code is located).
Set thiswb = thisworkbook
'Set wb = ActiveWorkbook ' This line was commented out because we no longer need to cope with 2 excel workbooks open at the same time.
'Target.Range.Value is the selection of the Hyperlink Path. Due to the address of the Hyperlink being "" we just assign the value to a
'temporary variable which is not used so the Click on event is still triggers
temp = Target.Range.Value
'Activate the wb, and attribute the File.Path located 1 column left of the Hyperlink/ActiveCell
thiswb.Activate
sFile = Cells(ActiveCell.Row, ActiveCell.Column - 1).Value
'Declare a variable as a FileDialog Object
Dim fldr As FileDialog
'Create a FileDialog object as a File Picker dialog box.
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
'Allow only single selection on Folders
fldr.AllowMultiSelect = False
'Show Folder picker dialog box to user and wait for user action
fldr.Show
'add the end slash of the path selected in the dialog box for the copy operation
sDFolder = fldr.SelectedItems(1) & "\"
'FSO System object to copy the file
Set FSO = CreateObject("Scripting.FileSystemObject")
' Copy File from (source = sFile), destination , (Overwrite True = replace file with the same name)
FSO.CopyFile (sFile), sDFolder, True
' check if there's multiple excel workbooks open and close workbook that is not needed
' section commented out because the Hyperlinks no longer Open the selected file
' If Not thiswb.Name = wb.Name Then
' wb.Close
' End If
Application.EnableEvents = True
End Sub
The above code Triggers when you click the Hyperlink and it promps a folder selection window.
You just need to paste the code into the Worksheet code. And you should be good to go.

Related

Save used range as jpg to SharePoint online with variable name

I have been trying for a while now to edit different code pieces found online to save only the used range of my active workbook as a jpg to my SharePoint online directory. I managed to make a VBA Code work that saves the range as a jpg in a local path but when I change this path to my SharePoint online link it only opens my file explorer and asks me to SaveAs.
I am very new to VBA so I basically have no experience and would therefore be very thankful for any help. Below the VBA Code that does not work right now.
I am pretty sure that the issue lies within the ExportName= ... and ChO.Chart.Export since I took this part from a code that SavesAs to a local path. But like mentioned before I am very new to VBA and therefore have no idea how to recode this to my use case.
Sub SaveAsJPG()
Dim ChO As ChartObject, ExportName As String
Dim CopyRange As Range
Dim Pic As Picture
Dim i As Long
Dim SharePointAdress As String
'My SharePoint Online Adress
SharePointAdress = "https://xxxxxx.sharepoint.com/sites/xxxxx/Shared Documents" & "/"
With ActiveSheet
Set CopyRange = .UsedRange
If Not CopyRange Is Nothing Then
Application.ScreenUpdating = False
ExportName = Application.GetSaveAsFilename(InitialFileName:=SharePointAdress & .Range("A1") & "_" & .Range("J1"), FileFilter:="JPEG Files (*.jpg), *.jpg")
If Not ExportName = "False" Then
CopyRange.Copy
.Pictures.Paste
Set Pic = .Pictures(.Pictures.Count)
Set ChO = .ChartObjects.Add(Left:=10, Top:=10, Width:=Pic.Width, Height:=Pic.Height)
Application.CutCopyMode = False
Do
DoEvents
Pic.Copy
DoEvents
ChO.Chart.Paste
DoEvents
i = i + 1
Loop Until (ChO.Chart.Shapes.Count > 0 Or i > 50)
ChO.Chart.Export Filename:=ExportName, Filtername:="JPG"
ChO.Delete
Pic.Delete
End If
Application.ScreenUpdating = True
End If
End With
End Sub
Range A1 & J1 have the name of the Table & the current calender week inside (so the filename is variable). I do not have the option to connect the SharePoint Link to the network folders.
Thank you for any help for a newbie! :)

Open file if not already open

The below code first checks if the required file is open, if it is open then use that file; if not, then open file from the path provided in the cell and read/write with that file. After completing the task, It further checks if the file path & name provided in the below cell is same or not, if same, then do nothing; if not, close the opened file without saving.
It works fine until the file path and name are same in the below cell. Throws an error when the file path and name is different in the below cell. It does not opens the file.
Not sure where am I going wrong. Can someone please help?
Asked Here - https://www.mrexcel.com/board/threads/open-file-if-not-already-open.1199858/
Asked here - https://chandoo.org/forum/threads/open-file-if-not-already-open.47763/
Sub RunQuery1()
Dim Lastrow As Long
Dim OpenBook_path, Available_File As String
Dim FileToOpen As Workbook
Dim wb As Workbook
Application.ScreenUpdating = False
Lastrow = ThisWorkbook.Sheets("Dashboard").Range("F" & Rows.Count).End(xlUp).Row
For i = 9 To Lastrow
OpenBook_path = ThisWorkbook.Sheets("Dashboard").Cells(i, 6) 'Path includes file name with extension
OpenBook_Sheet = ThisWorkbook.Sheets("Dashboard").Cells(i, 7)
OpenBook_Range = ThisWorkbook.Sheets("Dashboard").Cells(i, 8)
'Check if file is open,if open, then use open file; if not, open file from the path in the cell
Available_File = Dir(OpenBook_path) 'extracts the file name from the path
If Not wbOpen(Available_File, wb) Then Set FileToOpen = Workbooks.Open(OpenBook_path)
'open workbook from the path in the cell
With FileToOpen
'Copy range from the sheet
With Sheets(OpenBook_Sheet)
.Range(OpenBook_Range).Select 'Do something
End With
End With
'Check if Below File Path & Name are same
If ThisWorkbook.Sheets("Dashboard").Cells(i, 6) = ThisWorkbook.Sheets("Dashboard").Cells(i + 1, 6) Then
Else
FileToOpen.Close False
End If
Next i
Application.ScreenUpdating = True
End Sub
Function wbOpen(wbName As String, wbO As Workbook) As Boolean
On Error Resume Next
Set wbO = Workbooks(wbName)
wbOpen = Not wbO Is Nothing
End Function

Using function to open and update values in external workbooks, but returning source errors

I've been using a function from another StackOverflow question (I'm SO sorry I can't find the original answer!) to help go through a number of cells in Column L that contains a formula that spits our a hyperlinked filepath. It is meant to open each one (workbook), update the values, then save and close the workbook before opening the next one. See below.
Sub List_UpdateAndSave()
Dim lr As Long
Dim i As Integer
Dim WBSsource As Workbook
Dim FileNames As Variant
Dim msg As String
' Update the individual credit models
With ThisWorkbook.Sheets("List")
lr = .Cells(.Rows.Count, "L").End(xlUp).Row
FileNames = .Range("L2:L" & lr).Value
End With
For i = LBound(FileNames, 1) To UBound(FileNames, 1)
On Error Resume Next
If FileNames(i, 1) Like "*.xls*" Then
Set WBSsource = Workbooks.Open(FileNames(i, 1), _
ReadOnly:=False, _
Password:="", _
UpdateLinks:=3)
If Err = 0 Then
With WBSsource
'do stuff here
.Save
.Close True
End With
Else
msg = msg & FileNames(i, 1) & Chr(10)
On Error GoTo 0
End If
End If
Set WBSsource = Nothing
Next i
If Len(msg) > 0 Then
MsgBox "The Following Files Could Not Be Opened" & _
Chr(10) & msg, 48, "Error"
End If
End Sub
The problem now is I am using this to work on a Network drive, and as a result it cause pathing issues with the Connections/Edit Links part. Each of the files are stored on S:\... which as a result of using the Hyperlink formula, won't be able to find the source data. See below the example image of a file that as been opened through a hyperlink cell from my original workbook. When I go to update the Edit Links section of it, it shows these errors.
If I open that lettered drive in Windows Explorer and find the file, it works with no problems. Open, Update Values > Save > Close, it says unknown...
(but if I click Update values here they update correctly.)
If opened using a Hyperlink formula in a cell (Also directing to S:\..) it says it contains links that cannot be updated. I choose to edit links and they're all "Error: Source not found". The location on them also starts off with \\\corp\... and not S:\.
Anyway to fix this? Apologies for the long winded question.
I'm adding this as an answer as it contains code and is a bit long for a comment.
I'm not sure if it's what you're after though.
The code will take the mapped drive and return the network drive, or visa-versa for Excel files. DriveMap is the variable containing the final string - you may want to adapt into a function.
Sub UpdatePath()
Dim oFSO As Object
Dim oDrv As Object
Dim FileName As String
Dim DriveMap As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileName = Range("A1")
If InStr(oFSO.GetExtensionName(FileName), "xls") > 0 Then
For Each oDrv In oFSO.drives
If oDrv.sharename <> "" Then
'Changes \\corp\.... to S:\
If InStr(FileName, oDrv.sharename) = 1 Then
DriveMap = Replace(FileName, oDrv.sharename, oDrv.Path)
End If
'Changes S:\ to \\corp\....
' If InStr(FileName, oDrv.Path) = 1 Then
' DriveMap = Replace(FileName, oDrv.Path, oDrv.sharename)
' End If
End If
Next oDrv
End If
End Sub

Updatelinks in Powerpoint from identical workbook in different directory (through vba?)

I am working on linking charts in powerpoint (ppt) slides to charts in Excel (xls) workbooks. This works fine without vba code, as I just use paste special to create a link. The problem is however when I change the directoy of the ppt as well as the xls, as the ppt will still try to update the data from the xls in the old directory. My goal however would be to share these files, so everyone can just update their ppt with their xls.
So, to put it shortly, I want to update the ppt, but choose a different workbook (with a different directory). This workbook will be identical to the old one in terms of structure, just with diffeerent data.
I know there is the method updatelinks, but there doesn't seem to be any way to choose a different directory with this method. Does anyone have any tips?
So, to put it shortly, I want to update the ppt, but choose a different workbook (with a different directory). This workbook will be identical to the old one in terms of structure, just with different data.
TRIED AND TESTED with MS-OFFICE 2010
I have commented the code so that you will not have a problem understanding it. If you still do then feel free to ask.
Option Explicit
Sub UpDateLinks()
'~~> Powerpoint Variables/Objects
Dim ofd As FileDialog
Dim initDir As String
Dim OldSourcePath As String, NewSourcePath As String
'~~> Excel Objects
Dim oXLApp As Object, oXLWb As Object
'~~> Other Variables
Dim sPath As String, OldPath As String, sFullFileOld As String
Dim oldFileName As String, newFileName As String
'Set the initial directory path of File Dialog
initDir = "C:\"
'~~> Get the SourceFullName of the chart. It will be something like
' C:\MyFile.xlsx!Sheet1![MyFile.xlsx]Sheet1 Chart 1
OldSourcePath = ActivePresentation.Slides(1).Shapes(1).LinkFormat.SourceFullName
Set ofd = Application.FileDialog(msoFileDialogFilePicker)
With ofd
.InitialFileName = initDir
.AllowMultiSelect = False
If .Show = -1 Then
'~~> Get the path of the newly selected workbook. It will be something like
' C:\Book2.xlsx
sPath = .SelectedItems(1)
'~~> Launch Excel
Set oXLApp = CreateObject("Excel.Application")
oXLApp.Visible = True
'~~> Open the Excel File. Required to update the chart's source
Set oXLWb = oXLApp.Workbooks.Open(sPath)
'~~> Get the path "C:\MyFile.xlsx" from
'~~> say "C:\MyFile.xlsx!Sheet1![MyFile.xlsx]Sheet1 Chart 1"
OldPath = Split(OldSourcePath, "!")(0)
'~~> Get just the filename "MyFile.xlsx"
oldFileName = GetFilenameFromPath(OldPath)
'~~> Get just the filename "Book2.xlsx" from the newly
'~~> Selected file
newFileName = GetFilenameFromPath(.SelectedItems(1))
'~~> Replace old file with the new file
NewSourcePath = Replace(OldSourcePath, oldFileName, newFileName)
'Debug.Print NewSourcePath
'~~> Change the source and update
ActivePresentation.Slides(1).Shapes(1).LinkFormat.SourceFullName = NewSourcePath
ActivePresentation.Slides(1).Shapes(1).LinkFormat.Update
DoEvents
'~~> Close Excel and clean up
oXLWb.Close (False)
Set oXLWb = Nothing
oXLApp.Quit
Set oXLApp = Nothing
End If
End With
Set ofd = Nothing
End Sub
Public Function GetFilenameFromPath(ByVal strPath As String) As String
If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
GetFilenameFromPath = _
GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End If
End Function

copy a sheet from a workbook without opening to another [duplicate]

I want to collect data from different files and insert it into a workbook doing something like this.
Do While THAT_DIFFERENT_FILE_SOMEWHERE_ON_MY_HDD.Cells(Rand, 1).Value <> "" And Rand < 65536
then 'I will search if the last row in my main worksheet is in this file...
End Loop
If the last row from my main worksheet is in the file, I'll quit the While Loop. If not, I'll copy everything. I'm having trouble finding the right algorithm for this.
My problem is that I don't know how to access different workbooks.
The best (and easiest) way to copy data from a workbook to another is to use the object model of Excel.
Option Explicit
Sub test()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xls", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set targetworkbook
Set wb2 = ActiveWorkbook
'For instance, copy data from a range in the first workbook to another range in the other workbook
wb2.Worksheets("Sheet2").Range("C3:D4").Value = wb.Worksheets("Sheet1").Range("A1:B2").Value
End Sub
You might like the function GetInfoFromClosedFile()
Edit: Since the above link does not seem to work anymore, I am adding alternate link 1 and alternate link 2 + code:
Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
wbName As String, wsName As String, cellRef As String) As Variant
Dim arg As String
GetInfoFromClosedFile = ""
If Right(wbPath, 1) <> "" Then wbPath = wbPath & ""
If Dir(wbPath & "" & wbName) = "" Then Exit Function
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
On Error Resume Next
GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function
Are you looking for the syntax to open them:
Dim wkbk As Workbook
Set wkbk = Workbooks.Open("C:\MyDirectory\mysheet.xlsx")
Then, you can use wkbk.Sheets(1).Range("3:3") (or whatever you need)
There's very little reason not to open multiple workbooks in Excel. Key lines of code are:
Application.EnableEvents = False
Application.ScreenUpdating = False
...then you won't see anything whilst the code runs, and no code will run that is associated with the opening of the second workbook. Then there are...
Application.DisplayAlerts = False
Application.Calculation = xlManual
...so as to stop you getting pop-up messages associated with the content of the second file, and to avoid any slow re-calculations. Ensure you set back to True/xlAutomatic at end of your programming
If opening the second workbook is not going to cause performance issues, you may as well do it. In fact, having the second workbook open will make it very beneficial when attempting to debug your code if some of the secondary files do not conform to the expected format
Here is some expert guidance on using multiple Excel files that gives an overview of the different methods available for referencing data
An extension question would be how to cycle through multiple files contained in the same folder. You can use the Windows folder picker using:
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .Selected.Items.Count = 1 the InputFolder = .SelectedItems(1)
End With
FName = VBA.Dir(InputFolder)
Do While FName <> ""
'''Do function here
FName = VBA.Dir()
Loop
Hopefully some of the above will be of use
I had the same question but applying the provided solutions changed the file to write in. Once I selected the new excel file, I was also writing in that file and not in my original file. My solution for this issue is below:
Sub GetData()
Dim excelapp As Application
Dim source As Workbook
Dim srcSH1 As Worksheet
Dim sh As Worksheet
Dim path As String
Dim nmr As Long
Dim i As Long
nmr = 20
Set excelapp = New Application
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
.Show
path = .SelectedItems.Item(1)
End With
Set source = excelapp.Workbooks.Open(path)
Set srcSH1 = source.Worksheets("Sheet1")
Set sh = Sheets("Sheet1")
For i = 1 To nmr
sh.Cells(i, "A").Value = srcSH1.Cells(i, "A").Value
Next i
End Sub
With excelapp a new application will be called. The with block sets the path for the external file. Finally, I set the external Workbook with source and srcSH1 as a Worksheet within the external sheet.

Resources