path.frm

OA编程 源代码

VERSION 5.00
Begin VB.Form frmPath 
   BackColor       =   &H00E0E0E0&
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "选择路径"
   ClientHeight    =   4605
   ClientLeft      =   150
   ClientTop       =   1530
   ClientWidth     =   5355
   ClipControls    =   0   'False
   Icon            =   "Path.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4605
   ScaleWidth      =   5355
   StartUpPosition =   2  'CenterScreen
   Begin VB.CommandButton NewFoled 
      Cancel          =   -1  'True
      Caption         =   "新建"
      Height          =   350
      Left            =   3960
      MaskColor       =   &H00000000&
      TabIndex        =   6
      Top             =   1920
      Width           =   1200
   End
   Begin VB.CommandButton cmdCancel 
      Caption         =   "取消"
      Height          =   350
      Left            =   3960
      MaskColor       =   &H00000000&
      TabIndex        =   5
      Top             =   1200
      Width           =   1200
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "确认"
      Default         =   -1  'True
      Height          =   350
      Left            =   3960
      MaskColor       =   &H00000000&
      TabIndex        =   4
      Top             =   600
      Width           =   1200
   End
   Begin VB.DriveListBox drvDrives 
      Height          =   300
      Left            =   240
      TabIndex        =   1
      Top             =   600
      Width           =   3510
   End
   Begin VB.DirListBox dirDirs 
      Height          =   3240
      Left            =   225
      TabIndex        =   2
      Top             =   1200
      Width           =   3540
   End
   Begin VB.Label lblDrives 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "驱动器："
      Height          =   180
      Left            =   240
      TabIndex        =   3
      Top             =   360
      Width           =   960
   End
   Begin VB.Label lblDirs 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "目录："
      Height          =   180
      Left            =   240
      TabIndex        =   0
      Top             =   960
      Width           =   540
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "C:\"
      ForeColor       =   &H00FF0000&
      Height          =   180
      Left            =   240
      TabIndex        =   7
      Top             =   120
      Width           =   270
   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)
    'frm.txtFilePath = AimPath
    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
    
    Label1.Caption = 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
    
    Label1.Caption = 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
        '换皮肤
    Call LoadSkin(Me)
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
        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
    Set fs = Nothing
    Set f = Nothing
    Set fc = Nothing
    Set f1 = Nothing
End Sub