| 发表于：2007-06-24 07:32:166楼 得分:0 |
'in form:>
option explicit
dim m_sfolder as string 'path of folder/file returned from browseforfolder dialog.
dim m_sdisplayname as string 'item text returned from browseforfolder dialog.
private sub cmdbrowse_click（)
dim sfolder as string
m_sfolder = "d:\ "
sfolder = browse（me.hwnd, _
bif_browseincludefiles or bif_statustext or bif_usenewui, _
m_sfolder, _
m_sdisplayname, _
"title: ", _
"dialog title: ", _
" ")
debug.print sfolder & vbcrlf & _
"displayname: " & m_sdisplayname
end sub
'----------------------------
'in module:
option explicit
private const wm_user as long = &h400&
' message from browser
private const bffm_initialized as long = 1
private const bffm_selchanged as long = 2
private const bffm_setstatustexta as long = （wm_user + 100)
private const bffm_setselectiona as long = （wm_user + 102)
private const max_path as long = 260
private type browseinfoa
howner as long
pidlroot as long
pszdisplayname as string
lpsztitle as string
ulflags as long
lpfn as long
lparam as long
iimage as long
end type
public enum bif
bif_returnonlyfsdirs = &h1 ' for finding a folder to start document searching
bif_dontgobelowdomain = &h2 ' for starting the find computer
bif_statustext = &h4 ' top of the dialog has 2 lines of text for browseinfo.lpsztitle and one line if
' this flag is set. passing the message bffm_setstatustexta to the hwnd can set the
' rest of the text. this is not used with bif_usenewui and browseinfo.lpsztitle gets
' all three lines of text.
bif_returnfsancestors = &h8
bif_editbox = &h10 ' add an editbox to the dialog
bif_validate = &h20 ' insist on valid result （or cancel)
bif_newdialogstyle = &h40 ' use the new dialog layout with the ability to resize
' caller needs to call oleinitialize（) before using this api
bif_usenewui = （bif_newdialogstyle or bif_editbox)
bif_browseincludeurls = &h80 ' allow urls to be displayed or entered. （requires bif_usenewui)
bif_uahint = &h100 ' add a ua hint to the dialog, in place of the edit box. may not be combined with bif_editbox
bif_nonewfolderbutton = &h200 ' do not add the "new folder " button to the dialog. only applicable with bif_newdialogstyle.
bif_notranslatetargets = &h400 ' don 't traverse target as shortcut
bif_browseforcomputer = &h1000 ' browsing for computers.
bif_browseforprinter = &h2000 ' browsing for printers
bif_browseincludefiles = &h4000 ' browsing for everything
bif_shareable = &h8000 ' sharable resources displayed （remote shares, requires bif_usenewui)
end enum
private declare function shbrowseforfoldera lib "shell32 " （lpbrowseinfo as browseinfoa) as long
private declare function shgetidlistfrompath lib "shell32 " alias "#162 " （byval szpath as string) as long
private declare function shgetpathfromidlista lib "shell32 " （byval pidl as long, byval pszpath as string) as long
private declare function sendmessage lib "user32 " alias "sendmessagea " （byval hwnd as long, byval wmsg as long, byval wparam as long, byval lparam as string) as long
private declare function setwindowtexta lib "user32 " （byval hwnd as long, byval lpstring as string) as long
private declare sub cotaskmemfree lib "ole32 " （byval pv as long)
private buffer as string * max_path
private m_dialogtitle as string
private m_startdir as string
private m_bnewui as boolean
public function browse（byval hwnd as long, optional ulflags as bif = bif_returnonlyfsdirs, optional byval sstartdir as string, optional byref sdisplayname as string, optional byval stitle as string, optional byval sdialogtitle as string, optional byval srootdir as string) as string
dim bia as browseinfoa
dim pidl as long
m_startdir = sstartdir
m_dialogtitle = sdialogtitle
m_bnewui = （ulflags and bif_newdialogstyle) = bif_newdialogstyle
with bia 'fill the browseinfo structure.
.howner = hwnd 'getdesktopwindow（) 'can be application or desktop hwnd
if lenb（srootdir) then 'get pidl of root folder
.pidlroot = shgetidlistfrompath（strconv（srootdir, vbunicode))
else
.pidlroot = 0& 'desktop folder is used
end if
.pszdisplayname = buffer 'display name
if lenb（stitle) then
.lpsztitle = stitle 'title text
end if
.ulflags = ulflags 'dialog type.
.lpfn = getaddressoffunction（addressof browsecallbackproc) 'callback
end with
pidl = shbrowseforfoldera（bia) 'show the dialog
sdisplayname = stripnull（bia.pszdisplayname)
browse = shgetpathfromidlist（pidl, buffer)
end function
private function browsecallbackproc（byval hwnd as long, byval umsg as long, byval lp as long, byval pdata as long) as long
dim sbuffer as string
on error resume next 'suggested by ms to prevent an error from
'propagating back into the calling process.
select case umsg
case bffm_initialized
sendmessage hwnd, bffm_setselectiona, 1, m_startdir
setwindowtexta hwnd, m_dialogtitle
case bffm_selchanged
sbuffer = space$（max_path)
if shgetpathfromidlista（byval lp, sbuffer) = 1 then
call sendmessage（hwnd, bffm_setstatustexta, 0, sbuffer)
end if
end select
browsecallbackproc = 0
end function
' this function allows you to assign a function pointer to a vaiable.
private function getaddressoffunction（add as long) as long
getaddressoffunction = add
end function
private function shgetpathfromidlist（byval pidl as long, byval pszpath as string) as string
if pidl = 0 then exit function
if shgetpathfromidlista（byval pidl, pszpath) then
shgetpathfromidlist = stripnull（pszpath)
end if
cotaskmemfree pidl
end function
private function stripnull（byval strin as string) as string
dim nul as long
' truncate input string at first null.
' if no nulls, perform ordinary trim.
nul = instr（1, strin, vbnullchar, vbbinarycompare)
select case nul
case is > 1
stripnull = left$（strin, nul - 1)
case 1
stripnull = " "
case 0
stripnull = trim$（strin)
end select
end function
'----------------------
| | |
|
