VBA入门教程

' 声明变量
Dim num As Integer       ' 整数
Dim name As String      ' 字符串
Dim price As Double     ' 双精度浮点数
Dim isReady As Boolean  ' 布尔值
Dim dateValue As Date   ' 日期

' 变体类型（万能类型）
Dim var As Variant
var = "Hello"
var = 123
var = #2023-10-01#

' 数组声明
Dim arr(1 To 5) As Integer  ' 固定大小数组
Dim dynamicArr() As String  ' 动态数组
ReDim dynamicArr(1 To 3)    ' 调整动态数组大小

' 算术运算
result = 10 + 5 * 2       ' 结果：20
result = (10 + 5) * 2     ' 结果：30
result = 10 / 3           ' 结果：3.333...
result = 10 \ 3           ' 整除：3
result = 10 Mod 3         ' 取余：1

' 比较运算
If 5 > 3 Then MsgBox "True"
If "A" = "a" Then MsgBox "Equal" ' 区分大小写，输出False

' 逻辑运算
If (5 > 3) And (2 < 4) Then MsgBox "Both True"
If (5 > 3) Or (2 > 4) Then MsgBox "At least one True"

' If...Then...Else
If score >= 90 Then
    MsgBox "优秀"
ElseIf score >= 80 Then
    MsgBox "良好"
Else
    MsgBox "不及格"
End If

' Select Case
Select Case dayOfWeek
    Case 1: MsgBox "星期日"
    Case 2: MsgBox "星期一"
    ' 其他情况...
    Case Else: MsgBox "无效"
End Select

' For...Next循环
For i = 1 To 10
    Cells(i, 1).Value = i  ' 向A列写入1-10
Next i

' For Each...Next遍历对象
For Each cell In Range("A1:A10")
    If cell.Value > 5 Then cell.Interior.Color = RGB(255, 0, 0)
Next cell

' Do...Loop循环
Do While i <= 10
    i = i + 1
Loop

' 读取单元格值
value = Range("A1").Value
value = Cells(1, 1).Value ' 行号1，列号1

' 写入单元格值
Range("B1").Value = "Hello"
Cells(2, 2).Value = 100

' 选择范围
Range("A1:C10").Select
Range("A1").Resize(5, 3).Select ' 选择A1到C5

' 添加新工作表
Sheets.Add.Name = "数据汇总"

' 删除工作表
Application.DisplayAlerts = False ' 关闭提示
Sheets("Sheet1").Delete
Application.DisplayAlerts = True

' 保存工作簿
ActiveWorkbook.Save
ActiveWorkbook.SaveAs "C:\路径\文件名.xlsx"

Sub RemoveDuplicates()
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row ' 获取A列最后一行
    
    Range("A1:A" & lastRow).RemoveDuplicates Columns:=1, Header:=xlYes
    MsgBox "重复值已删除！"
End Sub

Sub AddPrefix()
    Dim cell As Range
    For Each cell In Range("A1:A100")
        If cell.Value <> "" Then
            cell.Value = "ID-" & cell.Value
        End If
    Next cell
End Sub

Sub CreatePivotTable()
    Dim wsData As Worksheet
    Dim wsPivot As Worksheet
    Dim lastRow As Long
    
    Set wsData = ThisWorkbook.Sheets("数据源")
    Set wsPivot = ThisWorkbook.Sheets.Add
    
    lastRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row
    
    ' 创建数据透视表
    wsData.Range("A1:C" & lastRow).PivotTable _
        TableDestination:=wsPivot.Range("A1"), _
        TableName:="销售数据透视表"
    
    ' 添加字段
    With wsPivot.PivotTables("销售数据透视表")
        .AddDataField .PivotFields("销售额"), "汇总销售额", xlSum
        .PivotFields("产品名称").Orientation = xlRowField
    End With
End Sub

Sub SendEmailWithAttachment()
    Dim olApp As Object
    Dim olMail As Object
    
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0) ' 0代表邮件
    
    With olMail
        .To = "recipient@example.com"
        .CC = "cc@example.com"
        .Subject = "月度报告"
        .Body = "附件为最新月度报告，请查收。"
        .Attachments.Add ThisWorkbook.FullName ' 添加当前工作簿作为附件
        .Send ' 发送邮件（或使用.Display显示）
    End With
    
    Set olMail = Nothing
    Set olApp = Nothing
End Sub

Sub ErrorHandlingDemo()
    On Error GoTo ErrorHandler
    
    Dim filePath As String
    filePath = "C:\不存在的文件.txt"
    Open filePath For Input As #1
    
    Exit Sub
    
ErrorHandler:
    MsgBox "错误：" & Err.Number & " - " & Err.Description
    Resume Next ' 继续执行后续代码
End Sub

' 计算BMI指数
Function CalculateBMI(weight As Double, height As Double) As Double
    CalculateBMI = weight / (height ^ 2)
End Function

' 在Excel单元格中使用：=CalculateBMI(B1, C1)

' 当单元格内容变化时触发
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A1")) Is Nothing Then
        MsgBox "A1单元格内容已更新！"
    End If
End Sub

Sub CreateBasicChart()
    Dim ws As Worksheet
    Dim chartObj As ChartObject
    Dim dataRange As Range
    
    ' 设置工作表
    Set ws = ThisWorkbook.Sheets("数据")
    
    ' 定义数据范围
    Set dataRange = ws.Range("A1:C10") ' 假设A列为类别，B、C列为数据
    
    ' 创建图表
    Set chartObj = ws.ChartObjects.Add( _
        Left:=100, Top:=50, Width:=500, Height:=300)
    
    ' 设置图表数据和类型
    With chartObj.Chart
        .SetSourceData Source:=dataRange
        .ChartType = xlColumnClustered ' 柱状图
        .HasTitle = True
        .ChartTitle.Text = "销售数据对比"
    End With
    
    MsgBox "图表创建完成！"
End Sub

Sub CreateVariousCharts()
    Dim ws As Worksheet
    Dim lastRow As Long
    Set ws = ThisWorkbook.ActiveSheet
    
    ' 获取数据最后一行
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 创建折线图
    ws.ChartObjects.Add(Left:=10, Top:=10, Width:=300, Height:=200).Chart _
        .SetSourceData Source:=ws.Range("A1:B" & lastRow)
    ws.ChartObjects(1).Chart.ChartType = xlLine
    
    ' 创建饼图
    ws.ChartObjects.Add(Left:=320, Top:=10, Width:=300, Height:=200).Chart _
        .SetSourceData Source:=ws.Range("A1:C" & lastRow)
    ws.ChartObjects(2).Chart.ChartType = xlPie
    
    ' 创建散点图
    ws.ChartObjects.Add(Left:=10, Top:=220, Width:=300, Height:=200).Chart _
        .SetSourceData Source:=ws.Range("A1:D" & lastRow)
    ws.ChartObjects(3).Chart.ChartType = xlXYScatter
End Sub

Sub FormatChart()
    Dim cht As Chart
    Set cht = ThisWorkbook.Sheets("数据").ChartObjects(1).Chart
    
    ' 设置图表标题
    With cht.ChartTitle
        .Text = "2023年月度销售趋势"
        .Font.Size = 14
        .Font.Bold = True
    End With
    
    ' 设置坐标轴
    With cht.Axes(xlCategory) ' X轴
        .HasTitle = True
        .AxisTitle.Text = "月份"
        .AxisTitle.Font.Italic = True
    End With
    
    With cht.Axes(xlValue) ' Y轴
        .HasTitle = True
        .AxisTitle.Text = "销售额(元)"
        .MinimumScale = 0 ' 设置最小值为0
    End With
    
    ' 设置图例
    With cht.Legend
        .Position = xlBottom ' 图例在底部
        .Font.Size = 10
    End With
    
    ' 设置数据系列格式
    With cht.SeriesCollection(1)
        .Name = "实际销售额"
        .Format.Fill.ForeColor.RGB = RGB(50, 120, 200) ' 蓝色
        .MarkerStyle = xlMarkerStyleCircle ' 数据点样式
    End With
End Sub

Sub BasicAutoFilter()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("客户数据")
    
    ' 确保筛选被关闭
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    ' 应用筛选
    ws.Range("A1:D1").AutoFilter ' A1:D1为标题行
    
    ' 筛选出"华东地区"的客户
    ws.Range("A1:D1").AutoFilter Field:=3, Criteria1:="华东地区" ' 第3列是地区
    
    ' 筛选出销售额大于10000的记录
    ' ws.Range("A1:D1").AutoFilter Field:=4, Criteria1:=">10000"
End Sub

Sub AdvancedFilter()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("销售数据")
    
    ' 关闭现有筛选
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    ' 多条件筛选：地区为"华南"且销售额>5000
    With ws.Range("A1:D1000")
        .AutoFilter
        .AutoFilter Field:=3, Criteria1:="华南" ' 第3列：地区
        .AutoFilter Field:=4, Criteria1:=">5000" ' 第4列：销售额
    End With
    
    ' 统计筛选结果数量
    Dim visibleCount As Long
    visibleCount = ws.Range("A2:A1000").SpecialCells(xlCellTypeVisible).Count
    
    MsgBox "符合条件的记录有 " & visibleCount & " 条"
End Sub

Sub AdvancedFilterWithCriteria()
    Dim wsData As Worksheet
    Dim wsCriteria As Worksheet
    Dim wsResult As Worksheet
    
    ' 设置工作表
    Set wsData = ThisWorkbook.Sheets("数据")
    Set wsCriteria = ThisWorkbook.Sheets("条件")
    Set wsResult = ThisWorkbook.Sheets("结果")
    
    ' 清除之前的结果
    wsResult.Range("A2:D1000").ClearContents
    
    ' 应用高级筛选
    wsData.Range("A1:D1000").AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=wsCriteria.Range("A1:D2"), _
        CopyToRange:=wsResult.Range("A1:D1"), _
        Unique:=False
        
    MsgBox "高级筛选完成，结果已复制到结果表"
End Sub

Sub RemoveFilter()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet
    
    ' 检查是否有筛选
    If ws.AutoFilterMode Then
        ' 关闭筛选
        ws.AutoFilterMode = False
        MsgBox "筛选已取消"
    Else
        MsgBox "当前没有应用筛选"
    End If
    
    ' 选中数据区域第一行
    ws.Range("A1").Select
End Sub

Sub WithStatementBasic()
    ' 不使用With语句
    Range("A1").Value = "姓名"
    Range("A1").Font.Bold = True
    Range("A1").Font.Size = 12
    Range("A1").Interior.Color = RGB(200, 200, 200)
    Range("A1").HorizontalAlignment = xlCenter
    
    ' 使用With语句，更简洁高效
    With Range("B1")
        .Value = "年龄"
        .Font.Bold = True
        .Font.Size = 12
        .Interior.Color = RGB(200, 200, 200)
        .HorizontalAlignment = xlCenter
    End With
End Sub

Sub WithStatementForObjects()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets.Add
    ws.Name = "With示例"
    
    ' 使用With配置工作表
    With ws
        ' 设置标题
        With .Range("A1:C1")
            .Value = Array("ID", "名称", "数量")
            .Font.Bold = True
            .Interior.Color = RGB(180, 200, 255)
            .EntireColumn.AutoFit
        End With
        
        ' 填充示例数据
        .Range("A2").Value = 1
        .Range("B2").Value = "产品A"
        .Range("C2").Value = 100
        
        .Range("A3").Value = 2
        .Range("B3").Value = "产品B"
        .Range("C3").Value = 200
        
        ' 添加边框
        .Range("A1:C3").Borders.LineStyle = xlContinuous
    End With
    
    MsgBox "工作表创建完成"
End Sub

Sub NestedWithStatements()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet
    
    ' 嵌套With语句示例
    With ws.ChartObjects.Add(Left:=100, Top:=50, Width:=500, Height:=300).Chart
        .ChartType = xlColumnClustered
        .SetSourceData Source:=ws.Range("A1:C6")
        
        ' 嵌套With设置标题
        With .ChartTitle
            .Text = "季度销售报表"
            .Font.Size = 16
            .Font.Bold = True
        End With
        
        ' 嵌套With设置X轴
        With .Axes(xlCategory)
            .HasTitle = True
            .AxisTitle.Text = "季度"
        End With
        
        ' 嵌套With设置Y轴
        With .Axes(xlValue)
            .HasTitle = True
            .AxisTitle.Text = "销售额"
            .MinimumScale = 0
        End With
    End With
End Sub

' 以下代码需要在UserForm的代码窗口中编写

' UserForm初始化事件
Private Sub UserForm_Initialize()
    ' 初始化下拉列表
    Me.cboDepartment.List = Array("销售部", "市场部", "技术部", "行政部")
    
    ' 设置默认日期为今天
    Me.txtDate.Value = Date
    
    ' 设置标题
    Me.Caption = "员工信息录入"
End Sub

' 确定按钮点击事件
Private Sub cmdOK_Click()
    Dim ws As Worksheet
    Dim lastRow As Long
    
    ' 数据验证
    If Me.txtName.Value = "" Then
        MsgBox "请输入姓名", vbExclamation
        Me.txtName.SetFocus
        Exit Sub
    End If
    
    If Me.cboDepartment.Value = "" Then
        MsgBox "请选择部门", vbExclamation
        Me.cboDepartment.SetFocus
        Exit Sub
    End If
    
    ' 写入数据
    Set ws = ThisWorkbook.Sheets("员工信息")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
    
    ws.Cells(lastRow, "A").Value = Me.txtID.Value
    ws.Cells(lastRow, "B").Value = Me.txtName.Value
    ws.Cells(lastRow, "C").Value = Me.cboDepartment.Value
    ws.Cells(lastRow, "D").Value = Me.txtDate.Value
    ws.Cells(lastRow, "E").Value = Me.txtSalary.Value
    
    ' 提示成功
    MsgBox "数据已成功保存！", vbInformation
    
    ' 清空表单
    Me.txtID.Value = ""
    Me.txtName.Value = ""
    Me.txtSalary.Value = ""
    Me.txtID.SetFocus
End Sub

' 取消按钮点击事件
Private Sub cmdCancel_Click()
    ' 关闭表单
    Unload Me
End Sub

' 标准模块中的代码，用于显示用户窗体
Sub ShowEmployeeForm()
    ' 显示用户窗体
    EmployeeForm.Show ' EmployeeForm是你的UserForm名称
End Sub

Sub ControlPropertiesDemo()
    ' 以下是常用控件及其重要属性的说明
    
    ' TextBox（文本框）
    ' .Value: 文本框中的内容
    ' .Text: 当前显示的文本
    ' .Enabled: 是否可用
    ' .Visible: 是否可见
    ' 示例:
    ' Me.txtName.Value = "张三"
    
    ' ComboBox（组合框）
    ' .List: 下拉列表内容
    ' .Value: 当前选中的值
    ' .Style: 样式（0=下拉组合框，2=下拉列表）
    ' 示例:
    ' Me.cboStatus.List = Array("在职", "离职", "休假")
    
    ' CheckBox（复选框）
    ' .Value: 选中状态（True/False）
    ' .Caption: 显示文本
    ' 示例:
    ' If Me.chkAgree.Value = True Then ...
    
    ' OptionButton（选项按钮）
    ' .Value: 是否选中（True/False）
    ' .GroupName: 分组名称（同组中只能选一个）
    ' 示例:
    ' If Me.optMale.Value = True Then ...
    
    ' CommandButton（命令按钮）
    ' .Caption: 按钮文本
    ' .OnClick: 点击事件
    ' 示例:
    ' Me.cmdSubmit.Caption = "提交"
    
    ' Label（标签）
    ' .Caption: 显示文本
    ' .Font: 字体设置
    ' 示例:
    ' Me.lblTitle.Caption = "用户信息"
End Sub

' UserForm代码
Private Sub cmdSearch_Click()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim searchTerm As String
    
    Set ws = ThisWorkbook.Sheets("产品数据")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    searchTerm = Me.txtSearch.Value
    
    ' 清除之前的结果
    Me.lstResults.Clear
    
    ' 搜索数据
    For i = 2 To lastRow
        ' 检查是否匹配（名称或编号）
        If InStr(1, ws.Cells(i, 1).Value, searchTerm, vbTextCompare) > 0 Or _
           InStr(1, ws.Cells(i, 2).Value, searchTerm, vbTextCompare) > 0 Then
           
            ' 添加到列表框
            Me.lstResults.AddItem
            Me.lstResults.List(Me.lstResults.ListCount - 1, 0) = ws.Cells(i, 1).Value ' 产品编号
            Me.lstResults.List(Me.lstResults.ListCount - 1, 1) = ws.Cells(i, 2).Value ' 产品名称
            Me.lstResults.List(Me.lstResults.ListCount - 1, 2) = ws.Cells(i, 3).Value ' 价格
        End If
    Next i
    
    ' 显示结果数量
    Me.lblCount.Caption = "找到 " & Me.lstResults.ListCount & " 个结果"
End Sub

Private Sub lstResults_Click()
    ' 双击列表项时显示详细信息
    If Me.lstResults.ListIndex >= 0 Then
        MsgBox "产品编号: " & Me.lstResults.List(Me.lstResults.ListIndex, 0) & vbCrLf & _
               "产品名称: " & Me.lstResults.List(Me.lstResults.ListIndex, 1) & vbCrLf & _
               "价格: " & Me.lstResults.List(Me.lstResults.ListIndex, 2), _
               vbInformation, "产品详情"
    End If
End Sub

Private Sub cmdClose_Click()
    Unload Me
End Sub

' 模块1：主程序
Sub SalesDataSystem()
    ' 显示系统菜单
    Dim choice As Integer
    choice = MsgBox("1. 数据录入" & vbCrLf & _
                   "2. 数据筛选" & vbCrLf & _
                   "3. 生成报表" & vbCrLf & _
                   "4. 图表分析" & vbCrLf & _
                   "5. 退出", _
                   vbYesNoCancel + vbQuestion, "销售数据处理系统")
    
    Select Case choice
        Case vbYes: DataEntryForm.Show ' 数据录入
        Case vbNo: RunFilter ' 数据筛选
        Case vbCancel: GenerateReport ' 生成报表
        ' 其他选项可以在这里添加
    End Select
End Sub

' 模块2：数据处理
Sub RunFilter()
    Dim ws As Worksheet
    Dim filterMonth As String
    
    Set ws = ThisWorkbook.Sheets("销售记录")
    
    ' 关闭现有筛选
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    ' 获取筛选条件
    filterMonth = InputBox("请输入要筛选的月份(1-12):", "筛选条件")
    If filterMonth = "" Then Exit Sub
    
    ' 应用筛选
    With ws.Range("A1:E1")
        .AutoFilter
        .AutoFilter Field:=2, Criteria1:="*" & filterMonth & "月*" ' 第2列是日期
        
        ' 检查是否有符合条件的数据
        On Error Resume Next
        Dim filteredCount As Long
        filteredCount = ws.Range("A2:A1000").SpecialCells(xlCellTypeVisible).Count
        On Error GoTo 0
        
        If filteredCount = 0 Then
            MsgBox "没有找到符合条件的数据", vbInformation
            ws.AutoFilterMode = False
        Else
            MsgBox "已筛选出 " & filteredCount & " 条记录", vbInformation
        End If
    End With
End Sub

' 模块3：报表生成
Sub GenerateReport()
    Dim wsData As Worksheet
    Dim wsReport As Worksheet
    Dim lastRow As Long
    
    Set wsData = ThisWorkbook.Sheets("销售记录")
    Set wsReport = ThisWorkbook.Sheets.Add
    wsReport.Name = "销售报表_" & Format(Date, "yyyymmdd")
    
    ' 复制标题
    wsData.Range("A1:E1").Copy wsReport.Range("A1")
    
    ' 复制筛选后的数据
    wsData.Range("A1:E1000").SpecialCells(xlCellTypeVisible).Copy _
        wsReport.Range("A1")
    
    ' 格式化报表
    With wsReport
        ' 调整列宽
        .Columns("A:E").AutoFit
        
        ' 设置标题格式
        With .Range("A1:E1")
            .Font.Bold = True
            .Interior.Color = RGB(200, 220, 255)
        End With
        
        ' 添加总计行
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
        .Cells(lastRow, "A").Value = "总计"
        .Cells(lastRow, "E").Formula = "=SUM(E2:E" & lastRow - 1 & ")"
        .Cells(lastRow, "E").Font.Bold = True
        
        ' 创建图表
        With .ChartObjects.Add(Left:=300, Top:=50, Width:=400, Height:=250).Chart
            .ChartType = xlColumnClustered
            .SetSourceData Source:=.Parent.Parent.Range("B2:E" & lastRow - 1)
            .HasTitle = True
            .ChartTitle.Text = "销售数据汇总"
        End With
    End With
    
    MsgBox "报表已生成：" & wsReport.Name, vbInformation
End Sub

Sub ReadTextFile()
    Dim filePath As String
    Dim fileNumber As Integer
    Dim lineContent As String
    Dim rowNum As Integer
    
    ' 获取文件路径
    filePath = "C:\data\example.txt"
    
    ' 检查文件是否存在
    If Dir(filePath) = "" Then
        MsgBox "文件不存在: " & filePath, vbExclamation
        Exit Sub
    End If
    
    ' 获取可用文件号
    fileNumber = FreeFile
    
    ' 打开文件用于读取
    Open filePath For Input As #fileNumber
    
    ' 初始化行号
    rowNum = 1
    
    ' 读取文件内容并输出到工作表
    Worksheets("数据").Range("A:A").ClearContents ' 清空A列
    
    Do While Not EOF(fileNumber)
        ' 读取一行内容
        Line Input #fileNumber, lineContent
        
        ' 写入到工作表
        Worksheets("数据").Cells(rowNum, 1).Value = lineContent
        
        rowNum = rowNum + 1
    Loop
    
    ' 关闭文件
    Close #fileNumber
    
    MsgBox "文件读取完成，共 " & rowNum - 1 & " 行", vbInformation
End Sub

Sub WriteToTextFile()
    Dim filePath As String
    Dim fileNumber As Integer
    Dim i As Integer
    
    ' 设置文件路径
    filePath = "C:\data\output.txt"
    
    ' 获取可用文件号
    fileNumber = FreeFile
    
    ' 打开文件用于写入（会覆盖已有文件）
    Open filePath For Output As #fileNumber
    
    ' 写入内容
    Print #fileNumber, "这是一个示例文件"
    Print #fileNumber, "生成时间: " & Now()
    Print #fileNumber, "-------------------------"
    
    ' 写入一些数据
    For i = 1 To 5
        Print #fileNumber, "数据行 " & i & ": " & i * 100
    Next i
    
    ' 关闭文件
    Close #fileNumber
    
    MsgBox "文件写入完成: " & filePath, vbInformation
End Sub

Sub AppendToFile()
    Dim filePath As String
    Dim fileNumber As Integer
    Dim newData As String
    
    ' 设置文件路径
    filePath = "C:\data\log.txt"
    
    ' 获取要追加的数据
    newData = InputBox("请输入要追加的日志内容:", "追加日志")
    If newData = "" Then Exit Sub ' 用户取消
    
    ' 获取可用文件号
    fileNumber = FreeFile
    
    ' 打开文件用于追加
    Open filePath For Append As #fileNumber
    
    ' 写入带时间戳的内容
    Print #fileNumber, "[" & Format(Now(), "yyyy-mm-dd hh:nn:ss") & "] " & newData
    
    ' 关闭文件
    Close #fileNumber
    
    MsgBox "内容已追加到文件", vbInformation
End Sub

Sub ReadEntireFile()
    Dim filePath As String
    Dim fileNumber As Integer
    Dim fileContent As String
    
    ' 设置文件路径
    filePath = "C:\data\notes.txt"
    
    ' 检查文件是否存在
    If Dir(filePath) = "" Then
        MsgBox "文件不存在", vbExclamation
        Exit Sub
    End If
    
    ' 获取可用文件号
    fileNumber = FreeFile
    
    ' 打开文件
    Open filePath For Input As #fileNumber
    
    ' 读取整个文件内容
    fileContent = Input(LOF(fileNumber), fileNumber)
    
    ' 关闭文件
    Close #fileNumber
    
    ' 显示文件内容（长内容会自动截断）
    MsgBox "文件内容: " & vbCrLf & fileContent, vbInformation, "文件内容"
    
    ' 也可以将内容写入单元格
    Worksheets("数据").Range("A1").Value = fileContent
End Sub

Sub ProcessMultipleFiles()
    Dim folderPath As String
    Dim fileName As String
    Dim fileNumber As Integer
    Dim content As String
    Dim resultRow As Integer
    
    ' 设置文件夹路径
    folderPath = "C:\data\reports\"
    resultRow = 1
    
    ' 清空结果区域
    Worksheets("汇总").Range("A:B").ClearContents
    Worksheets("汇总").Cells(1, 1).Value = "文件名"
    Worksheets("汇总").Cells(1, 2).Value = "第一行内容"
    Worksheets("汇总").Rows(1).Font.Bold = True
    
    ' 获取第一个文本文件
    fileName = Dir(folderPath & "*.txt")
    
    ' 循环处理所有文本文件
    Do While fileName <> ""
        resultRow = resultRow + 1
        Worksheets("汇总").Cells(resultRow, 1).Value = fileName
        
        ' 读取文件第一行
        fileNumber = FreeFile
        Open folderPath & fileName For Input As #fileNumber
        Line Input #fileNumber, content
        Close #fileNumber
        
        ' 写入结果
        Worksheets("汇总").Cells(resultRow, 2).Value = content
        
        ' 获取下一个文件
        fileName = Dir()
    Loop
    
    ' 调整列宽
    Worksheets("汇总").Columns("A:B").AutoFit
    
    MsgBox "处理完成，共 " & resultRow - 1 & " 个文件", vbInformation
End Sub

Sub FileOperationWithErrorHandling()
    Dim filePath As String
    Dim fileNumber As Integer
    
    filePath = "C:\data\sensitive.txt"
    
    On Error GoTo ErrorHandler
    
    fileNumber = FreeFile
    Open filePath For Input As #fileNumber
    
    ' 这里添加文件处理代码
    MsgBox "文件打开成功，可以进行读写操作", vbInformation
    
    Close #fileNumber
    Exit Sub
    
ErrorHandler:
    ' 处理不同类型的错误
    Select Case Err.Number
        Case 53 ' 文件未找到
            MsgBox "错误: 找不到文件 " & filePath, vbCritical
        Case 70 ' 权限被拒绝
            MsgBox "错误: 没有权限访问文件 " & filePath, vbCritical
        Case Else
            MsgBox "发生错误 " & Err.Number & ": " & Err.Description, vbCritical
    End Select
    
    ' 确保文件被关闭
    On Error Resume Next
    Close #fileNumber
End Sub

Sub BasicFileDialog()
    Dim fd As FileDialog
    Dim selectedFile As String
    
    ' 创建文件对话框实例（打开文件类型）
    Set fd = Application.FileDialog(msoFileDialogOpen)
    
    ' 设置对话框标题
    fd.Title = "请选择要打开的文本文件"
    
    ' 设置允许选择的文件类型
    fd.Filters.Clear ' 清除默认筛选器
    fd.Filters.Add "文本文件", "*.txt" ' 添加文本文件筛选
    fd.Filters.Add "Excel文件", "*.xlsx;*.xls" ' 添加Excel文件筛选
    fd.Filters.Add "所有文件", "*.*" ' 添加所有文件筛选
    
    ' 允许选择多个文件（默认是False）
    fd.AllowMultiSelect = False
    
    ' 显示对话框，如果用户点击了"确定"按钮
    If fd.Show = -1 Then
        ' 获取选中的文件路径
        selectedFile = fd.SelectedItems(1)
        
        ' 显示选中的文件
        MsgBox "您选择的文件是: " & vbCrLf & selectedFile, vbInformation
    Else
        ' 用户取消了操作
        MsgBox "您取消了文件选择", vbInformation
    End If
    
    ' 释放对象
    Set fd = Nothing
End Sub

Sub SelectSingleFile()
    Dim fd As FileDialog
    Dim filePath As String
    Dim ws As Worksheet
    
    ' 创建文件选择对话框
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    With fd
        .Title = "选择要导入的数据文件"
        .Filters.Clear
        .Filters.Add "CSV文件", "*.csv"
        .Filters.Add "文本文件", "*.txt"
        .AllowMultiSelect = False ' 只允许选择一个文件
        
        ' 显示对话框
        If .Show = -1 Then
            filePath = .SelectedItems(1)
            
            ' 这里可以添加处理文件的代码
            Set ws = ThisWorkbook.Sheets.Add
            ws.Name = "导入数据"
            
            MsgBox "已选择文件: " & filePath & vbCrLf & _
                   "数据将导入到 """ & ws.Name & """ 工作表", vbInformation
            
            ' 调用文件读取函数（使用之前学过的文件读取方法）
            ReadDataToWorksheet filePath, ws
        End If
    End With
    
    Set fd = Nothing
End Sub

' 辅助函数：将文件内容读取到工作表
Sub ReadDataToWorksheet(filePath As String, ws As Worksheet)
    Dim fileNum As Integer
    Dim lineContent As String
    Dim rowNum As Long
    
    rowNum = 1
    fileNum = FreeFile
    
    Open filePath For Input As #fileNum
        Do While Not EOF(fileNum)
            Line Input #fileNum, lineContent
            ws.Cells(rowNum, 1).Value = lineContent
            rowNum = rowNum + 1
        Loop
    Close #fileNum
    
    ws.Columns("A:A").AutoFit
    MsgBox "数据导入完成，共 " & rowNum - 1 & " 行", vbInformation
End Sub

Sub SelectMultipleFiles()
    Dim fd As FileDialog
    Dim i As Integer
    Dim ws As Worksheet
    
    ' 创建文件选择对话框
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    With fd
        .Title = "选择多个要处理的文件"
        .Filters.Clear
        .Filters.Add "文本文件", "*.txt"
        .AllowMultiSelect = True ' 允许选择多个文件
        
        ' 显示对话框
        If .Show = -1 Then
            ' 创建结果工作表
            Set ws = ThisWorkbook.Sheets.Add
            ws.Name = "多文件处理结果"
            ws.Cells(1, 1).Value = "文件名"
            ws.Cells(1, 2).Value = "路径"
            ws.Cells(1, 3).Value = "行数"
            ws.Rows(1).Font.Bold = True
            
            ' 处理每个选中的文件
            For i = 1 To .SelectedItems.Count
                ProcessFile .SelectedItems(i), ws, i + 1
            Next i
            
            ws.Columns("A:C").AutoFit
            MsgBox "已处理 " & .SelectedItems.Count & " 个文件", vbInformation
        End If
    End With
    
    Set fd = Nothing
End Sub

' 辅助函数：处理单个文件并记录信息
Sub ProcessFile(filePath As String, ws As Worksheet, rowNum As Long)
    Dim fileNum As Integer
    Dim lineCount As Long
    Dim dummy As String
    
    ' 获取文件名（不包含路径）
    Dim fileName As String
    fileName = Mid(filePath, InStrRev(filePath, "\") + 1)
    
    ' 计算文件行数
    lineCount = 0
    fileNum = FreeFile
    Open filePath For Input As #fileNum
        Do While Not EOF(fileNum)
            Line Input #fileNum, dummy
            lineCount = lineCount + 1
        Loop
    Close #fileNum
    
    ' 记录信息到工作表
    ws.Cells(rowNum, 1).Value = fileName
    ws.Cells(rowNum, 2).Value = filePath
    ws.Cells(rowNum, 3).Value = lineCount
End Sub

Sub SaveFileDialogDemo()
    Dim fd As FileDialog
    Dim savePath As String
    Dim fileNum As Integer
    Dim i As Integer
    
    ' 创建保存文件对话框
    Set fd = Application.FileDialog(msoFileDialogSaveAs)
    
    With fd
        .Title = "保存导出数据"
        .InitialFileName = "导出数据_" & Format(Date, "yyyymmdd") & ".txt" ' 默认文件名
        .InitialView = msoFileDialogViewDetails ' 详细视图
        
        ' 显示对话框
        If .Show = -1 Then
            savePath = .SelectedItems(1)
            
            ' 检查文件是否已存在
            If Dir(savePath) <> "" Then
                If MsgBox("文件已存在，是否覆盖?", vbYesNo + vbQuestion) = vbNo Then
                    MsgBox "保存操作已取消", vbInformation
                    Exit Sub
                End If
            End If
            
            ' 写入示例数据
            fileNum = FreeFile
            Open savePath For Output As #fileNum
                Print #fileNum, "数据导出时间: " & Now()
                Print #fileNum, "===================="
                For i = 1 To 10
                    Print #fileNum, "示例数据行 " & i & ": " & i * Rnd() * 1000
                Next i
            Close #fileNum
            
            MsgBox "数据已成功保存到: " & vbCrLf & savePath, vbInformation
        End If
    End With
    
    Set fd = Nothing
End Sub

Sub SelectFolderDialog()
    Dim fd As FileDialog
    Dim folderPath As String
    Dim fileName As String
    Dim ws As Worksheet
    Dim rowNum As Long
    
    ' 创建文件夹选择对话框
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    
    With fd
        .Title = "选择要扫描的文件夹"
        .InitialFileName = ThisWorkbook.Path ' 初始路径为当前工作簿所在文件夹
        
        ' 显示对话框
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
            
            ' 创建结果工作表
            Set ws = ThisWorkbook.Sheets.Add
            ws.Name = "文件夹扫描结果"
            ws.Cells(1, 1).Value = "文件名"
            ws.Cells(1, 2).Value = "路径"
            ws.Cells(1, 3).Value = "大小(字节)"
            ws.Cells(1, 4).Value = "修改日期"
            ws.Rows(1).Font.Bold = True
            rowNum = 2
            
            ' 获取文件夹中的所有文件
            fileName = Dir(folderPath & "\*.*")
            
            ' 循环处理所有文件
            Do While fileName <> ""
                ws.Cells(rowNum, 1).Value = fileName
                ws.Cells(rowNum, 2).Value = folderPath & "\" & fileName
                ws.Cells(rowNum, 3).Value = FileLen(folderPath & "\" & fileName)
                ws.Cells(rowNum, 4).Value = FileDateTime(folderPath & "\" & fileName)
                rowNum = rowNum + 1
                
                ' 获取下一个文件
                fileName = Dir()
            Loop
            
            ws.Columns("A:D").AutoFit
            MsgBox "文件夹扫描完成，共发现 " & rowNum - 2 & " 个文件", vbInformation
        End If
    End With
    
    Set fd = Nothing
End Sub

Sub FileDialogWithPreview()
    Dim fd As FileDialog
    Dim selectedFile As String
    Dim wsPreview As Worksheet
    
    ' 创建文件对话框
    Set fd = Application.FileDialog(msoFileDialogOpen)
    
    With fd
        .Title = "选择文本文件（带预览）"
        .Filters.Clear
        .Filters.Add "文本文件", "*.txt"
        .AllowMultiSelect = False
        
        ' 创建预览工作表
        On Error Resume Next
        Set wsPreview = ThisWorkbook.Sheets("文件预览")
        On Error GoTo 0
        
        If wsPreview Is Nothing Then
            Set wsPreview = ThisWorkbook.Sheets.Add
            wsPreview.Name = "文件预览"
        End If
        
        ' 循环显示对话框，直到用户取消或选择文件
        Do
            If .Show = -1 Then
                selectedFile = .SelectedItems(1)
                
                ' 预览文件内容
                wsPreview.Cells.Clear
                wsPreview.Cells(1, 1).Value = "文件预览: " & selectedFile
                wsPreview.Cells(1, 1).Font.Bold = True
                
                PreviewTextFile selectedFile, wsPreview
                
                ' 询问用户是否确认选择
                If MsgBox("是否确认选择此文件?", vbYesNo + vbQuestion) = vbYes Then
                    MsgBox "您选择了: " & selectedFile, vbInformation
                    Exit Do
                End If
            Else
                ' 用户取消
                MsgBox "已取消文件选择", vbInformation
                Exit Do
            End If
        Loop
    End With
    
    Set fd = Nothing
End Sub

' 辅助函数：预览文本文件内容
Sub PreviewTextFile(filePath As String, ws As Worksheet)
    Dim fileNum As Integer
    Dim lineContent As String
    Dim rowNum As Long
    Dim maxLines As Integer
    
    maxLines = 50 ' 最多预览50行
    rowNum = 3
    
    fileNum = FreeFile
    Open filePath For Input As #fileNum
        Do While Not EOF(fileNum) And rowNum <= maxLines + 2
            Line Input #fileNum, lineContent
            ws.Cells(rowNum, 1).Value = lineContent
            rowNum = rowNum + 1
        Loop
        
        ' 如果文件超过最大预览行数
        If Not EOF(fileNum) Then
            ws.Cells(rowNum, 1).Value = "..."
            ws.Cells(rowNum, 1).Font.Italic = True
        End If
    Close #fileNum
    
    ws.Columns("A:A").ColumnWidth = 80
    ws.Range("A2").Value = "（最多显示" & maxLines & "行）"
    ws.Range("A2").Font.Italic = True
End Sub

' 以下代码应放在UserForm的代码窗口中
Private Sub cmdBrowse_Click()
    Dim fd As FileDialog
    Dim selectedFile As String
    
    ' 创建文件对话框
    Set fd = Application.FileDialog(msoFileDialogOpen)
    
    With fd
        .Title = "选择数据文件"
        .Filters.Clear
        .Filters.Add "Excel文件", "*.xlsx;*.xls"
        .Filters.Add "CSV文件", "*.csv"
        
        If .Show = -1 Then
            selectedFile = .SelectedItems(1)
            Me.txtFilePath.Value = selectedFile ' 在文本框中显示路径
            
            ' 提取文件名显示在标签中
            Me.lblFileName.Caption = "文件名: " & Mid(selectedFile, InStrRev(selectedFile, "\") + 1)
        End If
    End With
    
    Set fd = Nothing
End Sub

Private Sub cmdImport_Click()
    ' 检查是否选择了文件
    If Me.txtFilePath.Value = "" Then
        MsgBox "请先选择文件", vbExclamation
        Exit Sub
    End If
    
    ' 检查文件是否存在
    If Dir(Me.txtFilePath.Value) = "" Then
        MsgBox "所选文件不存在", vbExclamation
        Exit Sub
    End If
    
    ' 执行导入操作（这里只是示例）
    MsgBox "开始导入文件: " & Me.txtFilePath.Value, vbInformation
    
    ' 关闭窗体
    Unload Me
End Sub

Private Sub cmdCancel_Click()
    Unload Me
End Sub

' 标准模块中的代码，用于显示UserForm
Sub ShowFileImportForm()
    FileImportForm.Show ' 假设UserForm名称为FileImportForm
End Sub

Sub BatchFileProcessor()
    Dim fd As FileDialog
    Dim i As Integer
    Dim filePaths As Variant
    Dim outputPath As String
    Dim wsReport As Worksheet
    Dim rowNum As Long
    
    ' 选择要处理的多个文件
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "选择要处理的文本文件"
        .Filters.Clear
        .Filters.Add "文本文件", "*.txt"
        .AllowMultiSelect = True
        
        If .Show <> -1 Then
            MsgBox "未选择任何文件，操作已取消", vbInformation
            Exit Sub
        End If
        
        filePaths = .SelectedItems
    End With
    
    ' 选择保存结果的文件夹
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "选择结果保存文件夹"
        .InitialFileName = ThisWorkbook.Path
        
        If .Show <> -1 Then
            MsgBox "未选择保存文件夹，操作已取消", vbInformation
            Exit Sub
        End If
        
        outputPath = .SelectedItems(1)
    End With
    
    ' 创建报告工作表
    Set wsReport = ThisWorkbook.Sheets.Add
    wsReport.Name = "批量处理报告"
    wsReport.Cells(1, 1).Value = "原始文件"
    wsReport.Cells(1, 2).Value = "处理后文件"
    wsReport.Cells(1, 3).Value = "状态"
    wsReport.Cells(1, 4).Value = "处理时间"
    wsReport.Rows(1).Font.Bold = True
    rowNum = 2
    
    ' 处理每个选中的文件
    For i = LBound(filePaths) To UBound(filePaths)
        wsReport.Cells(rowNum, 1).Value = filePaths(i)
        wsReport.Cells(rowNum, 4).Value = Now()
        
        On Error Resume Next
        ' 处理文件（这里只是示例：复制并添加处理标记）
        Dim sourceNum As Integer, destNum As Integer
        Dim content As String
        Dim fileName As String
        
        ' 获取文件名
        fileName = Mid(filePaths(i), InStrRev(filePaths(i), "\") + 1)
        
        ' 读取源文件
        sourceNum = FreeFile
        Open filePaths(i) For Input As #sourceNum
            content = Input(LOF(sourceNum), sourceNum)
        Close #sourceNum
        
        ' 写入处理后的文件
        destNum = FreeFile
        Open outputPath & "\" & Replace(fileName, ".txt", "_processed.txt") For Output As #destNum
            Print #destNum, "=== 处理于 " & Now() & " ===" & vbCrLf
            Print #destNum, content
        Close #destNum
        
        ' 记录结果
        If Err.Number = 0 Then
            wsReport.Cells(rowNum, 2).Value = outputPath & "\" & Replace(fileName, ".txt", "_processed.txt")
            wsReport.Cells(rowNum, 3).Value = "成功"
        Else
            wsReport.Cells(rowNum, 3).Value = "失败: " & Err.Description
        End If
        On Error GoTo 0
        
        rowNum = rowNum + 1
    Next i
    
    wsReport.Columns("A:D").AutoFit
    MsgBox "批量处理完成，共处理 " & UBound(filePaths) - LBound(filePaths) + 1 & " 个文件", vbInformation
    
    Set fd = Nothing
End Sub

Sub BasicInputBox()
    Dim userName As String
    
    ' 基本用法
    userName = InputBox("请输入您的姓名:", "输入姓名")
    
    ' 检查用户输入
    If userName = "" Then
        MsgBox "您没有输入姓名", vbInformation
    Else
        MsgBox "您好，" & userName & "！", vbWelcomeMsg
    End If
End Sub

InputBox(prompt, [title], [default], [xpos], [ypos], [helpfile], [context])

Sub InputBoxWithParameters()
    Dim ageStr As String
    Dim age As Integer
    
    ' 使用完整参数的InputBox
    ageStr = InputBox( _
        prompt:="请输入您的年龄:", _
        title:="年龄输入", _
        default:="30", _
        xpos:=Application.Left + 100, _
        ypos:=Application.Top + 100 _
    )
    
    ' 验证输入
    If ageStr = "" Then
        MsgBox "您取消了输入", vbInformation
    ElseIf IsNumeric(ageStr) Then
        age = CInt(ageStr)
        If age > 0 And age < 150 Then
            MsgBox "您的年龄是: " & age, vbInformation
        Else
            MsgBox "请输入有效的年龄", vbExclamation
        End If
    Else
        MsgBox "请输入数字", vbExclamation
    End If
End Sub

Sub InputBoxWithHelp()
    Dim scoreStr As String
    Dim helpFile As String
    
    ' 设置帮助文件路径（实际使用时替换为你的帮助文件）
    helpFile = "C:\help\score_help.chm"
    
    ' 带帮助按钮的InputBox
    scoreStr = InputBox( _
        prompt:="请输入考试分数(0-100):", _
        title:="分数输入", _
        default:="80", _
        helpfile:=helpFile, _
        context:=100 _
    )
    
    ' 处理输入
    If scoreStr = "" Then
        MsgBox "输入已取消", vbInformation
    ElseIf IsNumeric(scoreStr) Then
        If CDbl(scoreStr) >= 0 And CDbl(scoreStr) <= 100 Then
            MsgBox "您输入的分数是: " & scoreStr, vbInformation
        Else
            MsgBox "分数必须在0-100之间", vbExclamation
        End If
    Else
        MsgBox "请输入有效的数字", vbExclamation
    End If
End Sub

Sub InputBoxWithValidation()
    Dim quantityStr As String
    Dim quantity As Integer
    Dim isValid As Boolean
    
    isValid = False
    
    ' 循环直到获得有效输入
    Do While Not isValid
        quantityStr = InputBox( _
            prompt:="请输入订购数量(1-100):" & vbCrLf & _
                    "必须是1到100之间的整数", _
            title:="数量输入", _
            default:="10" _
        )
        
        ' 检查是否取消
        If quantityStr = "" Then
            MsgBox "已取消操作", vbInformation
            Exit Sub
        End If
        
        ' 验证输入
        If IsNumeric(quantityStr) Then
            quantity = CInt(quantityStr)
            If quantity >= 1 And quantity <= 100 Then
                isValid = True ' 有效输入，退出循环
            Else
                MsgBox "数量必须在1到100之间", vbExclamation
            End If
        Else
            MsgBox "请输入有效的数字", vbExclamation
        End If
    Loop
    
    ' 处理有效输入
    MsgBox "您已订购 " & quantity & " 件商品", vbInformation
End Sub

Sub InputBoxAndFileOperation()
    Dim filePath As String
    Dim fileNumber As Integer
    Dim userInput As String
    Dim i As Integer
    
    ' 使用InputBox获取文件路径
    filePath = InputBox( _
        prompt:="请输入要保存的文件路径和名称:" & vbCrLf & _
                "例如: C:\data\mynotes.txt", _
        title:="保存文件", _
        default:="C:\data\notes.txt" _
    )
    
    ' 检查用户是否取消
    If filePath = "" Then
        MsgBox "操作已取消", vbInformation
        Exit Sub
    End If
    
    ' 使用InputBox获取要保存的内容
    userInput = InputBox( _
        prompt:="请输入要保存的内容:", _
        title:="输入内容" _
    )
    
    If userInput = "" Then
        MsgBox "没有输入内容，文件未保存", vbInformation
        Exit Sub
    End If
    
    ' 保存到文件
    On Error GoTo ErrorHandler
    fileNumber = FreeFile
    Open filePath For Output As #fileNumber
    Print #fileNumber, "内容保存时间: " & Now()
    Print #fileNumber, "-------------------------"
    Print #fileNumber, userInput
    Close #fileNumber
    
    MsgBox "内容已成功保存到:" & vbCrLf & filePath, vbInformation
    Exit Sub
    
ErrorHandler:
    MsgBox "保存文件时出错: " & Err.Description, vbCritical
    On Error Resume Next
    Close #fileNumber
End Sub

Sub MultiStepInput()
    Dim customerInfo(1 To 4) As String
    Dim fields(1 To 4) As String
    Dim i As Integer
    Dim filePath As String
    Dim fileNumber As Integer
    
    ' 定义要收集的字段
    fields(1) = "客户姓名"
    fields(2) = "联系电话"
    fields(3) = "地址"
    fields(4) = "订单金额"
    
    ' 分步收集信息
    For i = 1 To 4
        customerInfo(i) = InputBox( _
            prompt:="请输入" & fields(i) & ":", _
            title:="输入客户信息 (" & i & "/4)", _
            default:="" _
        )
        
        ' 检查是否取消
        If customerInfo(i) = "" Then
            If MsgBox("确定要取消输入吗?", vbYesNo + vbQuestion) = vbYes Then
                MsgBox "已取消客户信息输入", vbInformation
                Exit Sub
            Else
                ' 重新获取当前字段
                i = i - 1 ' 因为循环会自动+1，所以这里-1
            End If
        End If
    Next i
    
    ' 显示收集的信息
    Dim summary As String
    summary = "收集的客户信息如下:" & vbCrLf
    For i = 1 To 4
        summary = summary & fields(i) & ": " & customerInfo(i) & vbCrLf
    Next i
    
    ' 询问是否保存
    If MsgBox(summary & vbCrLf & "是否保存这些信息?", vbYesNo + vbQuestion) = vbYes Then
        filePath = "C:\data\customers\" & Format(Now(), "yyyymmdd_hhnnss") & ".txt"
        fileNumber = FreeFile
        Open filePath For Output As #fileNumber
        Print #fileNumber, summary
        Close #fileNumber
        MsgBox "信息已保存到: " & filePath, vbInformation
    End If
End Sub

Sub FileManagerTool()
    Dim choice As Integer
    Dim running As Boolean
    
    running = True
    
    ' 主循环
    Do While running
        ' 显示菜单
        choice = MsgBox( _
            "文件管理工具" & vbCrLf & vbCrLf & _
            "1. 读取文本文件" & vbCrLf & _
            "2. 创建新文件" & vbCrLf & _
            "3. 追加到文件" & vbCrLf & _
            "4. 批量重命名文件" & vbCrLf & _
            "5. 退出", _
            vbYesNoCancel + vbQuestion + vbSystemModal, _
            "文件管理工具" _
        )
        
        ' 根据用户选择执行相应功能
        Select Case choice
            Case vbYes: ReadTextFileTool ' 读取文本文件
            Case vbNo: CreateNewFileTool ' 创建新文件
            Case vbCancel: AppendToFileTool ' 追加到文件
            ' 可以在这里添加其他功能的调用
            Case Else: running = False ' 退出
        End Select
    Loop
End Sub

' 读取文本文件工具
Sub ReadTextFileTool()
    Dim filePath As String
    
    ' 获取文件路径
    filePath = InputBox( _
        "请输入要读取的文本文件路径:", _
        "读取文件", _
        "C:\data\example.txt" _
    )
    
    If filePath = "" Then Exit Sub
    
    ' 检查文件是否存在
    If Dir(filePath) = "" Then
        MsgBox "文件不存在: " & filePath, vbExclamation
        Exit Sub
    End If
    
    ' 读取并显示文件内容
    Dim fileNumber As Integer
    Dim content As String
    
    fileNumber = FreeFile
    Open filePath For Input As #fileNumber
    content = Input(LOF(fileNumber), fileNumber)
    Close #fileNumber
    
    ' 创建显示内容的工作表
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("文件内容")
    On Error GoTo 0
    
    If ws Is Nothing Then
        Set ws = ThisWorkbook.Sheets.Add
        ws.Name = "文件内容"
    Else
        ws.Cells.Clear
    End If
    
    ' 显示文件信息和内容
    ws.Cells(1, 1).Value = "文件路径:"
    ws.Cells(1, 2).Value = filePath
    ws.Cells(2, 1).Value = "文件大小:"
    ws.Cells(2, 2).Value = FileLen(filePath) & " 字节"
    ws.Cells(3, 1).Value = "修改时间:"
    ws.Cells(3, 2).Value = FileDateTime(filePath)
    ws.Cells(5, 1).Value = "文件内容:"
    
    ' 将内容按行拆分
    Dim lines() As String
    lines = Split(content, vbCrLf)
    
    ' 写入内容到工作表
    Dim i As Integer
    For i = 0 To UBound(lines)
        ws.Cells(6 + i, 1).Value = lines(i)
    Next i
    
    ' 格式化工作表
    ws.Columns("A:A").ColumnWidth = 50
    ws.Rows("1:3").Font.Bold = True
    ws.Range("A5").Font.Bold = True
    
    MsgBox "文件内容已显示在 ""文件内容"" 工作表中", vbInformation
End Sub

' 创建新文件工具
Sub CreateNewFileTool()
    Dim filePath As String
    Dim content As String
    Dim fileNumber As Integer
    
    ' 获取文件路径
    filePath = InputBox( _
        "请输入要创建的文件路径和名称:", _
        "创建新文件", _
        "C:\data\newfile.txt" _
    )
    
    If filePath = "" Then Exit Sub
    
    ' 检查文件是否已存在
    If Dir(filePath) <> "" Then
        If MsgBox("文件已存在，是否覆盖?", vbYesNo + vbQuestion) = vbNo Then
            Exit Sub
        End If
    End If
    
    ' 获取文件内容
    content = InputBox( _
        "请输入文件内容:", _
        "输入内容" _
    )
    
    If content = "" Then
        If MsgBox("内容为空，仍要创建文件吗?", vbYesNo + vbQuestion) = vbNo Then
            Exit Sub
        End If
    End If
    
    ' 创建文件并写入内容
    On Error GoTo ErrorHandler
    fileNumber = FreeFile
    Open filePath For Output As #fileNumber
    Print #fileNumber, content
    Close #fileNumber
    
    MsgBox "文件已创建: " & filePath, vbInformation
    Exit Sub
    
ErrorHandler:
    MsgBox "创建文件失败: " & Err.Description, vbCritical
    On Error Resume Next
    Close #fileNumber
End Sub

' 追加到文件工具
Sub AppendToFileTool()
    Dim filePath As String
    Dim content As String
    Dim fileNumber As Integer
    
    ' 获取文件路径
    filePath = InputBox( _
        "请输入要追加内容的文件路径:", _
        "追加到文件", _
        "C:\data\log.txt" _
    )
    
    If filePath = "" Then Exit Sub
    
    ' 检查文件是否存在
    If Dir(filePath) = "" Then
        If MsgBox("文件不存在，是否创建新文件?", vbYesNo + vbQuestion) = vbNo Then
            Exit Sub
        End If
    End If
    
    ' 获取要追加的内容
    content = InputBox( _
        "请输入要追加的内容:", _
        "输入内容" _
    )
    
    If content = "" Then
        MsgBox "内容为空，未进行任何操作", vbInformation
        Exit Sub
    End If
    
    ' 追加内容
    On Error GoTo ErrorHandler
    fileNumber = FreeFile
    Open filePath For Append As #fileNumber
    Print #fileNumber, "[" & Format(Now(), "yyyy-mm-dd hh:nn:ss") & "] " & content
    Close #fileNumber
    
    MsgBox "内容已追加到文件: " & filePath, vbInformation
    Exit Sub
    
ErrorHandler:
    MsgBox "操作失败: " & Err.Description, vbCritical
    On Error Resume Next
    Close #fileNumber
End Sub