Cześć mam pytanie jak można ominąć to, że używanie polecenia Dir po raz drugi nadpisuje ścieżkę na której ona działa po raz pierwszy.
Zależy mi na tym, żeby ścieżka z pierwszego Dir'a była pamiętana i później jak chcę przy użyciu tego polecenia wyszukać kolejny plik to, żeby przeszukiwało to odpowiedni folder z pierwszej ściezki.
Trzeba dodać, że te polecenia znajdują się w pętli i dlateg owystępuje u mnie taki problem.
Poniżej zamieszczam kod i z góry dzięki za wszelkie odpowiedzi :)
Function BrowseFolder(Optional Caption As String, _
Optional InitialFolder As String) As String
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
BrowseFolder = F.Items.Item.Path
End If
End Function
'*****TUTAJ ZACZYNA SIĘ KOD POWYŻEJ JEST FUNKCJA WYBIERAJĄCA FOLDER Z KTÓREGO ZACIĄGA PLIKI I POTEM WYBIERA SIĘ FOLDER DOCELOWY*****
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swPart As SldWorks.PartDoc
Dim sFileName As String
Dim Path As String
Dim nErrors As Long
Dim nWarnings As Long
Dim Part As Object
Dim Longstatus As Long
Dim Nazwa As String
Dim NazwaZamykanie1 As String
Dim NazwaZamykanie2 As String
Dim swModelTitle As SldWorks.ModelDoc2
Dim vTitle As Variant
Dim PathSize As Long
Dim PathNoExtention As String
Dim FilePath As String
Dim Path2 As String
Dim Rozszerzenie As String
Dim SLDDRW As String
Dim NowaSciezka2 As String
Set swApp = Application.SldWorks
Path = BrowseFolder(Caption:="Select A Folder/Path")
If Path = "" Then
MsgBox "Please select the path and try again"
End
Else
Path = Path & "\"
End If
sFileName = Dir(Path) '****PIERWSZY DIR
Path2 = BrowseFolder(Caption:="Select A Folder/Path")
If Path2 = "" Then
MsgBox "Please select the path and try again"
End
Else
Path2 = Path2 & "\"
End If
'*******TUTAJ SIĘ ZACZYNA PROBLEM *******
Do Until sFileName = ""
Rozszerzenie = Right(sFileName, 6)
SLDDRW = "SLDDRW"
If StrComp(Rozszerzenie, SLDDRW, vbTextCompare) = 0 Then
Set swModel = swApp.OpenDoc6(Path + sFileName, 3, swOpenDocOptions_Silent, "", nErrors, nWarnings)
Set swPart = Nothing
Set swModelTitle = swApp.GetOpenDocument(vTitle): Debug.Assert Not swModelTitle Is Nothing
Set Part = swApp.ActiveDoc
Nazwa = Path2 & swModelTitle.GetTitle & ".pdf"
If Dir(Nazwa) <> "" Then '*********TUTAJ DRUGI DIR *************
Do Until Dir(NowaSciezka2) = ""
MsgBox "Ta nazwa ju¿ jest w folderze. W kolejnym oknie wpisz koñcówkê inn¹ np -1"
NowaSciezka2 = Path2 & swModelTitle.GetTitle & InputBox("Wpisz koñcówke") & ".pdf"
Loop
Longstatus = Part.SaveAs3(NowaSciezka2, 0, 0)
FilePath = Part.GetPathName
PathSize = Strings.Len(FilePath)
PathNoExtention = Strings.Left(FilePath, PathSize - 7)
PathSize = Strings.Len(Path)
NazwaZamykanie1 = Mid(PathNoExtention, PathSize + 1)
NazwaZamykanie2 = NazwaZamykanie1 & " " & "- Arkusz1"
Else
Longstatus = Part.SaveAs3(Nazwa, 0, 0)
FilePath = Part.GetPathName
PathSize = Strings.Len(FilePath)
PathNoExtention = Strings.Left(FilePath, PathSize - 7)
PathSize = Strings.Len(Path)
NazwaZamykanie1 = Mid(PathNoExtention, PathSize + 1)
NazwaZamykanie2 = NazwaZamykanie1 & " " & "- Arkusz1"
End If
swApp.CloseDoc NazwaZamykanie2
sFileName = Dir '******* TO POLECENIE PRZECZYTUJE JUŻFOLDER GDZIE MAJA BYC ZAPISYWANE PLIKI A NIE TEN SKAD ZACIAGA PLIKI
Else
sFileName = Dir '******* TO POLECENIE PRZECZYTUJE JUŻFOLDER GDZIE MAJA BYC ZAPISYWANE PLIKI A NIE TEN SKAD ZACIAGA PLIKI
End If
Loop
End Sub