vb 文件路径选择

 

BaseForm

'-----
'BaseForm
'-----

'画面初期化
Private Sub Form_Load()
    
    '磁盘路径
    Drive_Path = "D:"
    
    '文件夹路径
    Dir_Path = "D:"
    
    '新旧文件路径
    Old_filepath_txt.Text = ""
    New_filepath_txt.Text = ""
End Sub

Private Sub OLD_xls_cmd_1_Click()

    '原旧文件路径 取得
    Select_File_Path = Old_filepath_txt.Text

    File_Select_From.Show 1
    
    '旧文件路径 设定
    Old_filepath_txt.Text = Select_File_Path
    
End Sub

Private Sub NEW_xls_cmd_2_Click()

    '原新文件路径 取得
    Select_File_Path = New_filepath_txt.Text
    
    File_Select_From.Show 1
    
    '新文件路径 设定
    New_filepath_txt.Text = Select_File_Path

End Sub

'比较按钮
Private Sub Diffent_cmd_Click()
    
    '输入的文件路径 检查
    If FilePath_Check = False Then
        Exit Sub
    End If
    
    '新旧Excel 比较实施
    Call Excel_diff
    
    
    
    
    MsgBox ("OK")
    
End Sub

'输入的文件路径 检查
Private Function FilePath_Check() As Boolean
    
    FilePath_Check = True
    
    '旧文件是否Excel文件检查
    If Right(Trim(Old_filepath_txt.Text), 3) <> "xls" Then
        
        '警告提示
        MsgBox ("输入的旧文件并非EXCEL文件")
        
        '旧文件输入框 光标选中
        Old_filepath_txt.SetFocus
        
        FilePath_Check = False
        
        Exit Function
    End If
    
    '旧文件 是否存在检查
    If Dir(Old_filepath_txt.Text) = "" Then
        
        '警告提示
        MsgBox ("输入的旧文件不存在")
        
        '旧文件输入框 光标选中
        Old_filepath_txt.SetFocus
        
        FilePath_Check = False
        
        Exit Function
    End If
    
    '新文件是否Excel文件检查
    If Right(Trim(New_filepath_txt.Text), 3) <> "xls" Then
        
        '警告提示
        MsgBox ("输入的新文件并非EXCEL文件")
        
        '新文件输入框 光标选中
        New_filepath_txt.SetFocus
        
        FilePath_Check = False
        
        Exit Function
    End If
    
    '新文件 是否存在检查
    If Dir(New_filepath_txt.Text) = "" Then
        
        '警告提示
        MsgBox ("输入的新文件不存在")
        
        '新文件输入框 光标选中
        New_filepath_txt.SetFocus
        
        FilePath_Check = False
        
        Exit Function
    End If
    
    '新旧文件路径 是否相同检查
    If Trim(Old_filepath_txt.Text) = Trim(New_filepath_txt.Text) Then
    
        '警告提示
        MsgBox ("输入的新旧文件路径相同 为同一个文件")
        
        '旧文件输入框 光标选中
        Old_filepath_txt.SetFocus
        
        FilePath_Check = False
        
        Exit Function
    
    End If

End Function

'新旧Excel 比较实施
Private Sub Excel_diff()
    
    '创建EXCEL应用类
    Dim MyXls As Object
    Set MyXls = CreateObject("Excel.Application")
    
    '旧Excel文件
    Dim Old_WorkBook As Object
    Set Old_WorkBook = MyXls.Workbooks.Open(Trim(Old_filepath_txt.Text))
    
    '新Excel文件
    Dim New_WorkBook As Object
    Set New_WorkBook = MyXls.Workbooks.Open(Trim(New_filepath_txt.Text))
    
    '新旧Excel比较结果Excel文件
    Dim Result_WorkBook As Object
    Set Result_WorkBook = MyXls.Workbooks.Add
    
    Dim i As Integer
    Dim j As Integer
    
    '旧Excel文件Sheet循环
    For i = 1 To Old_WorkBook.sheets.Count
        
        '新Excel文件Sheet循环
        For j = 1 To New_WorkBook.sheets.Count
            
            '新旧excel文件中相同sheet名的sheet作对比
            If Old_WorkBook.sheets(i).Name = New_WorkBook.sheets(j).Name Then
                
                '复制旧文件中要做对比的sheet至 结果Excel 复制至最后位置sheet
                Old_WorkBook.sheets(i).Copy After:=Result_WorkBook.Worksheets(Result_WorkBook.sheets.Count)
                
                '
                '具体处理。。。
                '

            End If
            
        Next
        
    Next
    
    
    '新旧Excel文件关闭
    Old_WorkBook.Close (True)
    New_WorkBook.Close (True)
    
    '比较结果Excel文件多余sheet删除
    If Result_WorkBook.sheets.Count > 3 Then
        
        For i = Result_WorkBook.sheets.Count To 1 Step -1
            
            If Result_WorkBook.sheets(i).Name = "Sheet1" _
                Or Result_WorkBook.sheets(i).Name = "Sheet2" _
                Or Result_WorkBook.sheets(i).Name = "Sheet3" Then

                Result_WorkBook.sheets(i).Delete

            End If
            
        Next
    
    End If
    
    
    'EXCEL文件可见
    MyXls.Visible = True
    
End Sub

'旧文件路径输入框 光标进入
Private Sub Old_filepath_txt_GotFocus()

    Old_filepath_txt.SelStart = 0
    Old_filepath_txt.SelLength = Len(Old_filepath_txt.Text)
    
End Sub

'新文件路径输入框 光标进入
Private Sub New_filepath_txt_GotFocus()
    
    New_filepath_txt.SelStart = 0
    New_filepath_txt.SelLength = Len(New_filepath_txt.Text)
    
End Sub

 

File_Select_Form

'--------------------
'文件选择目录 联动设定
'--------------------

' 联动Flg
Private Init_Flg As String '初期化时 各列表框不联动(0:初期化,1：非初期化)


'画面初期化
Private Sub Form_Load()
    
    '初期化开始Flg
    Init_Flg = "0"
    
    '磁盘
    Drive1.Drive = Drive_Path
    
    '文件夹
    Dir1.Path = Dir_Path
    
    '文件
    File1.Path = Dir_Path
    
    '初期化结束Flg
    Init_Flg = "1"

End Sub

'磁盘列表 选择变更
Private Sub Drive1_Change()
    
    '非初期化时 变更的场合 联动实施
    If Init_Flg = "1" Then
    
        Drive_Path = Drive1.Drive
        
        '文件夹列表 联动
        Dir1.Path = Drive1.Drive
        
    End If

End Sub

'文件夹列表 选择变更
Private Sub Dir1_Change()

    '非初期化时 变更的场合 联动实施
    If Init_Flg = "1" Then
        
        Dir_Path = Dir1.Path
        
        '文件列表 联动
        File1.Path = Dir1.Path
    
    End If
    
End Sub

'文件列表 双击
Private Sub File1_DblClick()
    
    Call Return_File_Path
    
End Sub

'选择按钮 按下
Private Sub Select_cmd_Click()

    Call Return_File_Path
    
End Sub

'返回文件路径 并关闭窗口
Private Sub Return_File_Path()
    
    '取得的文件路径 设定
    Select_File_Path = Dir1.Path
    
    If Right(Dir1.Path, 1) <> "\" Then
        Select_File_Path = Select_File_Path & "\"
    End If
    
    Select_File_Path = Select_File_Path & File1.FileName
    
    '关闭窗口
    Unload Me
    
End Sub

Module1
 

'磁盘路径 全局变量
Global Drive_Path As String

'文件夹路径 全局变量
Global Dir_Path As String

'取得Excel文件路径
Global Select_File_Path As String