Imagem Para Fundo Access

option compare database option explicit ' ****code start**** ' place this code in a standard module. ' make sure you do not name the module ' to conflict with any of the functions below. 'author: stephen lebans ' [email protected] ' www.lebans.com ' may 03, 2003 ' 'copyright: lebans holdings 1999 ltd. ' 'functions: see function declarations inline ' 'dependencies: ' you must import the following modules into your own application in ' order for all of the functions contained in this project to work properly. ' ' modchangemdi ' modcolorpicker ' cdibsection ' clscommondialog ' 'credits: nobody ' ' 'why?: somebody asked for it! ' 'what's missing: user selectable props for scaling, position of bitmap. ' 'bugs: let me know! ' ' notes: ***************************************************** ' you must delete any brushes you create! ' ' :-) private type rect left as long top as long right as long bottom as long end type private type sizel cx as long cy as long end type private type rgbquad rgbblue as byte rgbgreen as byte rgbred as byte rgblreserved as byte

end type private type bitmapinfoheader '40 bytes bisize as long ' 40 biwidth as long ' 32 biheight as long ' 64 biplanes as integer '1 bibitcount as integer '1 bicompression as long 'ergbcompression bisizeimage as long bixpelspermeter as long biypelspermeter as long biclrused as long biclrimportant as long end type private type bitmapinfo bmiheader as bitmapinfoheader bmicolors(1) as rgbquad end type private type bitmap bmtype as long bmwidth as long bmheight as long bmwidthbytes as long bmplanes as integer bmbitspixel as integer bmbits as long end type

' logical brush (or pattern) private type logbrush lbstyle as long lbcolor as long lbhatch as long end type private type wndclass style as long lpfnwndproc as long cbclsextra as long cbwndextra2 as long hinstance as long hicon as long hcursor as long hbrbackground as long lpszmenuname as string lpszclassname as string end type

type wndclassex cbsize as long style as long lpfnwndproc as long cbclsextra as long cbwndextra as long hinstance as long hicon as long hcursor as long hbrbackground as long lpszmenuname as string lpszclassname as string hiconsm as long end type private declare function getsyscolor lib "user32" (byval nindex as long) as long private declare function settextcolor lib "gdi32" (byval hdc as long, byval crcolor as long) as long private declare function getdc lib "user32" (byval hwnd as long) as long private declare function deletedc lib "gdi32" (byval hdc as long) as long private declare function apigetdevicecaps lib "gdi32" _ alias "getdevicecaps" (byval hdc as long, byval nindex as long) as long private declare function createsolidbrush lib "gdi32" _ _ (byval crcolor as long) as long private declare function deleteobject lib "gdi32" _ (byval hobject as long) as long private declare function selectobject lib "gdi32" _ (byval hdc as long, byval hobject as long) as long private declare function getstockobject lib "gdi32" _ (byval nindex as long) as long private declare function createhatchbrush lib "gdi32" (byval nindex as long, byval crcolor as long) as long private declare function createpatternbrush lib "gdi32" (byval hbitmap as long) as long private declare function createdibpatternbrush lib "gdi32" (byval hpackeddib as long, byval wusage as long) as long private declare function createdibpatternbrushpt lib "gdi32" (lppackeddib as any, byval iusage as long) as long private declare function setclasslong lib "user32" alias "setclasslonga" (byval hwnd as long, byval nindex as long, byval dwnewlong as long) as long private declare function findwindowex lib "user32" alias "findwindowexa" (byval hwnd1 as long, byval hwnd2 as long, byval lpsz1 as string, byval lpsz2 as string) as long private declare function getwindowrect lib "user32" (byval hwnd as long, lprect as

rect) as long private declare function invalidaterect lib "user32" (byval hwnd as long, lprect as rect, byval berase as long) as long private declare function setbkcolor lib "gdi32" (byval hdc as long, byval crcolor as long) as long private declare function setbkmode lib "gdi32" (byval hdc as long, byval nbkmode as long) as long

private declare function apigetclassname lib "user32" _ alias "getclassnamea" _ (byval hwnd as long, _ byval lpclassname as string, _ byval nmaxcount as long) _ as long private declare function apigetparent lib "user32" _ alias "getparent" _ (byval hwnd as long) _ as long private declare function apigetwindow lib "user32" _ alias "getwindow" _ (byval hwnd as long, _ byval wcmd as long) _ as long private declare function getwindowdc lib "user32" (byval hwnd as long) as long private declare function releasedc lib "user32" (byval hwnd as long, byval hdc as long) as long private declare function apisendmessage lib "user32" _ alias "sendmessagea" _ (byval hwnd as long, _ byval wmsg as long, _ byval wparam as long, _ lparam as any) as long private declare function redrawwindow lib "user32" _ (byval hwnd as long, lprcupdate as rect, byval hrgnupdate as long, byval furedraw as long) as long private declare function setwindowlong lib "user32" alias "setwindowlonga" _ (byval hwnd as long, byval nindex as long, byval dwnewlong as long) as long private declare function getwindowlong lib "user32" alias "getwindowlonga" _ (byval hwnd as long, byval nindex as long) as long private declare function loadicon lib "user32" alias "loadicona" _ (byval hinstance as long, byval lpiconname as string) as long

private declare function loadcursor lib "user32" alias "loadcursora" _ (byval hinstance as long, byval lpcursorname as string) as long private declare function getclassinfo lib "user32" alias "getclassinfoa" _ (byval hinstance as long, byval lpclassname as string, lpwndclass as wndclass) as long private declare function getclassinfoex lib "user32" alias "getclassinfoexa" _ (byval hinstance as long, byval lpclassname as string, lpwndclass as wndclassex) as long ' class private private private private private private private private private private

field const const const const const const const const const const

offsets for getclasslong() and getclassword() gcl_menuname = (-8) gcl_hbrbackground = (-10) gcl_hcursor = (-12) gcl_hicon = (-14) gcl_hmodule = (-16) gcl_cbwndextra = (-18) gcl_cbclsextra = (-20) gcl_wndproc = (-24) gcl_style = (-26) gcw_atom = (-32)

' window field offsets for getwindowlong() and getwindowword() private const gwl_wndproc = (-4) private const gwl_hinstance = (-6) private const gwl_hwndparent = (-8) private const gwl_style = (-16) private const gwl_exstyle = (-20) private const gwl_userdata = (-21) private const gwl_id = (-12) ' stock private private private private private private private

logical objects const white_brush = 0 const ltgray_brush = 1 const gray_brush = 2 const dkgray_brush = 3 const black_brush = 4 const null_brush = 5 const hollow_brush = null_brush

private const clr_invalid = &hffff ' brush private private private private private private private private private private

styles const bs_solid = 0 const bs_null = 1 const bs_hollow = bs_null const bs_hatched = 2 const bs_pattern = 3 const bs_indexed = 4 const bs_dibpattern = 5 const bs_dibpatternpt = 6 const bs_pattern8x8 = 7 const bs_dibpattern8x8 = 8

' hatch styles private const hs_horizontal = 0 private const hs_vertical = 1 private const hs_fdiagonal = 2 private const hs_bdiagonal = 3 private const hs_cross = 4 private const hs_diagcross = 5 private const hs_fdiagonal1 = 6 private const hs_bdiagonal1 = 7 private const hs_solid = 8 private const hs_dense1 = 9 private const hs_dense2 = 10 private const hs_dense3 = 11 private const hs_dense4 = 12 private const hs_dense5 = 13 private const hs_dense6 = 14 private const hs_dense7 = 15 private const hs_dense8 = 16 private const hs_noshade = 17 private const hs_halftone = 18 private const hs_solidclr = 19 private const hs_ditheredclr = 20 private const hs_solidtextclr = 21 private const hs_ditheredtextclr = 22 private const hs_solidbkclr = 23 private const hs_ditheredbkclr = 24 private const hs_api_max = 25

' ' ' ' ' '

----||||| \\\\\ ///// +++++ xxxxx

' color private private private private private private private private

types const const const const const const const const

ctlcolor_msgbox = 0 ctlcolor_edit = 1 ctlcolor_listbox = 2 ctlcolor_btn = 3 ctlcolor_dlg = 4 ctlcolor_scrollbar = 5 ctlcolor_static = 6 ctlcolor_max = 8 ' three bits max

private private private private private private private private private private private private private private private private private private private private

const const const const const const const const const const const const const const const const const const const const

color_scrollbar = 0 color_background = 1 color_activecaption = 2 color_inactivecaption = 3 color_menu = 4 color_window = 5 color_windowframe = 6 color_menutext = 7 color_windowtext = 8 color_captiontext = 9 color_activeborder = 10 color_inactiveborder = 11 color_appworkspace = 12 color_highlight = 13 color_highlighttext = 14 color_btnface = 15 color_btnshadow = 16 color_graytext = 17 color_btntext = 18 color_inactivecaptiontext = 19

private const color_btnhighlight = 20

private const wm_syscolorchange = &h15 ' getwindow() constants private const gw_hwndnext = 2 private const gw_child = 5 private const title = "" private const api_true as long = 1& ' handle to original windowclass brush for mdi window private prevhbrush as long ' handle to our new brush for the mdi window private hbrush as long ' handle to mdi window private hwndmdi as long ' handle to original windowclass brush for mdi window private prevhbrushstatus as long ' handle to our new brush for the mdi window private hbrushstatus as long

public function setmdibackgroundimage(optional fname as string = "") as boolean ' junk var dim lngret as long dim hbrushimage as long dim hbrushimageprev as long ' window rect dim rc as rect ' an instance of our dibsection calss dim ds as new cdibsection if len(fname & vbnullstring) = 0 then ' call file dialog fname = ds.filedialog(true) end if ' load the bitmap file selected and create a dibsection ' based on this bitmap. ds.load fname ' create a brush from the bitmap we loaded hbrushimage = createpatternbrush(ds.hdib) ' find mdiclient first hwndmdi = findwindowex(application.hwndaccessapp, 0&, "mdiclient", title) ' get current dimensions

lngret = getwindowrect(hwndmdi, rc) with rc .bottom = .bottom - .top .top = 0 .right = .right - .left .left = 0 end with hbrushimageprev = setclasslong(hwndmdi, gcl_hbrbackground, hbrushimage) ' force a redraw call invalidaterect(hwndmdi, rc, api_true) setmdibackgroundimage = true ' cleanup ' delete old brush lngret = deleteobject(hbrushimageprev) set ds = nothing end function public function restoremdibackgroundimage(optional crcolor as long = -1) as boolean ' junk var dim lngret as long dim hbrushimage as long dim hbrushimageprev as long ' window rect dim rc as rect ' an instance of our dibsection calss if crcolor <> -1 then hbrushimage = createsolidbrush(crcolor) else ' create a brush from the bitmap we loaded hbrushimage = createsolidbrush(getsyscolor(color_appworkspace)) end if ' find mdiclient first hwndmdi = findwindowex(application.hwndaccessapp, 0&, "mdiclient", title) ' get current dimensions lngret = getwindowrect(hwndmdi, rc) with rc .bottom = .bottom - .top .top = 0 .right = .right - .left .left = 0 end with hbrushimageprev = setclasslong(hwndmdi, gcl_hbrbackground, hbrushimage) ' force a redraw call invalidaterect(hwndmdi, rc, api_true) restoremdibackgroundimage = true ' cleanup ' delete old brush lngret = deleteobject(hbrushimageprev) end function

public function setstatusbackground(byval bgcolor as long, optional textcolor as long = -1) as boolean ' i tried to set a nwe brush for the default background brush for this ' window class but access did not respect this change. i noticed that this window class ' is spec'd to have its own device context for each instance of the class so i ' decided to modify the dc's props directly. ' junk var dim lngret as long ' window rect dim rc as rect ' this window's device context dim hdc as long ' handle to status window dim hwndstatus as long ' the status bar's window handle hwndstatus = findwindowex(application.hwndaccessapp, 0&, "ostatbar", vbnullstring) ' get current dimensions of the status bar window lngret = getwindowrect(hwndstatus, rc) with rc .bottom = .bottom - .top .top = 0 .right = .right - .left .left = 0 end with ' let's set the dc's properties directly hdc = getdc(hwndstatus) ' set the background color of this dc lngret = setbkcolor(hdc, bgcolor) ' were we passed a new forecolor for the text? if textcolor <> -1 then lngret = settextcolor(hdc, textcolor) end if ' always release the dc asap lngret = releasedc(hwndstatus, hdc) ' force a redraw call invalidaterect(hwndstatus, rc, api_true) setstatusbackground = true end function

public function restorestatusbackground() as boolean ' restore to default colors ' junk var dim lngret as long dim buttonfacecolor as long ' window rect dim rc as rect ' this window's device context dim hdc as long ' handle to status window dim hwndstatus as long ' current system color buttonfacecolor = getsyscolor(color_btnface) ' the status bar's window handle hwndstatus = findwindowex(application.hwndaccessapp, 0&, "ostatbar", vbnullstring) ' get current dimensions of the status bar window lngret = getwindowrect(hwndstatus, rc) with rc .bottom = .bottom - .top .top = 0 .right = .right - .left .left = 0 end with ' let's set the dc's properties directly hdc = getdc(hwndstatus) ' set the background color of this dc lngret = setbkcolor(hdc, buttonfacecolor) ' set text forecolor to black lngret = settextcolor(hdc, 0) ' always release the dc asap lngret = releasedc(hwndstatus, hdc) ' force a redraw call invalidaterect(hwndstatus, rc, api_true) restorestatusbackground = true ' force a redraw call invalidaterect(hwndstatus, rc, api_true) restorestatusbackground = true end function

private function finddetailwindow(byval frmhwnd as long) as long ' the detail window is always the second of three ' windows of class oformsub. ' 1) form header ' 2) detail

' 3) footer dim hwnd_vsb as long dim hwnd as long dim ctr as long ctr = 0 hwnd = frmhwnd ' let's get first child window of the form hwnd_vsb = apigetwindow(hwnd, gw_child) ' let's walk through every sibling window of the form do ' thanks to terry kreft for explaining ' why the apigetparent acll is not required. ' terry is in a class by himself! :-) 'if apigetparent(hwnd_vsb) <> hwnd then exit do if fgetclassname(hwnd_vsb) = "oformsub" then ctr = ctr + 1 if ctr = 2 then finddetailwindow = hwnd_vsb exit function end if end if ' let's get the next sibling window hwnd_vsb = apigetwindow(hwnd_vsb, gw_hwndnext) ' let's start the process from the top again ' really just an error check loop while hwnd_vsb <> 0 ' sorry - no vertical scrollbar control ' is currently visible for this form finddetailwindow = 0 end function ' from dev ashish's site ' the access web ' http://www.mvps.org/access/ '******* code start ********* private function fgetclassname(hwnd as long) dim strbuffer as string dim lnglen as long const max_len = 255 strbuffer = space$(max_len) lnglen = apigetclassname(hwnd, strbuffer, max_len) if lnglen > 0 then fgetclassname = left$(strbuffer, lnglen) end function '******* code end *********