当前位置：首页>Excel>SolidWorks*Excel+VBA-拉拉手搞一起

SolidWorks*Excel+VBA-拉拉手搞一起

2026-09-25 06:05:01

拉拉小手，说声你好，SW老登！

已关注

关注

重播分享赞

视频详情

你俩终于能搞一起了╮(︶﹏︶)╭

看码：

Sub OpenSwFiles() '打开文件Dim SwFname As String, k As Integer, Posn As Long, SwErr As LongDim SwApp As SldWorks.SldWorks, SwFileType As Byte, SwModel As ModelDoc2On Error Resume Next    Set SwApp = GetObject(, "SldWorks.Application")    If SwApp Is Nothing Then        MsgBox "请先打开SolidWorks！", vbExclamation, "不正经的机械仙人"        Exit Sub    End If    With ThisWorkbook.ActiveSheet    Application.StatusBar = "正在打开："        If myselcondi Then            For k = 1 To Selnumber                ProcessBarUpdater k, Selnumber, "正在打开：", "共" & Selnumber & "个，第" & k & "个 ..."                Posn = Selarray(k)                SwFname = .Cells(Posn, 2) & "\" & .Cells(Posn, 3) & .Cells(Posn, 4)                If Dir(SwFname) = "" Then                    .Cells(Posn, 1) = "文件不存在！"                Else                    If UCase(.Cells(Posn, 4)) = ".SLDPRT" Then                        SwFileType = swDocPART                    Else                        SwFileType = swDocASSEMBLY                    End If                    Set SwModel = SwApp.ActivateDoc2(SwFname, False, SwErr)                    If SwModel Is Nothing Then Set SwModel = SwApp.OpenDoc(SwFname, SwFileType)                    If SwModel Is Nothing Then                        .Cells(Posn, 1) = "重名或高版本，打开失败！"                    Else                        .Cells(Posn, 1) = "打开成功！"                    End If                    Set SwModel = Nothing                End If            Next          Else            MsgBox "未选择正确行，程序结束！", vbExclamation, "不正经的机械仙人"        End If    End With    Application.StatusBar = FalseEnd SubSub StartSwApp()'启动SW程序Dim SwApp As SldWorks.SldWorks, i As ByteDim SwRevision As String, SwOpenPath As StringOn Error Resume Next    Set SwApp = GetObject(, "SldWorks.Application")    If SwApp Is Nothing Then        If ThisWorkbook.Sheets("参数设置").Range("C2").Value = "" Then            Set SwApp = CreateObject("SldWorks.Application")            ThisWorkbook.Sheets("参数设置").Range("C2").Value = SwApp.RevisionNumber            SwApp.ExitApp        End If        SwRevision = Left(ThisWorkbook.Sheets("参数设置").Range("C2").Value, 2)        SwOpenPath = myregedit("HKEY_LOCAL_MACHINE\SOFTWARE\Classes\SldWorks.Application." & SwRevision & "\shell\open\command\", "", "", "R")        SwOpenPath = Left(SwOpenPath, InStrRev(SwOpenPath, " ") - 1)        Shell SwOpenPath, vbNormalFocus        Do Until Not SwApp Is Nothing '延迟等待            Set SwApp = GetObject(, "SldWorks.Application")            Sleep 300            i = i + 1            If i > 100 Then Exit Do        Loop        If SwApp Is Nothing Then MsgBox "SolidWorks程序启动失败！", vbCritical, "不正经的机械仙人"    Else        MsgBox "SolidWorks程序已运行！", vbExclamation, "不正经的机械仙人"    End If    Set SwApp = NothingEnd Sub

还没完，这三段是打工的：

Option ExplicitPublic Selarray As Variant, Selnumber As Integer '选择的行数Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)Function myselcondi() As Boolean '处理选择操作Dim MySelection() As IntegerDim i As Long, j As LongDim Selarea As Range, Selrange As Range    ReDim MySelection(1 To 1000) As Integer    On Error Resume Next    Err.Clear: j = 1000    Selnumber = 1    For Each Selarea In Selection.Areas        For Each Selrange In Selarea.Rows            If Not (Selrange.Hidden) And Selrange.Row > 2 Then                MySelection(Selnumber) = Selrange.Row                Selnumber = Selnumber + 1                If Selnumber > j - 2 Then                    j = j + 1000                    ReDim Preserve MySelection(1 To j)                End If            End If        Next    Next    Selnumber = Selnumber - 1    If Selnumber = 0 Then        myselcondi = False: Exit Function    End If    ReDim Preserve MySelection(1 To Selnumber) As Integer: Selarray = MySelection    For i = 1 To Selnumber        MySelection(i) = WorksheetFunction.Small(Selarray, i)    Next    Selarray = MySelection: myselcondi = TrueEnd FunctionFunction ProcessBarUpdater(CurNum As Integer, TotalNum As Integer, strTopic As String, endTopic As String)Dim intNumberOfall As Integer, intCurrentOfBars As Integer    intNumberOfall = 35 '总显示长度    intCurrentOfBars = (CurNum / TotalNum) * intNumberOfall    Application.StatusBar = strTopic & "「" & String(intCurrentOfBars, Chr(47)) & String(intNumberOfall - intCurrentOfBars, Chr(45)) & "」" & endTopicEnd FunctionFunction myregedit(mykey As String, myval As Variant, mytype As String, mymod As String) As VariantDim oWshell    Set oWshell = CreateObject("WScript.Shell")    Select Case True        Case mymod = "R" '读            myregedit = oWshell.RegRead(mykey)        Case mymod = "W" '写            oWshell.RegWrite mykey, myval, mytype        Case mymod = "D" '删            oWshell.RegDelete mykey    End Select    Set oWshell = NothingEnd Function

为什么启动SW的代码要搞这么复杂，还牵扯上了注册表？

当用CreateObject创建启动SW程序后，GetObject怎么也获取不到对象(งᵒ̌皿ᵒ̌)ง⁼³₌₃

只有通过正常打开exe程序，GetObject才能连接上。

什么鬼东西(｡･ˇ_ˇ･｡:)

所以，为了配合这个鬼东西，族谱还得单开一页存他户口╮( •́ω•̀ )╭

本文来自网友投稿或网络内容，如有侵犯您的权益请联系我们删除，联系邮箱：wyl860211@qq.com 。

SolidWorks*Excel+VBA-拉拉手搞一起

教育部高教司PPT | 深化高校教育综合改革提升拔尖创新人才自主培养质效

各类证明模板合计(Word)

SolidWorks*Excel+VBA-拉拉手搞一起

教育部高教司PPT | 深化高校教育综合改革 提升拔尖创新人才自主培养质效

各类证明模板合计(Word)

教育部高教司PPT | 深化高校教育综合改革提升拔尖创新人才自主培养质效