宏-装配树中打开选中文件所在的文件夹

只看该作者 · 发表于 2017-7-6 08:33:51

本帖最后由 lkai 于 2017-7-11 13:47 编辑

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

宏文件源码如下：

游客，如果您要查看本帖隐藏内容请回复

只看该作者 · 发表于 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打开目标文件所在文件夹且选中目标文件》，作者：唐细刚。该段代码添加到楼主的宏中后，如果任务栏内没有文件夹打开，则新打开文件夹，如果已经有相同路径的文件夹打开，则激活该文件夹并重新定位选中文件。但实际使用时，在莫名情况下，总会出现错误，以下是截图。在网上查找错误原因，也几乎找不到原因。以下是修改的代码，鄙人初入宏门，代码不精。未经楼主以及“那段”代码作者的同意，擅自修改。如有不当，请多多包涵。也希望各路大神能够早点看到，指点迷津。

' ------------------------------------------------------------------------------
' OpenFileFolder
' OpenFileFolder.swp - by Lunkay, Copyright 2017/6/29
' Contact: 313618812@qq.com (Lunkay)
' 功能：
' 打开所选文件所在的文件夹，并选中目标。
'
' 使用方法：
' 1、不选中任何文件，打开程序
' 2、选中装配体中的子件，打开程序
' -------------------------------------------------------------------------------
'#If VBA7 Then
Private Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
'#Else
'Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
'#End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function SHCreateFromPathW Lib "Shell32" Alias "ILCreateFromPathA" (ByVal lpFileName As String) As Long
Private Declare PtrSafe Sub SHFree Lib "Shell32" Alias "ILFree" (ByVal lngPidl As Long)
Private Declare PtrSafe Function SHOpenFolderAndSelectItems Lib "Shell32" ( _
ByVal pidlFolder As Long, _
ByVal cidl As Long, _
ByVal apidl As Long, _
ByVal dwFlags As Long) As Long
'增加判断文件是否存在
Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare PtrSafe Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare PtrSafe Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swComp As SldWorks.Component2
Dim swCompModel As SldWorks.ModelDoc2
Dim sCompName As String
Dim sMgr As SldWorks.SelectionMgr
Dim sTyp As SwConst.swSelectType_e
Dim iReply As String
Dim swFrame As SldWorks.Frame ' declare status bar object
Dim nRetval As Long
Dim bRet As Boolean
Dim nErrors As Long
Dim nWarnings As Long
Dim mlngSWFileType As Long
Dim ret As Integer
Dim FilePath As String
Dim ml As String
Dim keys(0 To 255) As Byte
Const MINSELECTIONS = 1
Private Function FileExists(ByVal lpFileName As String) As Boolean
Dim tpWFD As WIN32_FIND_DATA
Dim lngFile As Long
lngFile = FindFirstFile(lpFileName, tpWFD)
Sleep 25
FileExists = lngFile <> INVALID_HANDLE_VALUE
Sleep 25
If lngFile Then Call FindClose(lngFile)
Sleep 25
End Function
'调用成功返回 True,否则返回 False
Public Function OpenFolderAndSetFileFocus(ByVal lpFileName As String) As Boolean
On Error Resume Next
Dim lngPidl As Long
Dim lngRet As Long
Dim strFile As String
'strFile = Trim(lpFileName) 原来代码
strFile = lpFileName
If FileExists(strFile) = False Then Exit Function
lngPidl = SHCreateFromPathW(strFile & vbNullChar)
Sleep 25
If lngPidl <> 0 Then
lngRet = SHOpenFolderAndSelectItems(lngPidl, 0, 0, 0)
Sleep 25
If lngRet = 0 Then
OpenFolderAndSetFileFocus = True
Sleep 25
End If
Call SHFree(lngPidl)
Sleep 25
End If
End Function
Sub main()
Set swApp = Application.SldWorks
' get current model
Set swModel = swApp.ActiveDoc
' check if a document is active
If swModel Is Nothing Then
MsgBox "请先打开一个需要打开其所在位置的文件！ ", vbCritical, "打开文件所在位置 By Lunkay"
End
End If
If swModel.GetType = 2 Then
Set sMgr = swModel.SelectionManager
'swModel.ClearSelection2 True
'MsgBox "请选择要打开位置的文件", vbCritical, "打开文件所在位置 By Lunkay"
If sMgr.GetSelectedObjectCount = 1 Or sMgr.GetSelectedObjectCount = 0 Then
GetKeyboardState keys(0)
If keys(27) > 127 Then End
GoTo AA
Else
MsgBox "请选择要打开位置的文件", vbCritical, "打开文件所在位置 By Lunkay"
End If
While sMgr.GetSelectedObjectCount < MINSELECTIONS
DoEvents
GetKeyboardState keys(0)
If keys(27) > 127 Then End
Wend
AA: Set swComp = sMgr.GetSelectedObjectsComponent2(1)
If swComp Is Nothing Then
sCompName = swModel.GetPathName
Else
sCompName = swComp.GetPathName
End If
'''FilePath = Left(sCompName, InStrRev(sCompName, "") - 1) '分解路径
'''FileName = swModel.GetTitle
'''On Error Resume Next
'''AppActivate FilePath
'''If Err.Number Then
'''ret = Shell("explorer.exe /e,/select," & sCompName, vbNormalFocus)
'''Else
'''SendKeys FileName
'''End If
OpenFolderAndSetFileFocus sCompName
swModel.ClearSelection2 True
Else
'''FilePath = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, "") - 1) '分解路径
'''FileName = swModel.GetTitle
'''FileName = Chr(34) + FileName + Chr(34)
'''MsgBox FileName
'''On Error Resume Next
'''AppActivate FilePath
'''If Err.Number Then
'''ret = Shell("explorer.exe /e,/select," & swModel.GetPathName, vbNormalFocus)
'''Else
'''SendKeys FileName
'''End If
'ret = Shell("explorer.exe /e,/select," & swModel.GetPathName, vbNormalFocus)
OpenFolderAndSetFileFocus swModel.GetPathName
'ret = Shell("explorer.exe /e,/select," & swModel.GetPathName, vbNormalFocus)
swModel.ClearSelection2 True
End If
' swFrame.SetStatusBarText "Done" ' feed done message to status bar
End
End Sub

复制代码

只看该作者 · 发表于 2017-7-6 09:45:58

下载学习

只看该作者 · 发表于 2017-7-6 11:18:07

谢谢分享，学习一下。

只看该作者 · 发表于 2017-7-6 14:33:49

谢谢分享，学习一下。

只看该作者 · 发表于 2017-7-9 07:15:17

谢谢楼主的分享！！

只看该作者 · 发表于 2017-7-9 20:42:36

谢谢，楼主

只看该作者 · 发表于 2017-7-10 09:10:45

感謝分享

只看该作者 · 发表于 2017-7-11 19:58:02

高手，接着继续往下走

只看该作者 · 发表于 2017-7-12 06:16:52

谢谢分享

只看该作者 · 发表于 2017-7-18 18:12:25

好像有现成功能呀！

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

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源