修改改EXCEL页眉页脚

程序实现修改改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

运行效果图: