lighttools batchmode 批处理vb程序代码

lighttools 连接代码：

 1 Private m_ltServer As LTAPI
 2 
 3 
 4 
 5 Public Function getLTAPIServer() As LTAPI
 6 If m_ltServer Is Nothing Then
 7     Dim lt As IUnknown
 8     Dim ltLoc As Locator
 9     Dim cmd As String
10     Set ltLoc = CreateObject("LTLocator.Locator")
11     ' to get a LightTools Server pointer, you need to know
12     ' the calling server process ID
13     ' if it is passed to this application via command line
14     ' in a shape of "-LTPID1234" (AddIn standard)
15     ' (1234 being hypothetical LightTools Process ID), do this
16     cmd = Command ' get command line
17     ' if command line is in the form of "-LTPID1234" you can
18     ' directly pass it to Locator
19     Set lt = ltLoc.GetLTAPIFromString(cmd)
20     'if the client code knows LT PID somehow, it could use the
21     ' GetLTAPI(pidNumber) interface
22     Set m_ltServer = lt
23     Set ltLoc = Nothing
24 End If
25 
26 Set getLTAPIServer = m_ltServer
27 End Function
28 Sub test2()
29 Dim lt As LTAPI
30 
31 Set lt = getLTAPIServer()
32 lt.Message ("Correct way of connecting to LightTools")
33 End Sub

窗体代码：

Option Explicit
Dim i As Integer
Dim j As Integer
Dim exist As Boolean

Private Sub cmdAddAll_Click()
'添加所有对象至Listbox
On Error Resume Next

For i = 0 To filList.ListCount - 1
    exist = False
    ' 排除重复对象
    For j = 0 To lstFileOnClosed.ListCount - 1
        If lstFileOnClosed.List(j) = DirList.Path & "\" & filList.List(i) Then
            exist = True
            Exit For
        End If
    Next j
    If exist = False Then
        lstFileOnClosed.AddItem DirList.Path & "\" & filList.List(i)
    End If
    
Next i
End Sub

Private Sub cmdAddSelect_Click()
'添加选择的对象至Listbox
On Error Resume Next
For i = 0 To filList.ListCount - 1
    exist = False
     ' 排除重复对象
    If filList.Selected(i) = True Then '判断对象是否被选中
    
        For j = 0 To lstFileOnClosed.ListCount - 1
            If lstFileOnClosed.List(j) = DirList.Path & "\" & filList.List(i) Then
                exist = True
                Exit For
            End If
        Next j
        
        If exist = False Then
        
            lstFileOnClosed.AddItem DirList.Path & "\" & filList.List(i)
        End If
        
    End If
Next i
End Sub

Private Sub cmdRemoveAll_Click()
'从listbox中移出所有的对象
  lstFileOnClosed.Clear
End Sub

Private Sub cmdRemoveSelect_Click()
'从listbox中移出选择的对象
On Error Resume Next
For i = 0 To lstFileOnClosed.ListCount - 1
  If lstFileOnClosed.Selected(i) = True Then
    lstFileOnClosed.RemoveItem (i)
  End If
Next i
End Sub

Private Sub Command1_Click()
'Debug.Print lstFileOnClosed.List(0)
'Debug.Print DirList.Path

Dim i As Integer
Dim sumok As Integer
Dim sumng As Integer
Dim datebegin As Date
Dim dateend As Date
Dim usetime As Date
sumok = 0
sumng = 0

App.OleRequestPendingMsgText = "模拟中，请等待！" '设置程序等待msg
App.OleServerBusyTimeout = 36000000 '设置程序等待时间单位ms,目前未10h
'排除未选择模拟文件的情况
If batchmode.lstFileOnClosed.ListCount = 0 Then
    batchmode.Text1.Text = "请选择要模拟的文件" & vbCrLf
    Exit Sub
End If
batchmode.Text1.Text = "模拟过程中请不要点击此窗体" & vbCrLf
For i = 0 To batchmode.lstFileOnClosed.ListCount - 1
    Dim lt As New LTAPI
    Dim FName As String
    Dim status As String
    datebegin = Now
    FName = batchmode.lstFileOnClosed.List(i)
    lt.SetOption "ShowDialogs", 0
    lt.SetOption "ShowFileDialogBox", 0
    lt.cmd "\VConsole" 'Note that this is case sensitive!
    lt.cmd "Open " & lt.Str(FName)
    lt.SetOption "ShowDialogs", 1
    lt.SetOption "ShowFileDialogBox", 1
    lt.cmd "\V3D"
    status = lt.cmd("BeginAllSimulations")
    dateend = Now
    usetime = dateend - datebegin
    If status = 0 Then
        batchmode.Text1.Text = batchmode.Text1.Text + " sim OK 用时" & usetime & " " & FName & vbCrLf
        sumok = sumok + 1
    Else
        batchmode.Text1.Text = batchmode.Text1.Text + " sim NG;错误代码：" & status & "用时" & usetime & " " & FName & vbCrLf
        sumng = sumng + 1
    End If
    lt.cmd "save"
    lt.cmd "close"

Next i
batchmode.Text1.Text = batchmode.Text1.Text + "所有模拟已经完成,其中" & sumok & "个模拟OK;其中" & sumng & "个模拟NG。"

End Sub

Private Sub DirList_Change()
'  更新文件列表框，使它与目录列表框保持同步。
    filList.Path = DirList.Path
End Sub
   
Private Sub DirList_LostFocus()
    DirList.Path = DirList.List(DirList.ListIndex)
End Sub
   
Private Sub DrvList_Change()
    On Error GoTo DriveHandler
    DirList.Path = DrvList.Drive
    Exit Sub
   
DriveHandler:
   DrvList.Drive = DirList.Path
    Exit Sub
  End Sub


Private Sub Form_Load()
'初始化FileListbox的格式及Drivelistbox的驱动盘
  filList.Pattern = "*.lts"
  DrvList.Drive = App.Path
  batchmode.Text1.Text = "欢迎使用此插件！" & vbCrLf
End Sub

然后生成为EXE格式，就可以进行使用。