田草博客

互联网田草博客


网友交流QQ群:11740834 需注明申请加入原因

微信 公众号:ByCAD

邮箱:tiancao1001x126.com
ByCAD,微信公众号
首页 | 普通 | 电脑 | AutoCAD | VB/VB.NET | FLash | 结构 | 建筑 | 电影 | BIM | 规范 | 软件 | ID
-随机-|-分布-
-博客论坛-|-﨣﨤﨧﨨-
-网站导航-|-规范下载-
-BelovedFLash欣赏-

用户登陆
用户:
密码:
 

站点日历
73 2024 - 6 48
      1
2345678
9101112131415
16171819202122
23242526272829
30


站点统计

最新评论



得到鼠标移动到地方的RGB颜色 一种旋转线条的算法
未知 VB6选择文件夹的时候有新建文件夹按钮   [ 日期:2007-03-20 ]   [ 来自:本站原创 ]  HTML
VB6选择文件夹的时候有新建文件夹按钮


程序代码:[ 复制代码到剪贴板 ]
Option Explicit
Public Type SHFILEOPSTRUCT

     hwnd As Long
     wFunc As Long
     pFrom As String
     pTo As String
     fFlags As Integer
     fAborted As Boolean
     hNameMaps As Long
     sProgress As String

End Type
Public Type BrowseInfo

     hwndOwner As Long
     pIDLRoot As Long
     pszDisplayName As String
     lpszTitle As String
     ulFlags As Long
     lpfnCallback As Long
     lParam As Long
     iImage As Long

End Type
Global FileDestination As String
Public Const BIF_BROWSEINCLUDEURLS = 128
Public Const BIF_NEWDIALOGSTYLE = 64
Public Const BIF_RETURNONLYFSDIRS = 1
Public Const BIF_STATUSTEXT = 4
Public Const BIF_USENEWUI = 64
Public Const MAX_PATH = 260

Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Public Declare Function SHBrowseForFolder Lib "shell32" _
     (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" _
     (ByVal pidList As Long, ByVal lpBuffer 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

Public Const FO_COPY = &H2
Public Const FO_DELETE = &H3
Public Const FO_MOVE = &H1
Public Const FO_RENAME = &H4
Public Const FOF_ALLOWUNDO = &H40
Public Const FOF_CONFIRMMOUSE = &H2
Public Const FOF_FILESONLY = &H80                  '  on *.*, do only files
Public Const FOF_MULTIDESTFILES = &H1
Public Const FOF_NOCONFIRMATION = &H10             '  Don't prompt the user.
Public Const FOF_NOCONFIRMMKDIR = &H200            '  don't confirm making any needed dirs
Public Const FOF_RENAMEONCOLLISION = &H8
Public Const FOF_SILENT = &H4                      '  don't create progress/report
Public Const FOF_SIMPLEPROGRESS = &H100            '  means don't show names of files
Public Const FOF_WANTMAPPINGHANDLE = &H20          '  Fill in SHFILEOPSTRUCT.hNameMappings

Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)

Public Declare Function SHFileOperation Lib "shell32.dll" Alias _
     "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Dim StartFolder As String


Public Function ShellRename(ParamArray vntFileName() As Variant) As Long


     Dim i As Integer
     Dim sFileNames As String
     Dim Dick As String
     Dim SHFileOp As SHFILEOPSTRUCT

     For i = LBound(vntFileName) To UBound(vntFileName)

          sFileNames = sFileNames & vntFileName(i) & vbNullChar

     Next
     sFileNames = sFileNames & vbNullChar
     Dick = FileDestination
     With SHFileOp

          .wFunc = &H4
          .pFrom = sFileNames
          .fFlags = FOF_ALLOWUNDO
          .pTo = Dick
     End With

     ShellRename = SHFileOperation(SHFileOp)


End Function


Public Function ShellCopy(ParamArray vntFileName() As Variant) As Long


     Dim i As Integer
     Dim sFileNames As Variant
     Dim Dick As String
     Dim SHFileOp As SHFILEOPSTRUCT

     For i = LBound(vntFileName) To UBound(vntFileName)

          sFileNames = sFileNames & vntFileName(i) & vbNullChar

     Next
     sFileNames = sFileNames & vbNullChar
     Dick = FileDestination
     With SHFileOp

          .wFunc = &H2
          .pFrom = sFileNames
          .fFlags = FOF_ALLOWUNDO
          .pTo = Dick
     End With

     ShellCopy = SHFileOperation(SHFileOp)


End Function


Public Function ShellMove(ParamArray vntFileName() As Variant) As Long


     Dim i As Integer
     Dim sFileNames As Variant
     Dim Dick As String
     Dim SHFileOp As SHFILEOPSTRUCT

     For i = LBound(vntFileName) To UBound(vntFileName)

          sFileNames = sFileNames & vntFileName(i) & vbNullChar

     Next
     sFileNames = sFileNames & vbNullChar
     Dick = FileDestination
     With SHFileOp

          .wFunc = &H1
          .pFrom = sFileNames
          .fFlags = FOF_ALLOWUNDO
          .pTo = Dick
     End With

     ShellMove = SHFileOperation(SHFileOp)


End Function


Public Function ShellDelete(ParamArray vntFileName() As Variant) As Long


     Dim i As Integer
     Dim sFileNames As String
     Dim SHFileOp As SHFILEOPSTRUCT

     For i = LBound(vntFileName) To UBound(vntFileName)

          sFileNames = sFileNames & vntFileName(i) & vbNullChar

     Next
     sFileNames = sFileNames & vbNullChar

     With SHFileOp

          .wFunc = FO_DELETE
          .pFrom = sFileNames
          .fFlags = FOF_ALLOWUNDO

     End With

     ShellDelete = SHFileOperation(SHFileOp)


End Function


Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String, Optional sStartFolder) As String


     Dim iNull As Integer
     Dim lpIDList As Long
     Dim lResult As Long
     Dim sPath As String
     Dim udtBI As BrowseInfo

     With udtBI

          .hwndOwner = hwndOwner
          .lpszTitle = sPrompt
          .ulFlags = BIF_BROWSEINCLUDEURLS Or BIF_NEWDIALOGSTYLE Or BIF_RETURNONLYFSDIRS Or BIF_STATUSTEXT Or BIF_USENEWUI
          If Not IsMissing(sStartFolder) Then
               StartFolder = sStartFolder & vbNullChar
               .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)
          End If

     End With

     lpIDList = SHBrowseForFolder(udtBI)
     If lpIDList Then

          sPath = String$(MAX_PATH, 0)
          lResult = SHGetPathFromIDList(lpIDList, sPath)
          CoTaskMemFree lpIDList
          iNull = InStr(sPath, vbNullChar)
          If iNull Then

               sPath = Left$(sPath, iNull - 1)

          End If

     End If

     BrowseForFolder = sPath


End Function

Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
   On Error Resume Next
   Dim lpIDList As Long
   Dim ret As Long
   Dim sBuffer As String
   Select Case uMsg
       Case BFFM_INITIALIZED
           SendMessage hwnd, BFFM_SETSELECTION, 1, StartFolder
       Case BFFM_SELCHANGED
           sBuffer = Space(MAX_PATH)
           ret = SHGetPathFromIDList(lp, sBuffer)
           If ret = 1 Then
               SendMessage hwnd, BFFM_SETSTATUSTEXT, 0, sBuffer
           End If
   End Select
   BrowseCallbackProc = 0
End Function

Private Function GetAddressofFunction(add As Long) As Long
    GetAddressofFunction = add
End Function



按此在新窗口打开图片


示例: 


点击下载此文件

[本日志由 tiancao1001 于 2018-07-27 08:31 PM 编辑]


暂时没有评论
发表评论 - 不要忘了输入验证码哦!
作者: 用户:  密码:   注册? 验证:  防止恶意留言请输入问题答案:2*2=?  
评论:

禁止表情
禁止UBB
禁止图片
识别链接
识别关键字

字体样式 文字大小 文字颜色
插入粗体文本 插入斜体文本 插入下划线
左对齐 居中对齐 右对齐
插入超级链接 插入邮件地址 插入图像
插入 Flash 插入代码 插入引用
插入列表 插入音频文件 插入视频文件
插入缩进符合
点击下载按钮 下标 上标
水平线 简介分割标记
表  情
 
Tiancao Blog All Rights Reserved 田草博客 版权所有
Copyright ©