希望这有助于任何在Excel中使用限制性页眉页脚选项的人。下面是我用来为excel创建高度自定义页眉和页脚的例程。我在论坛上找到了将单元格保存到图像http://www.ozgrid.com/forum/showthread.php?t=45682的例程。
我有一个隐藏的表单，用于“Header and Footer Developer”。有一组单元格，我有图形，如公司徽标，以及定义页眉和页脚的文本。这个例程对我来说完美无缺。 我的问题：我希望改进结果图像的质量。 这不错，但肯定会更好。
此致
马哈茂德
Sub PrintFomatter()
Dim HeaderTitle As String
Dim PrintSheet As String
Dim AddiTioNal_InFo_Check As Boolean
If ActiveSheet.Name Like "*PRINT*" Then Exit Sub
Call miscellaneous.Initializer
'Gets the header title
Select Case True
Case ActiveSheet.Name Like "*Bill*"
HeaderTitle = "Bill of Materials"
PrintSheet = ActiveSheet.Name
End Select
'Informs the user of the next action
MsgBox ("This tool generates a printer-friendly version of " & HeaderTitle & " Sheet." & vbNewLine & _
"Do Not use this sheet for editing inputs. The Sheet would automatically be DELETED after printing."), vbInformation
'Generates the Header/Footer Banner
Call HeaderFooterDeveloper.HeaderFooter(HeaderTitle, AddiTioNal_InFo_Check)
'Formats Sheet
Call miscellaneous.PrintSheetDeveloper(HeaderTitle, PrintSheet, AddiTioNal_InFo_Check)
Dim myPassword As String
'myPassword = "password"
For Each WS In ActiveWorkbook.Worksheets
If WS.Name Like "*PRINT*" Then
Else
WS.Protect 'Password:=myPassword
End If
Next WS
With Application
.EnableEvents = True
.ScreenUpdating = True
.StatusBar = False
End With
End Sub
Sub HeaderFooter(Header As String, AddiTioNal_InFo_Check As Boolean)
Dim i As Long ' i: Counter
Dim AddiTioNal_InFo As String
Worksheets("Header_Footer_Developer").Range("F6").Font.Color = RGB(255, 255, 255)
Worksheets("Header_Footer_Developer").Range("J6").Font.Color = RGB(255, 255, 255)
'Gets additional info is USED by user
AddiTioNal_InFo = BOM.Cells(BOM.Range("ToolMatNum").Row - 1, BOM.Range("ToolMatNum").Column)
'Check is user added additonal info
If Not AddiTioNal_InFo = "" And Not AddiTioNal_InFo = "-" And Not AddiTioNal_InFo = "N/A" And Not AddiTioNal_InFo = "n/a" And _
Not AddiTioNal_InFo = " " And Not AddiTioNal_InFo = "NA" And Not AddiTioNal_InFo = "na" Then AddiTioNal_InFo_Check = True
Select Case True
Case ActiveSheet.Name = BOM.Name
Worksheets("Header_Footer_Developer").Range("AB5") = "Checked By:"
Worksheets("Header_Footer_Developer").Range("AB6") = "Approved By:"
Worksheets("Header_Footer_Developer").Range("AC5") = BOM.Range("Checker").Value
Worksheets("Header_Footer_Developer").Range("AC6") = BOM.Range("Approver").Value
Worksheets("Header_Footer_Developer").Range("AE6") = "Date:"
Worksheets("Header_Footer_Developer").Range("AF5") = BOM.Cells(Range("Checker").Row, Range("Checker").Column + 2).Value
Worksheets("Header_Footer_Developer").Range("AF6") = BOM.Cells(Range("Approver").Row, Range("Approver").Column + 2).Value
End Select
Worksheets("Header_Footer_Developer").Range("A2") = Header & ": " & BOM.Range("D1")
'Calls SAVE_PICTURE to save Header and Footer banner
For i = 0 To 1
Select Case True
Case i = 0 'First Page Header Generator
Select Case True
Case Is = AddiTioNal_InFo_Check = False
Set HeadFoot = Worksheets("Header_Footer_Developer").Range("A1:AF6")
Case AddiTioNal_InFo_Check = True
Set HeadFoot = Worksheets("Header_Footer_Developer").Range("A1:AF7")
End Select
HeaderFileName = "FirstHeaderFileFor_Bill of Materials.png"
SAVE_PICTURE 'Calls routine to save picture
Case i = 1 'Footer Generator
Set HeadFoot = Worksheets("Header_Footer_Developer").Range("A33:AF35")
HeaderFileName = "FooterFileFor_Bill of Materials.png"
SAVE_PICTURE 'Calls routine to save picture
End Select
Next i
End Sub
'=============================================================================
'- COPY PICTURES FROM A WORKSHEET TO .BMP FILES
'- VERSION 2 : uses code to save file instead of SendKeys/MS Paint
'---------------------------------------------------------------------
'- Thanks to the code attributed to JAAFAR of MrExcel forum (with no messages present now)
'- Ref : http://www.ozgrid.com/forum/showthread.php?t=45682
'---------------------------------------------------------------------
'- Picks up Embedded objects (OLEObjects) and Pictures (Picture objects)
'=============================================================================
'- *** AMEND THESE CONST VALUES AND RUN THE MACRO FROM THE SHEET
Const BitmapFileName As String = "XLpicture" 'file name without "_00x.bmp"
Const MyPictureFolder As String = "C:\Users\marzmah\Videos\Cylinder Fixture __ Prototype Cost2_files" ' target folder for files
'-------------------------------------------------------------------------
'- 1. Copies all pictures from sheet.
'- 2. Gets next file name in the series (filenames format like "xxx_001.bmp")
'- 3. Saves file in target folder.
'- Brian Baulsom November 2008
'=============================================================================
'- VERSION 1 : Userform Screen copy July 2008 using SendKeys/MS Paint
'- Save Userform as BMP
'=============================================================================
'- DECLARATIONS & VARIABLES TO SAVE PICTURE FILE FROM CLIPBOARD
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'------------------------------------------------------------------------------
'- IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'-store the bitmap information
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
'-------------------------------------------------------------------------------
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const PICTYPE_BITMAP = 1
Dim IID_IDispatch As GUID
Dim uPicinfo As uPicDesc
Dim IPic As IPicture
Dim hPtr As Long
'=============================================================================
'- WORKSHEET/PICTURE VARIABLES
Dim HeadFoot As Range
Dim MyPicture As Object ' PICTURES IN SHEET
Dim PictureCount As Integer
'-----------------------------------------------------------------------------
'- BITMAP FILE : FULL PATH & FILE NAME
Dim HeaderFileName As String
Dim FullFileName As String '= MyPictureFolder & HeaderFileName & "_00x.bmp"
'-----------------------------------------------------------------------------
'- GET NEXT FILE NAME (Uses FileSystemObject)
Dim fso As Object
Dim FileNumber As Integer
Dim LastFileNumber As Integer
'-- end of declarations ------------------------------------------------------
'- SUBROUTINE : SAVE PICTURE FROM CLIPBOARD AS A BITMAP FILE (JAAFAR'S CODE)
'- Called from main routine
'=============================================================================
Private Sub SAVE_PICTURE()
ActiveSheet.Range("A1").Select ' focus from button or picture to sheet
LastFileNumber = 0 ' counter
Set fso = CreateObject("Scripting.FileSystemObject") ' FOR NEXTFILENAME
FullFileName = "C:\Users\Public\Pictures\" & HeaderFileName
'Sheet2.Range ("A1:AL5")
Application.ScreenUpdating = True
HeadFoot.CopyPicture Appearance:=xlScreen, Format:=xlBitmap ' MyPicture.Copy
Application.ScreenUpdating = False
'-----------------------------------------------------------------
OpenClipboard 0
hPtr = GetClipboardData(CF_BITMAP)
CloseClipboard
'-------------------------------------------------------------------------
'Create the interface GUID for the picture
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
'------------------------------------------------------------------------
' Fill uPicInfo with necessary parts.
With uPicinfo
.Size = Len(uPicinfo) ' Length of structure.
.Type = PICTYPE_BITMAP ' Type of Picture
.hPic = hPtr ' Handle to image.
.hPal = 0 ' Handle to palette (if bitmap).
End With
'------------------------------------------------------------------------
'Create the Picture Object
OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
'------------------------------------------------------------------------
'Save Picture
stdole.SavePicture IPic, FullFileName
'------------------------------------------------------------------------
'fix the clipboard (it seems to go messed up)
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
'------------------------------------------------------------------------
End Sub
Sub PrintSheetDeveloper(HeaderTitle As String, PrintSheet As String, AddiTioNal_InFo_Check As Boolean) 'This Routine Develops a Printer-Friendly WorkSheet.
Dim PrintSheetTitle As String
Dim nm As Name, WS As Worksheet
Dim LastUsedRow(1 To 4) As Long
Dim FirstRow As Long, LastCol As Long, i As Long, LastRow As Long, LastRowRng As Range, MergeRng(1 To 2) As Range
Dim DPI_SettingFactor As Double, DPI_Setting As String
PrintSheetTitle = "PRINT SHEET--" & HeaderTitle
On Error Resume Next
Application.DisplayAlerts = False
For Each WS In ActiveWorkbook.Worksheets
If WS.Name Like "*PRINT*" Then WS.Delete
Next WS
Application.DisplayAlerts = True
On Error GoTo 0
'Creats A Copy of Active Spreadsheet
Worksheets(PrintSheet).Copy before:=BOM
'Gets Screen DPI Settings to Adjust Print Options Accordingly
DPI_Setting = GetDpi()
If DPI_Setting Like "96" Then
DPI_SettingFactor = 0.97385
Else
DPI_SettingFactor = 1
End If
'Changes Name of ActiveSheet
ActiveSheet.Name = PrintSheetTitle
'Changes Sheet Tab color to grey
Worksheets(PrintSheetTitle).Tab.ColorIndex = xlNone
ActiveWindow.View = xlPageBreakPreview 'xlPageLayoutView
Select Case True
'Formats Bill of Materials Sheet
Case HeaderTitle = "Bill of Materials"
FirstRow = BOM.Range("ItemNo_BOM").Row
LastCol = BOM.Range("Comment_BOM").Column
'Changes the color of rows (Alternating Grey and White rows)
For i = FirstRow + 1 To 150 Step 2
Worksheets(PrintSheetTitle).Range(Cells(i, 1), Cells(i, LastCol)).Interior.ColorIndex = xlNone
Worksheets(PrintSheetTitle).Range(Cells(i + 1, 1), Cells(i + 1, LastCol)).Interior.Color = RGB(228, 228, 228)
Next i
Worksheets(PrintSheetTitle).Range(Cells(151, 1), Cells(151, LastCol)).Interior.ColorIndex = xlNone
'Hides existing header on sheet (will be replaced by header banner)
Worksheets(PrintSheetTitle).Rows("1:4").Hidden = True
'Gets last row from specific columns
LastUsedRow(1) = BOM.Columns("A").Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
LastUsedRow(2) = BOM.Columns("C").Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
LastUsedRow(3) = BOM.Columns("E").Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
LastUsedRow(4) = WorksheetFunction.Max(LastUsedRow(1), LastUsedRow(2), LastUsedRow(3))
End Select
'Adjust the Print Setup for Bill of Materials
With Worksheets(PrintSheetTitle).PageSetup
.ScaleWithDocHeaderFooter = False
Select Case True
'FORMATS BoM SHEET
Case HeaderTitle = "Bill of Materials"
.PaperSize = xlPaperLetter
.LeftHeaderPicture.Filename = "C:\Users\Public\Pictures\FirstHeaderFileFor_Bill of Materials.png"
.LeftHeader = "&G"
.LeftHeaderPicture.LockAspectRatio = True
.CenterFooterPicture.Filename = "C:\Users\Public\Pictures\FooterFileFor_Bill of Materials.png"
.CenterFooter = "&G"
.LeftHeaderPicture.Width = Application.InchesToPoints(9.5 * DPI_SettingFactor)
.CenterFooterPicture.Width = Application.InchesToPoints(9.6 * DPI_SettingFactor)
'Checks if there is additional info - and accounts for additional header margin
Select Case True
Case AddiTioNal_InFo_Check = False
.TopMargin = Application.InchesToPoints(1.1)
Case AddiTioNal_InFo_Check = True
.TopMargin = Application.InchesToPoints(1.24)
End Select
.BottomMargin = Application.InchesToPoints(0.65)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.PrintQuality = 600
.AlignMarginsHeaderFooter = True
.CenterHorizontally = True
.CenterFooterPicture.LockAspectRatio = True
.LeftFooter = "&" & Chr(34) & "Arial, regular" & Chr(34) & "&7" & "&B Print Date: &B &D " & " " & Chr(13) & Chr(13) '& Chr(13) 'vbCrLf & vbCrLf
.RightFooter = "&" & Chr(34) & "Arial &8" & Chr(34) & "&7" & "Page &P of &N " & Chr(13) & Chr(13) '& Chr(13)
.PrintArea = Range(Cells(FirstRow - 1, 1), Cells(LastUsedRow(4), LastCol)).Address
End Select
Application.PrintCommunication = True
End With
End Sub