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

citykunan 发表于 2004-2-16 10:14:00

大家可以用一下吧

nxy_918 发表于 2004-2-16 18:46:00

能否讲讲起用途

myfreemind 发表于 2004-2-16 18:47:00

用用看！！

yfy2003 发表于 2004-2-16 19:21:00

先试试！

citykunan 发表于 2004-2-17 09:31:00

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

citykunan 发表于 2004-2-17 17:39:00

我觉得这个程序有点问题：

'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 发表于 2011-1-21 17:02:44

还好了，我的绑定会出错

页: [1]

明经CAD社区's Archiver

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