hopefully helps struggled restrictive header-footer options in excel. below routine using create highly customized header , footer excel. found routine on forum save cells image http://www.ozgrid.com/forum/showthread.php?t=45682.
i have hidden sheet purpose "header , footer developer". there set of cells have graphics such company logos, , text define header , footer. routines work flawlessly me. my question: looking improve upon quality of resulted image. not bad better.
regards,
mahmoud
sub printfomatter() dim headertitle string dim printsheet string dim additional_info_check boolean if activesheet.name "*print*" exit sub call miscellaneous.initializer 'gets header title select case true case activesheet.name "*bill*" headertitle = "bill of materials" printsheet = activesheet.name end select 'informs user of next action msgbox ("this tool generates printer-friendly version of " & headertitle & " sheet." & vbnewline & _ "do not use sheet editing inputs. sheet automatically deleted after printing."), vbinformation 'generates header/footer banner call headerfooterdeveloper.headerfooter(headertitle, additional_info_check) 'formats sheet call miscellaneous.printsheetdeveloper(headertitle, printsheet, additional_info_check) dim mypassword string 'mypassword = "password" each ws in activeworkbook.worksheets if ws.name "*print*" else ws.protect 'password:=mypassword end if next ws application .enableevents = true .screenupdating = true .statusbar = false end end sub sub headerfooter(header string, additional_info_check boolean) dim long ' i: counter dim additional_info 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 used user additional_info = bom.cells(bom.range("toolmatnum").row - 1, bom.range("toolmatnum").column) 'check user added additonal info if not additional_info = "" , not additional_info = "-" , not additional_info = "n/a" , not additional_info = "n/a" , _ not additional_info = " " , not additional_info = "na" , not additional_info = "na" 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 save header , footer banner = 0 1 select case true case = 0 'first page header generator select case true case = 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 save picture case = 1 'footer generator set headfoot = worksheets("header_footer_developer").range("a33:af35") headerfilename = "footerfilefor_bill of materials.png" save_picture 'calls routine save picture end select next end sub '============================================================================= '- copy pictures worksheet .bmp files '- version 2 : uses code save file instead of sendkeys/ms paint '--------------------------------------------------------------------- '- code attributed jaafar of mrexcel forum (with no messages present now) '- ref : http://www.ozgrid.com/forum/showthread.php?t=45682 '--------------------------------------------------------------------- '- picks embedded objects (oleobjects) , pictures (picture objects) '============================================================================= '- *** amend these const values , run macro sheet const bitmapfilename string = "xlpicture" 'file name without "_00x.bmp" const mypicturefolder string = "c:\users\marzmah\videos\cylinder fixture __ prototype cost2_files" ' target folder files '------------------------------------------------------------------------- '- 1. copies pictures sheet. '- 2. gets next file name in series (filenames format "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 bmp '============================================================================= '- declarations & variables save picture file clipboard private declare function openclipboard lib "user32" (byval hwnd long) long private declare function getclipboarddata lib "user32" (byval wformat integer) long private declare function closeclipboard lib "user32" () long private declare function olecreatepictureindirect lib "olepro32.dll" _ (picdesc upicdesc, refiid guid, byval fpictureownshandle long, ipic ipicture) long '------------------------------------------------------------------------------ '- ipicture ole interface private type guid data1 long data2 integer data3 integer data4(0 7) byte end type '-store bitmap information private type upicdesc size long type long hpic long hpal 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 guid dim upicinfo upicdesc dim ipic ipicture dim hptr long '============================================================================= '- worksheet/picture variables dim headfoot range dim mypicture object ' pictures in sheet dim picturecount integer '----------------------------------------------------------------------------- '- bitmap file : full path & file name dim headerfilename string dim fullfilename string '= mypicturefolder & headerfilename & "_00x.bmp" '----------------------------------------------------------------------------- '- next file name (uses filesystemobject) dim fso object dim filenumber integer dim lastfilenumber integer '-- end of declarations ------------------------------------------------------ '- subroutine : save picture clipboard bitmap file (jaafar's code) '- called main routine '============================================================================= private sub save_picture() activesheet.range("a1").select ' focus button or picture sheet lastfilenumber = 0 ' counter set fso = createobject("scripting.filesystemobject") ' 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 interface guid picture 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 '------------------------------------------------------------------------ ' fill upicinfo necessary parts. upicinfo .size = len(upicinfo) ' length of structure. .type = pictype_bitmap ' type of picture .hpic = hptr ' handle image. .hpal = 0 ' handle palette (if bitmap). end '------------------------------------------------------------------------ 'create picture object olecreatepictureindirect upicinfo, iid_idispatch, true, ipic '------------------------------------------------------------------------ 'save picture stdole.savepicture ipic, fullfilename '------------------------------------------------------------------------ 'fix clipboard (it seems go messed up) selection.copypicture appearance:=xlscreen, format:=xlbitmap '------------------------------------------------------------------------ end sub sub printsheetdeveloper(headertitle string, printsheet string, additional_info_check boolean) 'this routine develops printer-friendly worksheet. dim printsheettitle string dim nm name, ws worksheet dim lastusedrow(1 4) long dim firstrow long, lastcol long, long, lastrow long, lastrowrng range, mergerng(1 2) range dim dpi_settingfactor double, dpi_setting string printsheettitle = "print sheet--" & headertitle on error resume next application.displayalerts = false each ws in activeworkbook.worksheets if ws.name "*print*" ws.delete next ws application.displayalerts = true on error goto 0 'creats copy of active spreadsheet worksheets(printsheet).copy before:=bom 'gets screen dpi settings adjust print options accordingly dpi_setting = getdpi() if dpi_setting "96" dpi_settingfactor = 0.97385 else dpi_settingfactor = 1 end if 'changes name of activesheet activesheet.name = printsheettitle 'changes sheet tab color 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 color of rows (alternating grey , white rows) = firstrow + 1 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 worksheets(printsheettitle).range(cells(151, 1), cells(151, lastcol)).interior.colorindex = xlnone 'hides existing header on sheet (will replaced header banner) worksheets(printsheettitle).rows("1:4").hidden = true 'gets last row 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 print setup bill of materials 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 additional info - , accounts 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 end sub
Comments
Post a Comment