修改改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

運作效果圖: