超级绑定，可以一起绑定（bind）很多图纸。

citykunan

大家可以用一下吧

nxy_918

能否讲讲起用途

myfreemind

用用看！！

yfy2003

先试试！

citykunan

用途我已经说了，可以把带有xref的很多图纸，一起把xref绑定进来。这样这些图纸就不会随着xref的变化而变化了。

citykunan

我觉得这个程序有点问题： 'Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub File1_Click() End Sub Private Sub cmdAddSource_Click()
Dim strfilepath As String If fileSource.ListCount > 0 Then

If Right(dirSource.Path, 1) = "\" Then
strfilepath = dirSource.Path + fileSource.FileName
Else
strfilepath = dirSource.Path + "\" + fileSource.FileName
End If

txtdwgsource.Text = strfilepath

End If
End Sub Private Sub cmdBind_Click() If InStr(txtNewPath, "\") = 0 Then MsgBox ("Please select the SaveAs path from the folder list above and click SaveAs button")
Exit Sub
End If
If lstBind.ListCount = 0 Then Exit Sub
End If
Dim ACADobj As AutoCAD.AcadApplication
Dim DOC As AutoCAD.AcadDocument
'Dim MSpace As AutoCAD.AcadPaperSpace
Dim Layouts As AutoCAD.AcadLayouts
Dim titleb As Object
Dim count As Integer Dim strdwgfile As String Dim result As String Dim i, j, ips As Integer
Dim strNewpath As String Dim iWidth, iHeight As Integer
result = strtextfile StatusBar1.SimpleText = "Bind is processing......" Set ACADobj = CreateObject("AutoCAD.Application") 'ACADobj.Documents.Open (strdwgfile)
'ACADobj.Documents.Add
ACADobj.Application.Visible = False
iWidth = ACADobj.Application.Width
iHeight = ACADobj.Application.Height
ACADobj.Application.Width = 1
ACADobj.Application.Height = 1 Set DOC = ACADobj.ActiveDocument
If Dir("c:\userdata\test.scr") = "test.scr" Then
Kill ("c:\userdata\test.scr")
End If Open CStr("c:\userdata\test.scr") For Output As #1 For i = 0 To lstBind.ListCount - 1 Print #1, "OPEN " & lstBind.List(i)
Print #1, ";U2D"
Print #1, "XREF"
Print #1, "B"
Print #1, "*"
Print #1, "SaveAs"
Print #1,
If Trim(txtNewPath.Text) <> "" And Len(txtNewPath.Text) > 0 Then
strdwgfile = lstBind.List(i)
Do While InStr(strdwgfile, "\") > 0
strdwgfile = Right(strdwgfile, (Len(strdwgfile) - InStr(strdwgfile, "\")))
Loop

Print #1, txtNewPath.Text + strdwgfile
If Dir(txtNewPath.Text + strdwgfile) = strdwgfile Then

If MsgBox("The File in " + txtNewPath.Text + strdwgfile + " exists, confirm overwrite?", vbOKCancel, "File Exist Alert") = vbOK Then

Kill (txtNewPath.Text + strdwgfile)
Else

Close #1
Kill ("c:\userdata\test.scr")
StatusBar1.SimpleText = "Bind is unsucessful."
DOC.Close (SaveChanges)
ACADobj.Application.Width = iWidth
ACADobj.Application.Height = iHeight
ACADobj.Quit
Exit Sub
End If
End If
Else

Print #1, lstBind.List(i)

End If

Print #1, "Close" Next i Close #1 ACADobj.Application.Visible = False DOC.SendCommand ("filedia") & Chr(13) & ("0") & Chr(13)
DOC.SendCommand ("scr") & Chr(13) & ("c:\userdata\test.scr") & Chr(13) For i = 1 To lstBind.ListCount / 2 + 1
Call Sleep(9000)
Next i
DOC.SendCommand ("filedia") & Chr(13) & ("1") & Chr(13)
DOC.Close (SaveChanges)
ACADobj.Application.Width = iWidth
ACADobj.Application.Height = iHeight ACADobj.Quit If Dir("c:\userdata\test.scr") = "test.scr" Then
Kill ("c:\userdata\test.scr")
End If StatusBar1.SimpleText = "Bind is successful."
'MsgBox ("Bind is ok") End Sub Private Sub Command1_Click()
If Len(dirSource.Path) > 0 Then

If Right(dirSource.Path, 1) = "\" Then
txtNewPath.Text = dirSource.Path
Else

txtNewPath.Text = dirSource.Path + "\"
End If

End If End Sub Private Sub dirSource_Change()
fileSource.Path = dirSource.Path
End Sub Private Sub drvSource_Change() dirSource.Path = drvSource.Drive End Sub Private Sub fileSource_DblClick()

Dim strfilepath As String If fileSource.ListCount > 0 Then

If Right(dirSource.Path, 1) = "\" Then
strfilepath = dirSource.Path + fileSource.FileName
Else
strfilepath = dirSource.Path + "\" + fileSource.FileName
End If

If isInBindList(strfilepath) = False Then
lstBind.AddItem (strfilepath)
Else
MsgBox ("The file " + strfilepath + " you select is already in the bind list")
Exit Sub
End If

End If End Sub Private Function isInBindList(strFileItem As String) As Boolean isInBindList = False
Dim i As Integer
Dim strfilepath As String

For i = 0 To lstBind.ListCount - 1

If lstBind.List(i) = strFileItem Then
isInBindList = True
End If

Next i End Function
Private Sub fileSource_KeyPress(KeyAscii As Integer) Dim i As Integer
Dim strfilepath As String

If KeyAscii = 13 Then

For i = 0 To fileSource.ListCount - 1

If fileSource.Selected(i) = True Then
If Right(dirSource.Path, 1) = "\" Then
strfilepath = dirSource.Path + fileSource.List(i)
Else
strfilepath = dirSource.Path + "\" + fileSource.List(i)
End If

If isInBindList(strfilepath) = False Then
lstBind.AddItem (strfilepath)
Else
MsgBox ("The file " + strfilepath + " you select is already in the bind list")
Exit Sub
End If
End If

Next i
End If
End Sub Private Sub lstBind_DblClick()

If lstBind.ListCount > 0 Then

lstBind.RemoveItem (lstBind.ListIndex)

End If
End Sub 我发现，当图纸比较大时，SLEEP 9 可能不够，这样CAD还在运行，同时还继续执行VB的后续命令，这样就出错了。有没有什么函数可以返回CAD执行的结果，如果测试到CAD还在运行，就不执行VB的以下的程序，直到推出CAD。 谢谢。

yanyanjun999

还好了，我的绑定会出错