找回密码 注册 QQ登录
开思网工业级高精度在线3D打印服务

iCAx开思网

CAD/CAM/CAE/设计/模具 高清视频【积分说明】如何快速获得积分?在线3D打印服务,一键上传,自动报价 
查看: 9859|回复: 100
打印 上一主题 下一主题

[分享] 宏-装配树中打开选中文件所在的文件夹

  [复制链接]
跳转到指定楼层
1
发表于 2017-7-6 08:33:51 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
本帖最后由 lkai 于 2017-7-11 13:47 编辑

本宏功能:在装配树中打开选中文件所在的文件夹
编码SOLIDWORKS版本:SolidWorks2013
程序简陋,请高手完善、修正。
谢谢!


宏文件源码如下:
游客,如果您要查看本帖隐藏内容请回复



本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏7 分享淘帖 赞一下!赞一下!
推荐
发表于 2020-2-21 16:59:36 | 只看该作者
idonot 发表于 2020-1-4 21:43
一直在使用这个宏,可以在装配体以及零件、工程图等环境直接打开并定位文件位置。但一直也存在这 ...

经过不断尝试,发现问题可能出现在32位系统和64位系统上。把代码里面的Long改为Longlong以后,代码运行目前没有再出现问题。
推荐
发表于 2020-1-4 21:43:23 | 只看该作者
chaomogu 发表于 2018-1-30 09:52
测试了下,很好用。不选中,直接执行打开当前零部件。
有一点我觉得不好,就是同一个装配体打开同一个同一 ...

       一直在使用这个宏,可以在装配体以及零件、工程图等环境直接打开并定位文件位置。但一直也存在这个问题,每使用一次宏,就会打开一次文件夹,哪怕文件夹是相同的。程序内的
ret = Shell("explorer.exe /e,/select," & swModel.GetPathName, vbNormalFocus)语句会一次次的打开文件夹。任务栏内会有大量相同的文件夹。在网上查找VB是否有类似功能的代码,搜索到的大部分也是这句。
      黄天不负苦心人,不停的寻找下,终于找到另一种解法,可以实现“激活”文件夹,而不是重复打开。权限不够,无法上传原贴网址,百度搜索:《VB6调用API打开目标文件所在文件夹且选中目标文件》,作者:唐细刚。该段代码添加到楼主的宏中后,如果任务栏内没有文件夹打开,则新打开文件夹,如果已经有相同路径的文件夹打开,则激活该文件夹并重新定位选中文件。但实际使用时,在莫名情况下,总会出现错误,以下是截图。在网上查找错误原因,也几乎找不到原因。以下是修改的代码,鄙人初入宏门,代码不精。未经楼主以及“那段”代码作者的同意,擅自修改。如有不当,请多多包涵。也希望各路大神能够早点看到,指点迷津。
  1. ' ------------------------------------------------------------------------------
  2. ' OpenFileFolder
  3. ' OpenFileFolder.swp -  by Lunkay, Copyright 2017/6/29
  4. ' Contact:  313618812@qq.com (Lunkay)

  5. ' 功能:
  6. '       打开所选文件所在的文件夹,并选中目标。
  7. '
  8. ' 使用方法:
  9. ' 1、不选中任何文件,打开程序
  10. ' 2、选中装配体中的子件,打开程序
  11. ' -------------------------------------------------------------------------------

  12. '#If VBA7 Then
  13.      Private Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
  14. '#Else
  15.      'Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
  16. '#End If









  17. '''''''''''''''''''''''''''''''''''''''''''''''''''''''
  18. '''''''''''''''''''''''''''''''''''''''''''''''''''''''

  19. Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  20. Private Declare PtrSafe Function SHCreateFromPathW Lib "Shell32" Alias "ILCreateFromPathA" (ByVal lpFileName As String) As Long
  21. Private Declare PtrSafe Sub SHFree Lib "Shell32" Alias "ILFree" (ByVal lngPidl As Long)
  22. Private Declare PtrSafe Function SHOpenFolderAndSelectItems Lib "Shell32" ( _
  23.         ByVal pidlFolder As Long, _
  24.         ByVal cidl As Long, _
  25.         ByVal apidl As Long, _
  26.         ByVal dwFlags As Long) As Long
  27. '增加判断文件是否存在
  28. Private Const INVALID_HANDLE_VALUE = -1
  29. Private Const MAX_PATH = 260
  30. Private Type FILETIME
  31.     dwLowDateTime As Long
  32.     dwHighDateTime As Long
  33. End Type
  34. Private Type WIN32_FIND_DATA
  35.     dwFileAttributes As Long
  36.     ftCreationTime As FILETIME
  37.     ftLastAccessTime As FILETIME
  38.     ftLastWriteTime As FILETIME
  39.     nFileSizeHigh As Long
  40.     nFileSizeLow As Long
  41.     dwReserved0 As Long
  42.     dwReserved1 As Long
  43.     cFileName As String * MAX_PATH
  44.     cAlternate As String * 14
  45. End Type
  46. Private Declare PtrSafe Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
  47.     ByVal lpFileName As String, _
  48.     lpFindFileData As WIN32_FIND_DATA) As Long
  49. Private Declare PtrSafe Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long




  50. Dim swApp As SldWorks.SldWorks
  51. Dim swModel As SldWorks.ModelDoc2
  52. Dim swComp As SldWorks.Component2
  53. Dim swCompModel As SldWorks.ModelDoc2

  54. Dim sCompName As String

  55. Dim sMgr As SldWorks.SelectionMgr
  56. Dim sTyp As SwConst.swSelectType_e
  57. Dim iReply As String
  58. Dim swFrame As SldWorks.Frame ' declare status bar object


  59. Dim nRetval As Long
  60. Dim bRet                        As Boolean
  61. Dim nErrors As Long
  62. Dim nWarnings As Long
  63. Dim mlngSWFileType As Long
  64. Dim ret As Integer

  65. Dim FilePath As String

  66. Dim ml As String

  67. Dim keys(0 To 255) As Byte


  68. Const MINSELECTIONS = 1


  69. Private Function FileExists(ByVal lpFileName As String) As Boolean
  70.     Dim tpWFD As WIN32_FIND_DATA
  71.     Dim lngFile As Long
  72.     lngFile = FindFirstFile(lpFileName, tpWFD)
  73.     Sleep 25
  74.     FileExists = lngFile <> INVALID_HANDLE_VALUE
  75.     Sleep 25
  76.     If lngFile Then Call FindClose(lngFile)
  77.     Sleep 25
  78. End Function
  79. '调用成功返回 True,否则返回 False
  80. Public Function OpenFolderAndSetFileFocus(ByVal lpFileName As String) As Boolean
  81.     On Error Resume Next
  82.     Dim lngPidl As Long
  83.     Dim lngRet  As Long
  84.     Dim strFile As String
  85.     'strFile = Trim(lpFileName) 原来代码
  86.     strFile = lpFileName
  87.     If FileExists(strFile) = False Then Exit Function
  88.     lngPidl = SHCreateFromPathW(strFile & vbNullChar)
  89.     Sleep 25
  90.     If lngPidl <> 0 Then
  91.        lngRet = SHOpenFolderAndSelectItems(lngPidl, 0, 0, 0)
  92.        Sleep 25
  93.        If lngRet = 0 Then
  94.           OpenFolderAndSetFileFocus = True
  95.           Sleep 25
  96.        End If
  97.        Call SHFree(lngPidl)
  98.        Sleep 25
  99.     End If
  100. End Function





  101. Sub main()

  102.     Set swApp = Application.SldWorks
  103.   
  104.     ' get current model
  105.     Set swModel = swApp.ActiveDoc

  106.     ' check if a document is active
  107.     If swModel Is Nothing Then
  108.         MsgBox "请先打开一个需要打开其所在位置的文件!  ", vbCritical, "打开文件所在位置 By Lunkay"
  109.         End

  110.     End If

  111.     If swModel.GetType = 2 Then

  112.         Set sMgr = swModel.SelectionManager
  113.         'swModel.ClearSelection2 True
  114.         'MsgBox "请选择要打开位置的文件", vbCritical, "打开文件所在位置 By Lunkay"
  115.         
  116.         If sMgr.GetSelectedObjectCount = 1 Or sMgr.GetSelectedObjectCount = 0 Then
  117.             GetKeyboardState keys(0)

  118.             If keys(27) > 127 Then End
  119.             
  120.             GoTo AA
  121.             
  122.             
  123.         Else
  124.             MsgBox "请选择要打开位置的文件", vbCritical, "打开文件所在位置 By Lunkay"
  125.         
  126.         End If
  127.         
  128.         While sMgr.GetSelectedObjectCount < MINSELECTIONS
  129.         
  130.            
  131.         
  132.             DoEvents
  133.             GetKeyboardState keys(0)

  134.             If keys(27) > 127 Then End
  135.             
  136.         Wend
  137.         
  138. AA:        Set swComp = sMgr.GetSelectedObjectsComponent2(1)
  139.         
  140.         If swComp Is Nothing Then
  141.             
  142.             sCompName = swModel.GetPathName
  143.    
  144.         Else
  145.         
  146.             sCompName = swComp.GetPathName
  147.    
  148.         End If
  149.         
  150.         '''FilePath = Left(sCompName, InStrRev(sCompName, "") - 1)   '分解路径
  151.         '''FileName = swModel.GetTitle
  152.         
  153.         '''On Error Resume Next
  154.         
  155.         '''AppActivate FilePath
  156.         
  157.         
  158.         '''If Err.Number Then
  159.         
  160.         '''ret = Shell("explorer.exe /e,/select," & sCompName, vbNormalFocus)
  161.         
  162.         '''Else
  163.         
  164.         '''SendKeys FileName
  165.         '''End If
  166.         
  167.         OpenFolderAndSetFileFocus sCompName
  168.         
  169.         
  170.         swModel.ClearSelection2 True
  171.      
  172.     Else
  173.    
  174.         '''FilePath = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, "") - 1)   '分解路径
  175.         '''FileName = swModel.GetTitle
  176.         
  177.         '''FileName = Chr(34) + FileName + Chr(34)
  178.         
  179.         '''MsgBox FileName
  180.         
  181.         '''On Error Resume Next
  182.         
  183.         '''AppActivate FilePath
  184.         
  185.         
  186.         '''If Err.Number Then
  187.         
  188.         '''ret = Shell("explorer.exe /e,/select," & swModel.GetPathName, vbNormalFocus)
  189.         
  190.         '''Else
  191.         
  192.         '''SendKeys FileName
  193.         '''End If
  194.         'ret = Shell("explorer.exe /e,/select," & swModel.GetPathName, vbNormalFocus)
  195.         OpenFolderAndSetFileFocus swModel.GetPathName
  196.         
  197.         
  198.      
  199.         'ret = Shell("explorer.exe /e,/select," & swModel.GetPathName, vbNormalFocus)
  200.    

  201.       
  202.     swModel.ClearSelection2 True
  203.    
  204.     End If
  205.    
  206.     '    swFrame.SetStatusBarText "Done" ' feed done message to status bar

  207.     End

  208. End Sub
复制代码

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
2
发表于 2017-7-6 09:45:58 | 只看该作者
下载学习
3
发表于 2017-7-6 11:18:07 | 只看该作者
谢谢分享,学习一下。
4
发表于 2017-7-6 14:33:49 | 只看该作者
谢谢分享,学习一下。
5
发表于 2017-7-9 07:15:17 | 只看该作者
谢谢楼主的分享!!
6
发表于 2017-7-9 20:42:36 | 只看该作者
谢谢,楼主
7
发表于 2017-7-10 09:10:45 | 只看该作者
感謝分享
8
发表于 2017-7-11 19:58:02 | 只看该作者
高手,接着继续往下走

9
发表于 2017-7-12 06:16:52 | 只看该作者
谢谢分享
10
发表于 2017-7-18 18:12:25 | 只看该作者
好像有现成功能呀!

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

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

本版积分规则

3D打印手板模型快速制作服务,在线报价下单!

QQ 咨询|手机版|联系我们|iCAx开思网  

GMT+8, 2022-1-25 22:15 , Processed in 0.028432 second(s), 12 queries , Gzip On, Redis On.

Powered by Discuz! X3.3

© 2002-2022 www.iCAx.org

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