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

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

复制代码

作者: 风中de沙 时间: 2020-1-5 10:55

idonot 发表于 2020-1-4 21:43
一直在使用这个宏，可以在装配体以及零件、工程图等环境直接打开并定位文件位置。但一直也存在这 ...

我在win10系统下的sw2015试过好多次，没发现问题

作者: idonot 时间: 2020-1-5 18:54

风中de沙发表于 2020-1-5 10:55
我在win10系统下的sw2015试过好多次，没发现问题

我在两台电脑上分别试用自己修改的这个宏，一台win7，另一台win10。打开单个零件时基本不出现问题，但是打开大一点的装配体就会出现错误。有时候行，有时候不行，不规律。你再多试试看，期望能找到根本原因。

作者: idonot 时间: 2020-1-15 20:03
不要沉，求大神看一下

作者: idonot 时间: 2020-2-21 16:59

idonot 发表于 2020-1-4 21:43
一直在使用这个宏，可以在装配体以及零件、工程图等环境直接打开并定位文件位置。但一直也存在这 ...

经过不断尝试，发现问题可能出现在32位系统和64位系统上。把代码里面的Long改为Longlong以后，代码运行目前没有再出现问题。

作者: yh2010 时间: 2020-2-26 23:51

厉害支持一下

作者: 幻想柏拉图 时间: 2020-8-29 18:05
谢谢大神无私奉献！！！！！！！！！！！！！！！

作者: 285240263@qq.co 时间: 2020-12-17 14:52
看看源代码

作者: may0356 时间: 2020-12-22 15:10
多谢楼主的分享

作者: deihc851209 时间: 2021-3-26 10:39
可有最终的版本分享一下

作者: haitianyis 时间: 2021-4-2 17:15

谢谢分享，学习一下。

作者: wxf5888 时间: 2021-4-3 11:29
学习一下``````````````

作者: lxr8833661 时间: 2021-8-30 11:49
好东西学习学习

作者: hbhz520 时间: 2021-11-18 16:44
感谢分享

作者: 13717174595 时间: 2021-11-18 23:28
谢谢分享，看着挺好的。

作者: dreamsboy 时间: 2021-11-19 16:45
谢谢楼主分享，下载研究。

作者: yangcongs 时间: 2021-11-26 10:12
看着很好用拿来学习学习

作者: mifochen 时间: 2021-12-5 15:27
kankan

作者: wubing3708909 时间: 2021-12-8 11:41
学习下

作者: qzf1 时间: 2021-12-9 13:54

好好学习天天向上

作者: szat51980 时间: 2022-5-14 19:34
这是一个很实用的宏文件

欢迎光临 iCAx开思网 (https://www.icax.org/)