玩酷之家

 找回密码
 立即注册
查看: 451|回复: 0

VB6 选择文件夹路径

[复制链接]

98

主题

103

帖子

426

积分

中级会员

Rank: 3Rank: 3

积分
426
发表于 2020-2-26 15:22:03 | 显示全部楼层 |阅读模式
VB6 选择文件夹路径,含新建文件夹和不含新建文件夹。


  1. '---------------------------------------------------------------------------------------
  2. ' Module    : ModuleFile
  3. ' Author    : ROVAST
  4. ' Date      : 2014-4-22
  5. ' Purpose   : 文件相关操作模块
  6. ' Function  : 1、选取文件夹
  7. '---------------------------------------------------------------------------------------
  8.   
  9. Option Explicit
  10.   
  11. Private Type BrowseInfo
  12.     hWndOwner As Long
  13.     pIDLRoot As Long
  14.     pszDisplayName As Long
  15.     lpszTitle As Long
  16.     ulFlags As Long
  17.     lpfnCallback As Long
  18.     lParam As Long
  19.     iImage As Long
  20. End Type
  21. Const BIF_RETURNONLYFSDIRS = 1
  22. Const BIF_NEWDIALOGSTYLE = &H40
  23. Const BIF_EDITBOX = &H10
  24. Const BIF_USENEWUI = BIF_NEWDIALOGSTYLE Or BIF_EDITBOX
  25. Const MAX_PATH = 260
  26. Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
  27. Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
  28. Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
  29. Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
  30.   
  31.   
  32. '---------------------------------------------------------------------------------------
  33. ' Procedure : BrowseForFolder
  34. ' Author    : ROVAST
  35. ' Date      : 2014-4-22
  36. ' Purpose   : 选取文件夹(含新建文件夹指令) 返回BrowseForFolder
  37. '---------------------------------------------------------------------------------------
  38. '
  39. Public Function BrowseForFolder(Optional sTitle As String = "请选择文件夹") As String
  40.     Dim iNull As Integer, lpIDList As Long, lResult As Long
  41.     Dim sPath As String, udtBI As BrowseInfo
  42.   
  43.     With udtBI
  44.         .hWndOwner = 0 ' Me.hWnd
  45.         .lpszTitle = lstrcat(sTitle, "")
  46.         .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI
  47.     End With
  48.     lpIDList = SHBrowseForFolder(udtBI)
  49.     If lpIDList Then
  50.        sPath = String$(MAX_PATH, 0)
  51.         SHGetPathFromIDList lpIDList, sPath
  52.         CoTaskMemFree lpIDList
  53.        iNull = InStr(sPath, vbNullChar)
  54.         If iNull Then
  55.           sPath = Left$(sPath, iNull - 1)
  56.         End If
  57.     End If
  58.   
  59.     BrowseForFolder = sPath
  60. End Function
  61.   
  62.   
  63. '---------------------------------------------------------------------------------------
  64. ' Procedure : BrowseForFolder1
  65. ' Author    : ROVAST
  66. ' Date      : 2014-4-22
  67. ' Purpose   : 选取文件夹路径(不含新建文件夹) 返回BrowseForFolder1 字符串
  68. '---------------------------------------------------------------------------------------
  69. '
  70. Public Function BrowseForFolder1(Optional sTitle As String = "请选择文件夹") As String
  71.     Dim iNull As Integer, lpIDList As Long, lResult As Long
  72.     Dim sPath As String, udtBI As BrowseInfo
  73.   
  74.     With udtBI
  75.         .hWndOwner = 0 ' Me.hWnd
  76.         .lpszTitle = lstrcat(sTitle, "")
  77.         .ulFlags = BIF_RETURNONLYFSDIRS
  78.     End With
  79.     lpIDList = SHBrowseForFolder(udtBI)
  80.     If lpIDList Then
  81.        sPath = String$(MAX_PATH, 0)
  82.         SHGetPathFromIDList lpIDList, sPath
  83.         CoTaskMemFree lpIDList
  84.        iNull = InStr(sPath, vbNullChar)
  85.         If iNull Then
  86.           sPath = Left$(sPath, iNull - 1)
  87.         End If
  88.     End If
  89.   
  90.     BrowseForFolder1 = sPath
  91. End Function
复制代码

在主窗体中可以插入按钮。添加下述代码,其中前一个没有新建文件夹功能,后一个有新建文件夹功能

  1. Option Explicit

  2. Private Sub Command1_Click()
  3. Dim path1 As String
  4. path1 = BrowseForFolder
  5. MsgBox path1
  6. End Sub

  7. Private Sub Command2_Click()
  8. Dim path As String
  9. path = BrowseForFolder1
  10. MsgBox path
  11. End Sub

复制代码



最多选择要压缩的20张 PNG图像
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|Archiver|手机版|小黑屋|玩酷之家 ( 鄂ICP备14012049号-1 )|

GMT+8, 2020-8-4 15:56 , Processed in 1.060802 second(s), 18 queries .

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表