frmpath.frm

OA编程 源代码

VERSION 5.00
Begin VB.Form frmPath 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "选择路径"
   ClientHeight    =   4485
   ClientLeft      =   150
   ClientTop       =   1530
   ClientWidth     =   5355
   ClipControls    =   0   'False
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4485
   ScaleWidth      =   5355
   StartUpPosition =   2  '屏幕中心
   Begin VB.TextBox TxtCurPath 
      Height          =   735
      Left            =   30
      MultiLine       =   -1  'True
      TabIndex        =   8
      Top             =   270
      Width           =   5265
   End
   Begin VB.CommandButton NewFoled 
      Cancel          =   -1  'True
      Caption         =   "新建"
      Height          =   350
      Left            =   3810
      MaskColor       =   &H00000000&
      TabIndex        =   6
      Top             =   2730
      Width           =   1200
   End
   Begin VB.CommandButton cmdCancel 
      Caption         =   "取消"
      Height          =   350
      Left            =   3810
      MaskColor       =   &H00000000&
      TabIndex        =   5
      Top             =   2010
      Width           =   1200
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "确认"
      Default         =   -1  'True
      Height          =   350
      Left            =   3810
      MaskColor       =   &H00000000&
      TabIndex        =   4
      Top             =   1410
      Width           =   1200
   End
   Begin VB.DriveListBox drvDrives 
      Height          =   300
      Left            =   90
      TabIndex        =   1
      Top             =   1410
      Width           =   3510
   End
   Begin VB.DirListBox dirDirs 
      Height          =   2400
      Left            =   90
      TabIndex        =   2
      Top             =   2010
      Width           =   3510
   End
   Begin VB.Label Label2 
      Caption         =   "当前路径:"
      Height          =   225
      Left            =   30
      TabIndex        =   7
      Top             =   30
      Width           =   1185
   End
   Begin VB.Label lblDrives 
      AutoSize        =   -1  'True
      Caption         =   "驱动器："
      Height          =   180
      Left            =   90
      TabIndex        =   3
      Top             =   1170
      Width           =   960
   End
   Begin VB.Label lblDirs 
      AutoSize        =   -1  'True
      Caption         =   "目录："
      Height          =   180
      Left            =   90
      TabIndex        =   0
      Top             =   1770
      Width           =   540
   End
End
Attribute VB_Name = "frmPath"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim OldName As String

Private Sub CmdCancel_Click()
    AimPath = ""
    
    Unload Me
End Sub

Private Sub CmdOk_Click()
    AimPath = AddDirSep(dirDirs.Path)
    Unload Me
End Sub

Private Sub dirDirs_Change()
    Static intBusy As Integer

    On Error Resume Next

    If FirstFlag Then
        If intBusy = False Then
            intBusy = True

            ChDir dirDirs.Path

            If Err = 0 Then
                AimPath = dirDirs.Path
                drvDrives.Drive = Left$(dirDirs.Path, 2)
            Else
                Err = 0
            End If

            intBusy = False
        End If
    Else
        If intBusy = False Then
            intBusy = True

            ChDir dirDirs.Path

            If Err <> 0 Then
                Err = 0
            End If

            intBusy = False
        End If
    End If
    
    TxtCurPath.Text = AddDirSep(dirDirs.Path)
End Sub

Private Sub drvDrives_Change()
    On Error GoTo DirErr
        
    dirDirs.Path = drvDrives.Drive

    Exit Sub
DirErr:
    MsgBox Error$ & " ！", 64, "提示"
    
    drvDrives.Drive = OldName
End Sub

Private Sub drvDrives_GotFocus()
    OldName = drvDrives.Drive
End Sub

Private Sub Form_Activate()
    On Error Resume Next
    
    TxtCurPath.Text = AddDirSep(dirDirs.Path)
End Sub

Private Sub Form_Load()
    On Error Resume Next

    FirstFlag = False
    
    If AimPath <> "" Then
        dirDirs.Path = AimPath
        drvDrives = AimPath
    End If
    
    drvDrives.Refresh
    dirDirs.Refresh

    FirstFlag = True
End Sub

Private Sub NewFoled_Click()
    Dim FoldName As String
    Dim fs, f, f1, fc

Folderr:
    If FoldName <> "" Then
        MsgBox "名称不合法 ！ ", 64, "提示"
    End If

    FoldName = InputBox("文件夹名称", "提示", FoldName)
    FoldName = Trim(FoldName)
    If InStr(1, FoldName, "/") Then GoTo Folderr
    If InStr(1, FoldName, "\") Then GoTo Folderr
    If InStr(1, FoldName, ":") Then GoTo Folderr
    If InStr(1, FoldName, "*") Then GoTo Folderr
    If InStr(1, FoldName, "?") Then GoTo Folderr
    If InStr(1, FoldName, ">") Then GoTo Folderr
    If InStr(1, FoldName, "<") Then GoTo Folderr
    If InStr(1, FoldName, "|") Then GoTo Folderr
    If InStr(1, FoldName, "/") Then GoTo Folderr
    If Len(FoldName) > 50 Then GoTo Folderr

    If FoldName = "" Then Exit Sub
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(Me.dirDirs.Path)
    Set fc = f.SubFolders
    
    For Each f1 In fc
        Debug.Print f1.Name
        If StrComp(FoldName, f1.Name, vbTextCompare) = 0 Then
            MsgBox " 已经存在该目录", 64, "提示"
            Exit Sub
        End If
    Next
  
    If Right(dirDirs.Path, 1) = "\" Then
        fs.CreateFolder dirDirs.Path & FoldName
        dirDirs.Refresh
        dirDirs.Path = dirDirs.Path & FoldName
    Else
        fs.CreateFolder dirDirs.Path & "\" & FoldName
        dirDirs.Refresh
        dirDirs.Path = dirDirs.Path & "\" & FoldName
    End If
End Sub
Function AddDirSep(strPathName As String)
    If Right(Trim(strPathName), Len(gstrSEP_URLDIR)) <> gstrSEP_URLDIR And _
       Right(Trim(strPathName), Len(gstrSEP_DIR)) <> gstrSEP_DIR Then
        strPathName = RTrim$(strPathName) & gstrSEP_DIR
        AddDirSep = strPathName
    Else
        AddDirSep = strPathName
    End If
End Function