چجوری میشه توی یه درایو دونبال یه فولدر گشت ؟

سلام.
میخوام یه برنامه بنویسم که بره توی یه فولدری دنبال یه فولدر بگرده .
اگه پیدا کرد مقدار اول برگرده اگه نه مقدار دوم.
راستی رو سیستم من ویبی 2010 نصبه .
یه مشکلم اون داره :
برنامه هایی که با ویبی 2010 مینویسیم رو ایکس پی اجرا نمیشه .
واسه اون چه راهکاری دارین ؟
( من میخوام برنامم Stand Alone باشه و نبازی به نصب نباشه . )

خودم پیدا کردم.

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

نقل قول:

---

نوشته شده توسط MR Cracker [ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]

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

---

راست گفتی ها . ببخشید باید زودتر میزاشتم.

Function FileExists (strPath As String) As Integer
Dim lngRetVal As Long
On Error Resume Next
lngRetVal = Len(Dir$('Put Your Adress))
If Err Or lngRetVal = 0 Then
a = msgbox ("File Doesnt Exist")
Else
b = msgbox ("File Exist")
end if
End Function

کد:

---

Option Explicit
Dim strTFNContinedFolderName As String
Dim MoveFileReturnCode As Integer
Dim MoveFolderReturnCode As Integer
Dim TotalFolderNo As Double
Private Sub cmdExit_Click()
    Unload Me
End Sub
Private Sub CmdStartOperation_Click()
    On Error GoTo errHandler
    If Len(txtTFNContinedFolderPath) = 0 Then
        MsgBox "áØÝÇ ãÓíÑ ÑÇ æÇÑÏ äãÇííÏ"
        Exit Sub
    End If
   
    PPICWaitingMessage.Visible = True
    DoEvents
   
    strTFNContinedFolderName = txtTFNContinedFolderPath.Text
   
    Dim fs, Mainfolder, subfldr1, subfolder, subfldr2, filess, file1, FileNo, sumSize, subfolder2, subfolder3
    FileNo = 0
    sumSize = 0
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set Mainfolder = fs.Getfolder(strTFNContinedFolderName)
    Set subfolder = Mainfolder.SubFolders
    lstInvalidFoldersList.Clear
    For Each subfldr1 In subfolder
        TotalFolderNo = TotalFolderNo + 1
        lblTotalFoldersCount = TotalFolderNo
        DoEvents
        lblFolderName.Caption = subfldr1.Name
        DoEvents
        If Len(Trim(subfldr1.Name)) <> 12 Then
            lstInvalidFoldersList.AddItem Replace(Trim(subfldr1.Name), " ", "*") & "-" & Len(Trim(subfldr1.Name))
            FileNo = FileNo + 1
        End If
    Next
    PPICWaitingMessage.Visible = False
    lblCount.Caption = FileNo
    DoEvents
   
    MsgBox "ÇíÇä ÚãáíÇÊ" & vbCrLf & "ÊÚÏÇÏ ÝæáÏÑ ÈÇ Øæá ãÎÇáÝ 12 : " & FileNo
    Exit Sub
errHandler:
    Select Case Err.Number
        Case 76
          MsgBox "ãÓíÑ æÇÑÏ ÔÏå íÏÇ äÔÏ.áØÝÇ ãÓíÑ ÏÑÓÊ ÑÇ æÇÑÏ äãÇííÏ¡ãÔÎÕÇÊ ÎØÇ ÚÈÇÑÊäÏ ÇÒ : " & vbCrLf & " ÔãÇÑå ÎØÇ : " & Err.Number & vbCrLf & " ÔÑÍ ÎØÇ : " & Err.Description
        Case Else
          MsgBox "æÞæÚ ÎØÇ¡ãÔÎÕÇÊ ÎØÇ ÚÈÇÑÊäÏ ÇÒ : " & vbCrLf & " ÔãÇÑå ÎØÇ : " & Err.Number & vbCrLf & " ÔÑÍ ÎØÇ : " & Err.Description
          Resume Next
    End Select
    PPICWaitingMessage.Visible = False
    DoEvents
End Sub
'Private Sub MakeFolderIfIsNotExist1(strFolderFullPath As String)
'    Dim fso
'    Set fso = CreateObject("Scripting.FileSystemObject")
'    If fso.FolderExists(strFolderFullPath) = False Then
'        fso.CreateFolder (strFolderFullPath)
'    End If
'End Sub
Private Sub MoveFile1(strSource, strTarget)
  On Error GoTo ErrorHandler
    Dim fso, file1
    MoveFileReturnCode = 0
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set file1 = fso.GetFile(strSource)
    file1.Move (strTarget)
    Exit Sub
ErrorHandler:
    MoveFileReturnCode = -1
    MsgBox "æÞæÚ ÎØÇ ÏÑ åäÇã ÇäÊÞÇá ÝÇíá : " & strSource & vbCrLf & Err.Description
    Resume Next
End Sub
Private Sub MoveFolder(strSource, strTarget)
  On Error GoTo ErrorHandler
    Dim fso, folder1
    MoveFolderReturnCode = 0
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder1 = fso.Getfolder(strSource)
    folder1.Move (strTarget & "\")
    Exit Sub
ErrorHandler:
    MoveFolderReturnCode = -1
    MsgBox "æÞæÚ ÎØÇ ÏÑ åäÇã ÇäÊÞÇá folder : " & strSource & vbCrLf & Err.Description
    Resume Next
End Sub

Private Sub cmdMoveNestedFolders_Click()
    On Error GoTo errHandler
    If Len(txtTFNContinedFolderPath) = 0 Then
        MsgBox "áØÝÇ ãÓíÑ ÑÇ æÇÑÏ äãÇííÏ"
        Exit Sub
    End If
   
    PPICWaitingMessage.Visible = True
    DoEvents
   
    strTFNContinedFolderName = txtTFNContinedFolderPath.Text
   
    Dim fs, Mainfolder, subfldr1, subfolder, subfldr2, filess, file1, FileNo, sumSize, subfolder2, subfolder3
    FileNo = 0
    sumSize = 0
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set Mainfolder = fs.Getfolder(strTFNContinedFolderName)
    Set subfolder = Mainfolder.SubFolders
    lstInvalidMovedFolders.Clear
    lstValidMovedFolders.Clear
    For Each subfldr1 In subfolder
        Set subfolder2 = subfldr1.SubFolders
        For Each subfolder3 In subfolder2
            If Len(Trim(subfolder3.Name)) <> 12 Then
                lstInvalidMovedFolders.AddItem Replace(Trim(subfolder3.Name), " ", "*") & "-" & Len(Trim(subfolder3.Name))
                DoEvents
            Else
                lstValidMovedFolders.AddItem subfolder3.Name
                DoEvents
            End If
            Call MoveFolder(subfolder3, Mainfolder)
            FileNo = FileNo + 1
            TotalFolderNo = TotalFolderNo + 1
            lblTotalFoldersCount = TotalFolderNo
            DoEvents
        Next
    Next
    PPICWaitingMessage.Visible = False
    lblMovedCount.Caption = FileNo
    DoEvents
   
    MsgBox "ÇíÇä ÚãáíÇÊ" & vbCrLf & "ÊÚÏÇÏ ÝæáÏÑ ãäÊÞá ÔÏå : " & FileNo
    Exit Sub
errHandler:
    Select Case Err.Number
        Case 76
          MsgBox "ãÓíÑ æÇÑÏ ÔÏå íÏÇ äÔÏ.áØÝÇ ãÓíÑ ÏÑÓÊ ÑÇ æÇÑÏ äãÇííÏ¡ãÔÎÕÇÊ ÎØÇ ÚÈÇÑÊäÏ ÇÒ : " & vbCrLf & " ÔãÇÑå ÎØÇ : " & Err.Number & vbCrLf & " ÔÑÍ ÎØÇ : " & Err.Description
        Case Else
          MsgBox "æÞæÚ ÎØÇ¡ãÔÎÕÇÊ ÎØÇ ÚÈÇÑÊäÏ ÇÒ : " & vbCrLf & " ÔãÇÑå ÎØÇ : " & Err.Number & vbCrLf & " ÔÑÍ ÎØÇ : " & Err.Description
          Resume Next
    End Select
    PPICWaitingMessage.Visible = False
    DoEvents
End Sub
Private Sub Form_Load()
    TotalFolderNo = 0
End Sub

---

-----------------------------------------

اصلاح شد.
لطفا برای کدهای خود از تگ کد استفاده کنید.
Payman_62