Run-time error '5':

[Axel]

The program works on a single computer, and the network I use, but does
not work with citrix on a remote desktop (Not the same network).
The "Backup" macro works fine, but not the "Restore"
I paste both below:

This works:
Sub Backup()
ans = MsgBox("Ønsker du å lagre endringer før backup?", vbOKCancel)
If ans = vbOK Then ActiveWorkbook.Save
On Error Resume Next
MkDir ThisWorkbook.Path & "\" & "BackupBHA"
On Error GoTo 0
Dim Fname As String
Dim OrigFname As String
Dim Fpath As String
Dim sht As Worksheet
Dim strdate As String
strdate = Format(Now, "dd-mmm-yy h-mm-ss")
OrigFname = ActiveWorkbook.Name
'Denne må endres offshore
Fpath = ThisWorkbook.Path + "\" + "BackupBHA"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sht In Sheets
Fname = Fpath + "\" + sht.Name + strdate + ".csv"
sht.SaveAs Fname, FileFormat:=xlCSV
Next sht
Fname = Fpath + "\" + OrigFname
MsgBox "Det er tatt backup av alle filene. " & Date & ". BHA
masterlist vil nå lukkes."
ActiveWorkbook.Close savechanges:=False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

This dont:
Private Sub Restore_Click()
'sett dialogparameter
UsrFrmRestore.Hide
On Error Resume Next
MkDir ThisWorkbook.Path & "\" & "BackupBHA"
On Error GoTo 0
Dim myFolder As String
Dim myFileName As Variant
Dim ExistingFolder As String
myFolder = ThisWorkbook.Path & "\" & "BackupBHA"
ExistingFolder = CurDir
ChDrive myFolder
ChDir myFolder
myFileName = Application.GetOpenFilename("BHA backup files (*.csv),
*.csv")
ChDrive ExistingFolder
ChDir ExistingFolder
If myFileName = False Then
MsgBox "Feil"
Exit Sub

Any suggestion?

*** Sent via Developersdex http://www.developersdex.com ***

 

[Axel]

This is the address that the restore macro dont work with.
(Changed some letters with X)

myFolder = "\\XX1stvcl003\Projects\P0024 XXXXXXX IP Drilling\_General -
WIP\07 Rig\Rig Contractor\Shared\Masterlist\BackupBHA"

I have tested it inside the network, so it has nothing to do with
citrix, or remote desktop.
and as wrote before, it works on other network like:
H:\WORK\IP\BackupBHA

*** Sent via Developersdex http://www.developersdex.com ***

 

[Dave Peterson]

Chdir and ChDrive won't work with UNC paths--they will work with mapped drives.

But you can use a Windows API that works with either.

This is a sample that may help you. The first portion is what you care about.

Option Explicit
Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
Sub ChDirNet(szPath As String)
Dim lReturn As Long
lReturn = SetCurrentDirectoryA(szPath)
If lReturn = 0 Then Err.Raise vbObjectError + 1, "Error setting path."
End Sub
Sub testme()
Dim myNewFolder As String
Dim CurFolder As String
Dim UserFileName As Variant
Dim UserFolder As String
Dim TestStr As String
Dim resp As Long

If ActiveWorkbook.Path = "" Then
'keep going, it was based on a template (*.xlt) and hasn't been saved
Else
'get out, it's already been saved
Exit Sub
End If

myNewFolder = "\\uncpath\here\foldername\foldername2"
CurFolder = CurDir

On Error Resume Next
ChDirNet myNewFolder
If Err.Number <> 0 Then
'what should happen
MsgBox "Design error--Folder not found" & vbLf & _
"Contact Vibeke right away, please."
Err.Clear
Exit Sub
End If
On Error GoTo 0

UserFileName = Application.GetSaveAsFilename _
(InitialFileName:="Please Stay in this folder!", _
filefilter:="Excel Files, *.xls")

ChDirNet CurFolder

If UserFileName = False Then
'user hit cancel
Exit Sub
End If

UserFolder = Left(UserFileName, InStrRev(stringcheck:=UserFileName, _
stringmatch:="\", Start:=-1, compare:=vbTextCompare) - 1)

If LCase(UserFolder) = LCase(myNewFolder) Then
'ok
Else
Beep
MsgBox "File NOT Saved!" & vbLf & vbLf _
& "Please choose a filename in: " & vbLf & myNewFolder
Exit Sub
End If

TestStr = ""
On Error Resume Next
TestStr = Dir(UserFileName)
On Error GoTo 0

If TestStr = "" Then
'file doesn't exist
'don't prompt about overwriting
Else
'give them a choice
resp = MsgBox(Prompt:="Overwrite existing file?", Buttons:=vbYesNo)
If resp = vbNo Then
MsgBox "File not saved"
Exit Sub
End If
End If

Application.DisplayAlerts = False 'stop overwrite prompt
Application.EnableEvents = False 'get by that workbook_beforesave event
On Error Resume Next 'just in case
ActiveWorkbook.SaveAs Filename:=UserFileName, _
FileFormat:=xlWorkbookNormal
If Err.Number <> 0 Then
MsgBox "File not saved!" & vbLf & _
Err.Number & vbLf & Err.Description
Err.Clear
Else
MsgBox "Saved to:" & vbLf & UserFileName
End If
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub

 

[Axel]

Thanks alot Dave. I will try it out
Aksel

*** Sent via Developersdex http://www.developersdex.com ***