adygelber
05-07-2014, 08:09 AM
Hello everyone,
Until few days ago I used the below mentioned script to update a file from a specific location under Office 2003. Now, under Office 2010 is no longer working.
Can anyone help me to adapt it to the new Office version?
Thanks in advance!
Sub checkforupdates()
Dim fs As FileSearch, ws As Worksheet, i As Long
Set fs = Application.FileSearch
With fs
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
.LookIn = "c:\ (file://\\10.230.30.15\Telefoni\ICU)"
If .Execute > 0 Then
Set ws = ActiveSheet
For i = 1 To .FoundFiles.Count
ws.Cells(i, 31) = Mid$(.FoundFiles(i), InStrRev(.FoundFiles(i), "\") + 1)
Next
Else
MsgBox "No files found"
Exit Sub
End If
End With
If Range("AD1").Value >= Range("AF1").Value Then
MsgBox " CONGRATULATIONS!" & vbNewLine & _
"You are using the latest version of IBAN Check Utility."
Else
Dim varResponse As Variant
varResponse = MsgBox("There is a new version available. Do you want to download it?", vbYesNo, "New version available")
If varResponse = vbYes Then
GoTo download
ElseIf varResponse = vbNo Then
GoTo endscript
End If
download:
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim objWSHShell As Object
Dim strSpecialFolderPath
Set objWSHShell = CreateObject("WScript.Shell")
SpecialFolderPath = objWSHShell.SpecialFolders("Desktop")
FromPath = "c:\ (file://\\10.230.30.15\Telefoni\ICU)"
ToPath = SpecialFolderPath
If Right(FromPath, 1) = "\" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If
If Right(ToPath, 1) = "\" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
FSO.CopyFolder Source:=FromPath, Destination:=ToPath
MsgBox "You can find the new file on your Desktop."
End If
Exit Sub
endscript:
Exit Sub
End Sub
Until few days ago I used the below mentioned script to update a file from a specific location under Office 2003. Now, under Office 2010 is no longer working.
Can anyone help me to adapt it to the new Office version?
Thanks in advance!
Sub checkforupdates()
Dim fs As FileSearch, ws As Worksheet, i As Long
Set fs = Application.FileSearch
With fs
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
.LookIn = "c:\ (file://\\10.230.30.15\Telefoni\ICU)"
If .Execute > 0 Then
Set ws = ActiveSheet
For i = 1 To .FoundFiles.Count
ws.Cells(i, 31) = Mid$(.FoundFiles(i), InStrRev(.FoundFiles(i), "\") + 1)
Next
Else
MsgBox "No files found"
Exit Sub
End If
End With
If Range("AD1").Value >= Range("AF1").Value Then
MsgBox " CONGRATULATIONS!" & vbNewLine & _
"You are using the latest version of IBAN Check Utility."
Else
Dim varResponse As Variant
varResponse = MsgBox("There is a new version available. Do you want to download it?", vbYesNo, "New version available")
If varResponse = vbYes Then
GoTo download
ElseIf varResponse = vbNo Then
GoTo endscript
End If
download:
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim objWSHShell As Object
Dim strSpecialFolderPath
Set objWSHShell = CreateObject("WScript.Shell")
SpecialFolderPath = objWSHShell.SpecialFolders("Desktop")
FromPath = "c:\ (file://\\10.230.30.15\Telefoni\ICU)"
ToPath = SpecialFolderPath
If Right(FromPath, 1) = "\" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If
If Right(ToPath, 1) = "\" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
FSO.CopyFolder Source:=FromPath, Destination:=ToPath
MsgBox "You can find the new file on your Desktop."
End If
Exit Sub
endscript:
Exit Sub
End Sub