$PBExportHeader$w_getfolder.srw forward global type w_getfolder from window end type type lv_folders from listview within w_getfolder end type type tv_drives from treeview within w_getfolder end type type cb_ok from commandbutton within w_getfolder end type type st_folder from statictext within w_getfolder end type type st_1 from statictext within w_getfolder end type type cb_cancel from commandbutton within w_getfolder end type type filetime from structure within w_getfolder end type type win32_find_data from structure within w_getfolder end type type shfileinfo from structure within w_getfolder end type type share_info_1 from structure within w_getfolder end type end forward type filetime from structure unsignedlong dwlowdatetime unsignedlong dwhighdatetime end type type win32_find_data from structure unsignedlong dwfileattributes filetime ftcreationtime filetime ftlastaccesstime filetime ftlastwritetime unsignedlong nfilesizehigh unsignedlong nfilesizelow unsignedlong dwreserved0 unsignedlong dwreserved1 character cfilename[260] character calternatefilename[14] end type type shfileinfo from structure long hicon long iicon long dwattributes character szdisplayname[260] character sztypename[80] end type type share_info_1 from structure long shi1_netname long shi1_type long shi1_remark end type shared variables String ss_title end variables global type w_getfolder from window integer width = 2976 integer height = 1652 boolean titlebar = true string title = "Select Folder" windowtype windowtype = response! long backcolor = 67108864 string icon = "AppIcon!" boolean center = true lv_folders lv_folders tv_drives tv_drives cb_ok cb_ok st_folder st_folder st_1 st_1 cb_cancel cb_cancel end type global w_getfolder w_getfolder type prototypes Function long SHGetFolderPath ( & long hwnd, & ulong csidl, & long hToken, & ulong dwFlags, & Ref string pszPath & ) Library "shell32.dll" Alias For "SHGetFolderPathW" Function ulong SHGetFileInfo ( & string pszPath, & long dwFileAttributes, & Ref SHFILEINFO psfi, & long cbFileInfo, & long uFlags & ) Library "shell32.dll" Alias For "SHGetFileInfoW" Function ulong GetDriveType ( & string lpRootPathName & ) Library "kernel32.dll" Alias For "GetDriveTypeW" Function long FindFirstFile ( & string lpFileName, & Ref win32_find_data lpFindFileData & ) Library "kernel32.dll" Alias For "FindFirstFileW" Function boolean FindNextFile ( & long hFindFile, & Ref win32_find_data lpFindFileData & ) Library "kernel32.dll" Alias For "FindNextFileW" Function boolean FindClose ( & long hFindFile & ) Library "kernel32.dll" Alias For "FindClose" Function long NetShareEnum ( & string servername, & ulong level, & Ref long bufptr, & ulong prefmaxlen, & Ref ulong entriesread, & Ref ulong totalentries, & Ref ulong resume_handle & ) Library "netapi32.dll" Function long NetApiBufferFree ( & ulong Buffer & ) Library "netapi32.dll" Subroutine CopyMemory ( & Ref structure Destination, & long Source, & long Length & ) Library "kernel32.dll" Alias For "RtlMoveMemory" end prototypes type variables // Constants for GetDriveType Constant ULong DRIVE_UNKNOWN = 0 Constant ULong DRIVE_NO_ROOT_DIR = 1 Constant ULong DRIVE_REMOVABLE = 2 Constant ULong DRIVE_FIXED = 3 Constant ULong DRIVE_REMOTE = 4 Constant ULong DRIVE_CDROM = 5 Constant ULong DRIVE_RAMDISK = 6 // Constants for SHGetFolderPath Constant Long CSIDL_DESKTOP = 0 Constant Long CSIDL_PERSONAL = 5 Constant Long CSIDL_MYDOCUMENTS = CSIDL_PERSONAL Constant Long CSIDL_MYMUSIC = 13 Constant Long CSIDL_MYVIDEO = 14 Constant Long CSIDL_MYPICTURES = 39 String is_servers[] end variables forward prototypes public subroutine wf_populate_listview (string as_folder) public function string wf_getfolderpath (long al_csidl) public function boolean wf_checkbit (long al_number, unsignedinteger ai_bit) public function integer wf_getfiles (string as_filespec, ref string as_name[]) public subroutine wf_settitle (string as_title) public subroutine wf_addserver (string as_server) public subroutine wf_getshares (long al_handle, string as_server) public function integer wf_getdrives (ref string as_drive[], ref unsignedlong aul_type[], ref string as_typename[], ref string as_label[]) end prototypes public subroutine wf_populate_listview (string as_folder);ListViewItem llvi_item Integer li_idx, li_max String ls_name[] If Right(as_folder, 1) = ":" Then st_folder.text = as_folder + "\" Else st_folder.text = as_folder End If lv_folders.DeleteItems() // add up-arrow item llvi_item.Data = Left(as_folder, LastPos(as_folder, "\") - 1) llvi_item.Label = "Parent" llvi_item.PictureIndex = 2 lv_folders.AddItem(llvi_item) li_max = wf_GetFiles(as_folder, ls_name) For li_idx = 1 To li_max // add folder item llvi_item.Data = as_folder + "\" + ls_name[li_idx] llvi_item.Label = ls_name[li_idx] llvi_item.PictureIndex = 1 lv_folders.AddItem(llvi_item) Next end subroutine public function string wf_getfolderpath (long al_csidl);// This function returns the path to a shell folder. Constant Long SHGFP_TYPE_CURRENT = 0 String ls_path ls_path = Space(260) SHGetFolderPath(0, al_CSIDL, 0, SHGFP_TYPE_CURRENT, ls_path) Return ls_path end function public function boolean wf_checkbit (long al_number, unsignedinteger ai_bit);// This function determines if a certain bit is on or off within the number. If Int(Mod(al_number / (2 ^(ai_bit - 1)), 2)) > 0 Then Return True End If Return False end function public function integer wf_getfiles (string as_filespec, ref string as_name[]);// This function returns a list of folders. win32_find_data lstr_fd Boolean lb_Found, lb_Hidden, lb_System, lb_SubDir Integer li_file Long ll_handle String ls_filename // append filename pattern If Right(as_filespec, 1) = "\" Then as_filespec += "*.*" Else as_filespec += "\*.*" End If // find first file ll_Handle = FindFirstFile(as_filespec, lstr_fd) If ll_Handle < 1 Then Return -1 // loop through each file Do // add file to array ls_filename = String(lstr_fd.cFilename) If ls_filename = "." Or ls_filename = ".." Then Else // check for hidden attrib lb_Hidden = wf_checkbit(lstr_fd.dwFileAttributes, 2) lb_System = wf_checkbit(lstr_fd.dwFileAttributes, 3) lb_SubDir = wf_checkbit(lstr_fd.dwFileAttributes, 5) If ( lb_hidden Or lb_system ) Then Else If lb_SubDir Then li_file++ as_name[li_file] = ls_filename End If End If End If // find next file lb_Found = FindNextFile(ll_Handle, lstr_fd) Loop Until Not lb_Found // close find handle FindClose(ll_Handle) Return li_file end function public subroutine wf_settitle (string as_title);ss_title = as_title end subroutine public subroutine wf_addserver (string as_server);// add a server to the array Long ll_idx, ll_max ll_max = UpperBound(is_servers) For ll_idx = 1 To ll_max If Lower(as_server) = Lower(is_servers[ll_idx]) Then Return End If Next is_servers[ll_max + 1] = as_server end subroutine public subroutine wf_getshares (long al_handle, string as_server);Constant ULong NERR_Success = 0 Constant ULong MAX_PREFERRED_LENGTH = 4294967295 Constant ULong STYPE_DISKTREE = 0 TreeViewItem ltvi_item SHARE_INFO_1 lstr_info Long ll_result, ll_handle, ll_StructSize String ls_server, ls_netname ULong lul_entriesread, lul_index ULong lul_totalentries, lul_resume Long ll_bufptr SetPointer(HourGlass!) ll_StructSize = 12 ls_server = "\\" + as_server // get the network shares for the server ll_result = NetShareEnum(ls_server, 1, ll_bufptr, MAX_PREFERRED_LENGTH, & lul_entriesread, lul_totalentries, lul_resume) If ll_result = NERR_Success Then For lul_index = 0 To lul_entriesread - 1 // copy from memory to the structure CopyMemory(lstr_info, ll_bufptr + (ll_StructSize * lul_index), ll_StructSize) If lstr_info.shi1_type = STYPE_DISKTREE Then If lstr_info.shi1_netname > 0 Then ls_netname = String(lstr_info.shi1_netname, "address") End If choose case ls_netname case "print$" // skip case else // add to the treeview ltvi_item.Data = ls_server + "\" + ls_netname ltvi_item.Label = ls_netname ltvi_item.PictureIndex = 15 ltvi_item.SelectedPictureIndex = 15 ll_handle = tv_drives.InsertItemLast(al_handle, ltvi_item) end choose End If Next Else tv_drives.GetItem(al_handle, ltvi_item) ltvi_item.Children = False tv_drives.SetItem(al_handle, ltvi_item) End If NetApiBufferFree(ll_bufptr) end subroutine public function integer wf_getdrives (ref string as_drive[], ref unsignedlong aul_type[], ref string as_typename[], ref string as_label[]);// This function returns a list of disk drives with their type and volume label. Constant ULong SHGFI_DISPLAYNAME = 512 Constant ULong SHGFI_TYPENAME = 1024 SHFILEINFO lstr_sfi Integer li_idx, li_next ULong lul_type, lul_Attribs String ls_drive, ls_path For li_idx = 1 To 26 ls_drive = Char(li_idx + 64) + ":" ls_path = ls_drive + "\" lul_type = GetDriveType(ls_path) If lul_type = DRIVE_UNKNOWN Or & lul_type = DRIVE_NO_ROOT_DIR Then Else // add drive to output arrays li_next = UpperBound(as_drive) + 1 as_drive[li_next] = Left(ls_drive, 1) aul_type[li_next] = lul_type // get explorer display name SHGetFileInfo(ls_path, lul_Attribs, lstr_sfi, 352, SHGFI_DISPLAYNAME) as_label[li_next] = String(lstr_sfi.szDisplayName) // get explorer type name SHGetFileInfo(ls_path, lul_Attribs, lstr_sfi, 352, SHGFI_TYPENAME) as_typename[li_next] = String(lstr_sfi.szTypeName) End If Next Return li_next end function on w_getfolder.create this.lv_folders=create lv_folders this.tv_drives=create tv_drives this.cb_ok=create cb_ok this.st_folder=create st_folder this.st_1=create st_1 this.cb_cancel=create cb_cancel this.Control[]={this.lv_folders,& this.tv_drives,& this.cb_ok,& this.st_folder,& this.st_1,& this.cb_cancel} end on on w_getfolder.destroy destroy(this.lv_folders) destroy(this.tv_drives) destroy(this.cb_ok) destroy(this.st_folder) destroy(this.st_1) destroy(this.cb_cancel) end on event open;Constant UInt TVM_SETITEMHEIGHT = 4379 TreeViewItem ltvi_item Long ll_desktop, ll_thispc, ll_handle, ll_network Long ll_idx, ll_max, ll_len, ll_pos, ll_server String ls_default, ls_regkey, ls_value String ls_drive[], ls_typename[], ls_label[] String ls_server, ls_values[] ULong lul_type[] If ss_title = "" Then this.Title = "Browse for Folder" Else this.Title = ss_title End If // get the passed default ls_default = Message.StringParm If ls_default = "" Then ls_default = "C:" Else Message.StringParm = "" If Not DirectoryExists(ls_default) Then ls_default = "C:" End If End If // change the image height for spacing Send(Handle(tv_drives), TVM_SETITEMHEIGHT, 24, 0) // Insert: Desktop ltvi_item.Expanded = True ltvi_item.Data = wf_GetFolderPath(CSIDL_DESKTOP) ltvi_item.Label = "Desktop" ltvi_item.PictureIndex = 2 ltvi_item.SelectedPictureIndex = 2 ll_desktop = tv_drives.InsertItemLast(0, ltvi_item) ltvi_item.Expanded = True // Insert: This PC ltvi_item.Expanded = True ltvi_item.Data = "" ltvi_item.Label = "This PC" ltvi_item.PictureIndex = 1 ltvi_item.SelectedPictureIndex = 1 ll_thispc = tv_drives.InsertItemLast(ll_desktop, ltvi_item) ltvi_item.Expanded = False // Insert: Network ltvi_item.Expanded = False ltvi_item.Data = "" ltvi_item.Label = "Network" ltvi_item.PictureIndex = 14 ltvi_item.SelectedPictureIndex = 14 ll_network = tv_drives.InsertItemLast(ll_desktop, ltvi_item) // Insert: Desktop ltvi_item.Data = wf_GetFolderPath(CSIDL_DESKTOP) ltvi_item.Label = "Desktop" ltvi_item.PictureIndex = 2 ltvi_item.SelectedPictureIndex = 2 ll_handle = tv_drives.InsertItemLast(ll_thispc, ltvi_item) // Insert: Documents ltvi_item.Data = wf_GetFolderPath(CSIDL_MYDOCUMENTS) ltvi_item.Label = "Documents" ltvi_item.PictureIndex = 3 ltvi_item.SelectedPictureIndex = 3 ll_handle = tv_drives.InsertItemLast(ll_thispc, ltvi_item) // Insert: Downloads ls_regkey = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders" RegistryGet(ls_regkey, "{374DE290-123F-4565-9164-39C4925E467B}", RegString!, ls_value) If ls_value <> "" Then ltvi_item.Data = ls_value ltvi_item.Label = "Downloads" ltvi_item.PictureIndex = 4 ltvi_item.SelectedPictureIndex = 4 ll_handle = tv_drives.InsertItemLast(ll_thispc, ltvi_item) End If // Insert: Music ltvi_item.Data = wf_GetFolderPath(CSIDL_MYMUSIC) ltvi_item.Label = "Music" ltvi_item.PictureIndex = 5 ltvi_item.SelectedPictureIndex = 5 ll_handle = tv_drives.InsertItemLast(ll_thispc, ltvi_item) // Insert: Pictures ltvi_item.Data = wf_GetFolderPath(CSIDL_MYPICTURES) ltvi_item.Label = "Pictures" ltvi_item.PictureIndex = 6 ltvi_item.SelectedPictureIndex = 6 ll_handle = tv_drives.InsertItemLast(ll_thispc, ltvi_item) // Insert: Videos ltvi_item.Data = wf_GetFolderPath(CSIDL_MYVIDEO) ltvi_item.Label = "Videos" ltvi_item.PictureIndex = 7 ltvi_item.SelectedPictureIndex = 7 ll_handle = tv_drives.InsertItemLast(ll_thispc, ltvi_item) // add drives ll_max = wf_GetDrives(ls_drive, lul_type, ls_typename, ls_label) For ll_idx = 1 To ll_max ltvi_item.Data = ls_drive[ll_idx] + ":" ltvi_item.Label = ls_label[ll_idx] If ls_drive[ll_idx] = "C" Then ltvi_item.PictureIndex = 8 ltvi_item.SelectedPictureIndex = 8 Else choose case lul_type[ll_idx] case 2 // Removable Drive If Pos(Lower(ls_typename[ll_idx]), "floppy") > 0 Then ltvi_item.PictureIndex = 9 ltvi_item.SelectedPictureIndex = 9 Else ltvi_item.PictureIndex = 10 ltvi_item.SelectedPictureIndex = 10 End If case 4 // Network Drive ltvi_item.PictureIndex = 11 ltvi_item.SelectedPictureIndex = 11 // add server name to instance array ls_server = Mid(ls_label[ll_idx], Pos(ls_label[ll_idx], "\\")) ll_pos = Pos(ls_server, "\", 3) If ll_pos = 0 Then ll_pos = Pos(ls_server, ")", 3) End If ls_server = Mid(ls_server, 3, ll_pos - 3) wf_AddServer(ls_server) case 5 // CD-ROM Drive ltvi_item.PictureIndex = 12 ltvi_item.SelectedPictureIndex = 12 case 6 // RAM Disk ltvi_item.PictureIndex = 13 ltvi_item.SelectedPictureIndex = 13 case else // Hard Drive ltvi_item.PictureIndex = 10 ltvi_item.SelectedPictureIndex = 10 end choose End If ll_handle = tv_drives.InsertItemLast(ll_thispc, ltvi_item) Next // get recent servers ls_regkey = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\TypedPaths" RegistryValues(ls_regkey, ls_values) ll_max = UpperBound(ls_values) For ll_idx = 1 To ll_max RegistryGet(ls_regkey, ls_values[ll_idx], RegString!, ls_server) If Left(ls_server, 2) = "\\" Then // add server name to instance array ls_server = Mid(ls_server, Pos(ls_server, "\\")) + "\" ls_server = Mid(ls_server, 3, Pos(ls_server, "\", 3) - 3) wf_AddServer(ls_server) End If Next // add recent servers to network node ll_max = UpperBound(is_servers) If ll_max > 0 Then For ll_idx = 1 To ll_max ltvi_item.Children = True ltvi_item.Data = "" ltvi_item.Label = is_servers[ll_idx] ltvi_item.PictureIndex = 1 ltvi_item.SelectedPictureIndex = 1 ll_server = tv_drives.InsertItemLast(ll_network, ltvi_item) Next End If // populate listview on the right wf_populate_listview(ls_default) end event type lv_folders from listview within w_getfolder integer x = 1495 integer y = 192 integer width = 1399 integer height = 1156 integer taborder = 10 integer textsize = -9 integer weight = 400 fontcharset fontcharset = ansi! fontpitch fontpitch = variable! fontfamily fontfamily = swiss! string facename = "Segoe UI" long textcolor = 33554432 borderstyle borderstyle = stylelowered! listviewview view = listviewreport! long largepicturemaskcolor = 536870912 string smallpicturename[] = {"folder.ico","uparrow.ico"} long smallpicturemaskcolor = 536870912 long statepicturemaskcolor = 536870912 end type event constructor;this.AddColumn("Name", Left!, 1300) end event event doubleclicked;ListViewItem llvi_item String ls_folder If index > 0 Then this.GetItem(index, llvi_item) ls_folder = llvi_item.Data If ls_folder = "" Then Else wf_populate_listview(ls_folder) End If End If end event type tv_drives from treeview within w_getfolder integer x = 73 integer y = 192 integer width = 1399 integer height = 1156 integer taborder = 40 integer textsize = -9 integer weight = 400 fontcharset fontcharset = ansi! fontpitch fontpitch = variable! fontfamily fontfamily = swiss! string facename = "Segoe UI" long textcolor = 33554432 borderstyle borderstyle = stylelowered! boolean trackselect = true string picturename[] = {"thispc.ico","desktop.ico","documents.ico","downloads.ico","music.ico","pictures.ico","videos.ico","windrive.ico","floppy.ico","harddrive.ico","netdrive.ico","cdrom.ico","ramdisk.ico","network.ico","netfolder.ico"} long picturemaskcolor = 536870912 long statepicturemaskcolor = 536870912 end type event clicked;this.Event SelectionChanged(handle, handle) end event event selectionchanged;TreeViewItem ltvi_item If newhandle > 0 Then tv_drives.GetItem(newhandle, ltvi_item) If ltvi_item.Data = "" Then st_folder.text = "" lv_folders.DeleteItems() Else wf_populate_listview(ltvi_item.Data) End If End If end event event itempopulate;TreeViewItem ltvi_item this.GetItem(handle, ltvi_item) If ltvi_item.Level = 3 Then wf_GetShares(handle, ltvi_item.Label) End If end event type cb_ok from commandbutton within w_getfolder integer x = 2158 integer y = 1408 integer width = 334 integer height = 100 integer taborder = 20 integer textsize = -8 integer weight = 400 fontcharset fontcharset = ansi! fontpitch fontpitch = variable! fontfamily fontfamily = swiss! string facename = "Segoe UI" string text = "OK" end type event clicked;CloseWithReturn(Parent, st_folder.text) end event type st_folder from statictext within w_getfolder integer x = 261 integer y = 64 integer width = 2633 integer height = 108 integer textsize = -8 integer weight = 400 fontcharset fontcharset = ansi! fontpitch fontpitch = variable! fontfamily fontfamily = swiss! string facename = "Segoe UI" long textcolor = 33554432 long backcolor = 67108864 boolean focusrectangle = false end type type st_1 from statictext within w_getfolder integer x = 73 integer y = 64 integer width = 187 integer height = 68 integer textsize = -8 integer weight = 400 fontcharset fontcharset = ansi! fontpitch fontpitch = variable! fontfamily fontfamily = swiss! string facename = "Segoe UI" long textcolor = 33554432 long backcolor = 67108864 string text = "Folder:" boolean focusrectangle = false end type type cb_cancel from commandbutton within w_getfolder integer x = 2560 integer y = 1408 integer width = 334 integer height = 100 integer taborder = 30 integer textsize = -8 integer weight = 400 fontcharset fontcharset = ansi! fontpitch fontpitch = variable! fontfamily fontfamily = swiss! string facename = "Segoe UI" string text = "Cancel" boolean cancel = true end type event clicked;CloseWithReturn(Parent, "") end event
File: w_getfolder.srw
Size: 19735
Date: Tue, 11 Aug 2020 03:29:50 +0200
Size: 19735
Date: Tue, 11 Aug 2020 03:29:50 +0200
- window w_getfolder(srw)
- wf_addserver (string as_server)
- wf_checkbit (long al_number, unsignedinteger ai_bit) returns boolean
- wf_getdrives (ref string as_drive[], ref unsignedlong aul_type[], ref string as_typename[], ref string as_label[]) returns integer
- wf_getfiles (string as_filespec, ref string as_name[]) returns integer
- wf_getfolderpath (long al_csidl) returns string
- wf_getshares (long al_handle, string as_server)
- wf_populate_listview (string as_folder)
- wf_settitle (string as_title)
- listview lv_folders
- treeview tv_drives
- commandbutton cb_ok
- statictext st_folder
- statictext st_1
- commandbutton cb_cancel