عدم انتخاب فایل در پوشه های با نام فارسی هنگام جستجو با DialogFilePicker

[ZAMEN58]

با سلام
من برنامه ای دارم که در آن یک تصویر می بایست از پوشه ای دلخواه انتخاب شده و در پوشه ای با نام تجهیز مورد نظر و بعد پوشه ای با نام تاریخ ذخیره شده و نام آن فایل نیز به تاریخ روز + تعداد فایلهای داخل پوشه تغییر کند
مشکل کار اینجاست که اگر تصویر از پوشه ای با نام فارسی انتخاب شود یا در مسیر تا پوشه نهایی ، پوشه ای با نام فارسی باشد و یا نام فایل انتخابی فارسی باشد ، فایل انتخابی انتقال پیدا نمی کند
لطفا راهنمایی فرمایید
متاسفانه چون حجم فایل بسیار زیاد است قادر به پیوست نیستم
با تشکر



Dim FSO As Object
Dim I As Integer
Dim SplitDir() As String
Dim CreateDir As String
Dim strDirectoryPath, strPicturePath, strOldDirectoryPath, strNewDirectoryPath, strOldFileName, strNewFileName, strOldFileType, strNewFileDir, strNodeID, strItemName As String
Dim strFileCount As Integer
ItemName1 = ItemName
NodeID1 = NodeID
InsertDate1 = InsertDate
Me.DirectoryPath1 = DirectoryPath
Forms!frmInsertPicture.Cycle = 0
DoCmd.GoToRecord , , acNewRec
DirectoryPath = DirectoryPath1
ItemName = ItemName1
NodeID = NodeID1
InsertDate = InsertDate1
DirectoryPath1 = DirectoryPath
strDirectoryPath = DirectoryPath & "\Picture" & InsertDate & ""
strPicturePath = CurrentProject.Path & "\Picture" & InsertDate & ""
If IsNull(strDirectoryPath) Or strDirectoryPath = "\Picture" & InsertDate & "" Then
strDirectoryPath = strPicturePath
End If
SplitDir = Split(strDirectoryPath, "")
Set FSO = CreateObject("Scripting.FileSystemObject")
I = 0
For I = LBound(SplitDir()) To UBound(SplitDir())
If I = 0 Then
CreateDir = SplitDir(I)
Else
CreateDir = CreateDir & "" & SplitDir(I)
End If
If FSO.FolderExists(CreateDir) = False Then
FSO.CreateFolder (CreateDir)
End If
Next I
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = strPicturePath
.InitialView = msoFileDialogViewLargeIcons
.Filters.Clear
.Filters.add "jpeg", "*.jpg"
.Filters.add "bitmap", "*.bmp"
.Filters.add "tiff", "*.tif"
.Filters.add "GIF", "*.gif"
.Filters.add "PNG", ".png"
.Filters.add "All Files", "*.*"
.FilterIndex = 1
.AllowMultiSelect = False
.Title = "ÇäÊÎÇÈ ÝÇíá ÊÕæíÑ"
If .Show = -1 Then
strOldDirectoryPath = .SelectedItems(1)
strOldFileName = Dir(.SelectedItems(1))
strOldFileType = Right(strOldFileName, 3)
strNewDirectoryPath = strDirectoryPath
strNewFileDir = Dir(strNewDirectoryPath & "*." & strOldFileType)
Do While strNewFileDir <> ""
strFileCount = strFileCount + 1
strNewFileDir = Dir()
Loop
strNewFileName = InsertDate & "(" & strFileCount + 1 & ")." & strOldFileType
Name strOldDirectoryPath As strNewDirectoryPath & strNewFileName
PictureFolderPath = strNewDirectoryPath
CopyMoveTick = 1
End If
End With
Forms!frmInsertPicture.Cycle = 1
Debug.Print strOldDirectoryPath
Debug.Print strOldFileName
Debug.Print strNewDirectoryPath
End Function

[Amir Ghasemiyan]

سلام دوست عزيز

شما بايد از كد اسكي استفاده كنيد.
داخل انجمن كد اسكي رو سرچ بفرماييد

در اين لينك كدي نوشتم كه متن رو به كد اسكي و برعكس تبديل ميكنه. اميدوارم مفيد باشه
https://forum.exceliran.com/showthread.php/3858

[ZAMEN58]

سلام آقای قاسمیان
ممنون از لطفی که فرمودید
برنامه ای که نوشتید خیلی جاها به کارم اومد ولی توی این مورد باز هم جواب نداد
من هم با روش زیر نوشتم و جواب داد
ببینید مشکل دو تاست . یکی اینکه باید از یه پوشه فارسی انتخاب بشه و دوم اینکه باید توی یه پوشه فارسی منتقل بشه و اسمش هم عوض بشه ولی مشکل اینجاست که وقتی از تابعDIR استفاده می کنیم توی پوشه های فارسی جواب نمی ده و بایستی برای بدست اوردن تعدا فایل از دستور زیر استفاده کنیم
lngTargetFilesCount1 = FSO.GetFolder(strTargetPath).Files.Count
من فایل را ابتدا از پوشه مبدأ به دایرکتوری اصلی مثلا D:\ منتقل کردم بعدش اونجا اسمش را تغییر دادم و بعد اون رو به پوشه مقصد انتقال دادم

If InsertDate = 0 Then Exit Sub
If IsNull(NodeID) Or NodeID = "0" Then Exit Sub
On Error Resume Next
Dim FSO As Object
Dim A, B, c As Integer, lngLenSourcePath As Long, lngTargetFilesCount1 As Long, lngTargetFilesCount2 As Long, lngLenSourceFileName, lngInsertDate As Long
Dim SplitDir() As String, CreateDir As String, strPictureFolder As String, strSourcePath As String, strTempPath As String, TmpFileName As String
Dim strSourceFileName As String, strTargetFileName As String, strFileType As String, strTargetPath As String, PathAsciiCode As Variant
'================================================= ================================================== ================================================== =====
strTargetPath = SelDirectoryPath & Chr(92) & Chr(202) & Chr(213) & Chr(199) & Chr(230) & Chr(237) & Chr(209) & Chr(92) & InsertDate & Chr(92)
'================================================= ================================================== ===============================================
strPictureFolder = CurrentProject.Path & Chr(92) & Chr(202) & Chr(213) & Chr(199) & Chr(230) & Chr(237) & Chr(209) & Chr(92) & InsertDate & Chr(92)
'================================================= ================================================== ===============================================
If IsNull(strTargetPath) Or IsNull(NodeID) Or NodeID = "0" Then
strTargetPath = strPictureFolder
End If
'================================================= ==
Set FSO = CreateObject("Scripting.FileSystemObject")
SplitDir = Split(strTargetPath, "")
A = 0
For A = LBound(SplitDir()) To UBound(SplitDir())
If A = 0 Then
CreateDir = SplitDir(A)
Else
CreateDir = CreateDir & Chr(92) & SplitDir(A)
End If
If FSO.FolderExists(CreateDir) = False Then
FSO.CreateFolder (CreateDir)
End If
Next A
lngInsertDate = InsertDate
Forms!frmInsertPicture.Cycle = 0
DoCmd.GoToRecord , , acNewRec
Forms!frmInsertPicture.Cycle = 1
NodeID = SelNodeID
ItemName = SelItemName
InsertDate = lngInsertDate
With Application.FileDialog(msoFileDialogFilePicker)
'================================================= ==
.InitialFileName = CurrentProject.Path
.InitialView = msoFileDialogViewLargeIcons
.Filters.Clear
.Filters.Add "jpeg", "*.jpg"
.Filters.Add "bitmap", "*.bmp"
.Filters.Add "tiff", "*.tif"
.Filters.Add "GIF", "*.gif"
.Filters.Add "PNG", ".png"
.Filters.Add "All Files", "*.*"
.FilterIndex = 1
.AllowMultiSelect = False
.Title = Chr(199) & Chr(228) & Chr(202) & Chr(206) & Chr(199) & Chr(200) & Chr(32) & Chr(221) _
& Chr(199) & Chr(237) & Chr(225) & Chr(32) & Chr(202) & Chr(213) & Chr(230) & Chr(237) & Chr(209)
'================================================= ================================================
If .Show = -1 Then
strSourcePath = .SelectedItems(1)
'=========================================
lngLenSourcePath = Len(strSourcePath)
PathAsciiCode = ""
For B = 1 To lngLenSourcePath
PathAsciiCode = PathAsciiCode & "&Chrw(" & Asc(Mid(strSourcePath, B, 1)) & ")"
Next B
strSourcePath = Right(PathAsciiCode, Len(PathAsciiCode) - 1).Value
'================================================= ==============================================
SplitDir = Split(strSourcePath, "")
strSourceFileName = SplitDir(UBound(SplitDir()))
lngLenSourceFileName = Len(strSourceFileName)
SplitDir = Split(strSourcePath, ".")
strFileType = SplitDir(UBound(SplitDir()))
'=============================================
lngLenSourcePath = Len(strTargetPath)
PathAsciiCode = ""
For A = 1 To lngLenSourcePath
PathAsciiCode = PathAsciiCode & "&Chrw(" & Asc(Mid(strTargetPath, A, 1)) & ")"
Next A
strTargetPath = Right(PathAsciiCode, Len(PathAsciiCode) - 1).Value
'================================================= ==============================================
If FSO.FolderExists(strTargetPath) Then
lngTargetFilesCount1 = FSO.GetFolder(strTargetPath).Files.Count
End If
SplitDir = Split(CurrentProject.Path, "")
strTempPath = SplitDir(0) & "" & InsertDate & "(" & lngTargetFilesCount1 + 1 & ")." & strFileType
FSO.MoveFile Source:=strSourceFileName, Destination:=strTempPath
FSO.MoveFile Source:=strTempPath, Destination:=strTargetPath
'=============================================
If FSO.FolderExists(strTargetPath) Then
lngTargetFilesCount2 = FSO.GetFolder(strTargetPath).Files.Count
End If
'=============================================
If lngTargetFilesCount2 = lngTargetFilesCount1 + 1 Then
PictureFolderPath = strTargetPath
Me.CopyMoveTick = 1
Else
MsgBox (Chr(202) & Chr(213) & Chr(230) & Chr(237) & Chr(209) & Chr(32) & Chr(227) & Chr(228) & Chr(202) & Chr(222) & Chr(225) & Chr(32) _
& Chr(228) & Chr(212) & Chr(207) & vbNewLine & Chr(58) & Chr(227) & Chr(211) & Chr(237) & Chr(209) & Chr(32) & Chr(230) & Chr(32) & Chr(228) _
& Chr(199) & Chr(227) & Chr(32) & Chr(221) & Chr(199) & Chr(237) & Chr(225) & Chr(32) & Chr(199) & Chr(228) & Chr(202) & Chr(206) & Chr(199) _
& Chr(200) & Chr(237) & Chr(32) & vbNewLine & strTempPath)
End If
End If
End With



امیدوارم کسایی که با این مشکل روبرو هستند به کارشون بیاد