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

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


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

سلام

مسیر زیر رو یه بررسی کنید
http://access-training.blog.ir/post/...8%AF%D8%B1-VBA

اگر براتون مقدوره بخشی از برنامه که مشکل داره رو قرار بدین تا بشه فهمید اشکال از کجاست

سلام ممنون
این هم فایل پیوست
ضمیمه 150351

نه file system object و نه folder dialog هیچکدوم مشکلی با اسامی فارسی یا چند تکه ندارن.
جای دیگه دنبال مشکل بگردین.

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

برنامه پیوست رو یک نگاه انداختم،
فقط باید بخشی رو که مشکل داره اون هم ساده شده قرار بدین

تنها راهش اینه که برنامه تون رو دیباگ کنین.

نقل قول:

---

نوشته شده توسط mazoolagh

برنامه پیوست رو یک نگاه انداختم،
فقط باید بخشی رو که مشکل داره اون هم ساده شده قرار بدین

تنها راهش اینه که برنامه تون رو دیباگ کنین.

---

سلام
من فقط توی همین قسمت مشکل دارم
منظورتون از ساده شده چیه؟
من 90 درصد برنامه اصلی رو حذف کردم

ساده شده یعنی فقط و فقط مشکل بدون هر ابجکت اضافی دیگه
اینجوری باید صبر کنین یک نفر بیکار پیدا بشه وقت آزاد داشته باشه

دیباگ کنین (trace) ، سریع مشکل پیدا میشه

سلام آقای پرکار
از یه طریق دیگه رفتم حل شد

Private Sub cmdInsertPicture_Click()
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
End Sub