修改改EXCEL页眉页脚

来源：互联网发布：java 开源连接池编辑：程序博客网时间：2024/04/29 15:36

程序实现修改改EXCEL页眉页脚,下面代码经测试,请放心使用(修改)

Option Explicit

Private strFileName As String
Private mstrDir As String
Private colAllDir() As New Collection
Private mintCount As Integer                        ''.xls 文件个数
Private mFileName(800) As String              ''文件全路径（含文件名）

Private Sub cmd_Change_Click()

    Dim i As Integer
    Dim j As Integer
    Dim ObjExcelApl As Variant

    scan (txt_Path.Text & "/")

    If mintCount = -1 Then
        MsgBox "File Path Error!", vbOKOnly, "出错啦！NO Excel File"
        Exit Sub
    End If

    ProgressBar1.Min = 0
    ProgressBar1.Max = mintCount + 1
    ProgressBar1.Visible = True
'    List1.Clear

    For i = 0 To mintCount

        Set ObjExcelApl = Nothing
        j = 1

        Set ObjExcelApl = CreateObject("Excel.Application")         '打开excel
        ObjExcelApl.Workbooks.Open mFileName(i)                     '打开book

        For j = 1 To ObjExcelApl.Worksheets.Count

                ObjExcelApl.Worksheets.Item(j).Activate

                lblSheetCount.Caption = mFileName(i) & vbCrLf & ObjExcelApl.ActiveSheet.Name

                    If InStr(ObjExcelApl.ActiveSheet.Name, "外部定义") > 0 Then
                        ObjExcelApl.ActiveSheet.Range("G4").Value = "蒋中平系统"
                    Else
                        ObjExcelApl.ActiveSheet.Cells(3, 12) = "蒋中平系统"
                    End If

                    '印刷設定
                    With ObjExcelApl.ActiveSheet.PageSetup
                        ''页眉
                        .LeftHeader = "&""宋体,常规" & Chr$(34) & "&12 "                             ''左为空
                        .RightHeader = "&""宋体,常规" & Chr$(34) & "&12 " & "BinYz"        ''右为BinYz
                        ''页脚
                        .RightFooter = "&""宋体,常规" & Chr$(34) & "&12 " & "JiangZhp"    ''右JiangZhp
                    End With
                    ObjExcelApl.ActiveSheet.Range("A1").Select
        Next j

            ObjExcelApl.Worksheets.Item(1).Select
            ObjExcelApl.ActiveWorkbook.Save
            ObjExcelApl.ActiveWindow.Close

'            List1.AddItem mFileName(i)
            ProgressBar1.Value = i + 1

    Next i

    MsgBox "所有的文件都修正完了！", vbOKOnly, "确认"

End Sub
'结束
Private Sub Close_Click()
End
End Sub
'获得目录
Private Sub Dir1_Change()
    txt_Path.Text = Dir1.Path
End Sub
'获得驱动器
Private Sub Drive1_Change()
   Dir1.Path = Drive1.Drive
End Sub

Private Sub Form_Load()
mintCount = -1
End Sub

Sub scan(strDir As String)
Dim strFileName     As String
Dim nd              As Integer
Dim fold()          As String
Dim n               As Integer

Dim strTmpDir       As String
Dim strTmpDirSec() As String

strFileName = Dir(strDir, vbDirectory)
Do While strFileName <> ""
          If strFileName <> "." And strFileName <> ".." Then
                  If GetAttr(strDir & strFileName) = vbDirectory Then
                          nd = nd + 1
                          ReDim Preserve fold(nd)
                          fold(nd) = strDir & strFileName
                  Else
                        If strDir <> mstrDir Then
                            If Right(strFileName, 4) = ".xls" Then
                                mintCount = mintCount + 1
                                mFileName(mintCount) = strDir & strFileName
                            End If
                        End If
                  End If
          End If
          strFileName = Dir
'          DoEvents
Loop

strFileName = Dir(strDir)
Do While strFileName <> ""
          strFileName = Dir
Loop

For n = 1 To nd
        Call scan(fold(n) & "/")
Next

End Sub

运行效果图: