LBdianziqianming/cadVb/code/vbproject_jk/Module1.bas

Attribute VB_Name = "Module1"
Option Explicit
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long




Public acadStarted As Boolean
Public acadApp As New ZcadApplication
Public acadDoc As ZcadDocument
Public Sub FinalRelease()
    If Not acadApp Is Nothing Then Set acadApp = Nothing

End Sub
Sub Main()
'MsgBox ("0000")

Dim myObj As ZcadObject
Dim a_strArgs() As String
Dim blnDebug As Boolean
Dim strFileName As String
Dim i As Integer
Dim dwgFile As String
Dim dataFile As String
Dim isMultiView As String, isMultiLayout As String, isMultiLayer As String, isMultiSheet As String, paperSize As String
Dim Line As Variant
Dim Values As Variant
Dim Value As Variant
Dim subvalue As Variant
Dim txtFileName As String
Dim Attrs As Variant
Dim J As Integer
Dim myReference As ZcadBlockReference
Dim myReference_1 As ZcadBlockReference



  
  txtFileName = ""
a_strArgs = Split(Command$, "#")
For i = LBound(a_strArgs) To UBound(a_strArgs)
    Select Case i
    Case 0:
    dwgFile = a_strArgs(i)
    'MsgBox dwgFile
    Case 1:
    txtFileName = a_strArgs(i)
    'MsgBox txtFileName
    End Select
Next

 'dwgFile = "C:\Users\Administrator\Desktop\vbproject_jk\A0-H.dwg"     '"D:\Work\xiya\cad.dwg"
'    txtFileName = "C:\Users\Administrator\Desktop\vbproject_jk\test.txt"
If txtFileName = "" Then
    Exit Sub
    'dwgFile = "C:\Users\Administrator\Desktop\vbproject\A0-H.dwg"     '"D:\Work\xiya\cad.dwg"
    'txtFileName = "C:\Users\Administrator\Desktop\vbproject\test.txt"
End If



On Error Resume Next
Set acadApp = GetObject(, "ZWCAD.Application")
If Err Then
    Set acadApp = CreateObject("ZWCAD.Application")
    acadStarted = False
    If Err Then
        'MsgBox Err.Description
        'Err.Description
        Exit Sub
    End If
End If

'MsgBox ("222")
Dim oldDoc As ZcadDocument
Dim Opened As Boolean
Opened = False
'acadApp.Visible = False
'MsgBox dwgFile

For Each oldDoc In acadApp.Documents
    'MsgBox oldDoc.FullName
    If oldDoc.FullName <> "" Then
        If InStr(LCase(dwgFile), LCase(oldDoc.FullName)) <> 0 Then
            'MsgBox oldDoc.FullName
            Opened = True
            oldDoc.Activate
           ' Set acadApp.ActiveDocument = oldDoc
            Exit For
        End If
    End If
Next
'MsgBox a_strArgs(0)
'Set acadDocs = acadApp.Documents
'MsgBox Barcode
'Set acadDoc = acadApp.Documents.Open("D:\Work\xincai\TEST.dwg")
 If Opened Then
 
  Set acadDoc = acadApp.ActiveDocument
 Else
 Set acadDoc = acadApp.Documents.Open(dwgFile)
    'Set acadDoc = acadApp.Documents.Open("D:\Work\xiya\cad.dwg")
 End If
'Call InsertBarcode(Barcode)
        'Set fs = CreateObject("Scripting.FileSystemObject")
        'Set WshShell = WScript.CreateObject("WScript.Shell")
 'Replace(txtFileName, Chr(34), "")
Open Replace(txtFileName, Chr(34), "") For Input As #1

        'Set txtFile = fs.OpenTextFile(txtFileName)
        'Line = txtFile.ReadAll()
        'txtFile.Close
        'Set Data = ReadObject(Line)
        'Call SplitStr(line, values)
 Line Input #1, Line
   ' MsgBox Line
        Values = Split(Line, "|")

'        For Each Value In Values
'            subvalue = Split(Value, "=")
'            'MsgBox subvalue(1)
'        Next
'MsgBox dwgFile
'MsgBox txtFileName
'MsgBox Line
Dim myFont As ZcadTextStyle
'Set myFont = acadDoc.TextStyles.Item("USER1")
'Set myFont = acadDoc.TextStyles.Add("USER1")
'myFont.fontFile = "c:\windows\fonts\stxinwei.ttf"
Dim acCurDb As ZcadDatabase


Dim blkInsPnt_1(0 To 2) As Double
blkInsPnt_1(0) = 0: blkInsPnt_1(1) = 0: blkInsPnt_1(2) = 0

myReference_1 = acadDoc.ModelSpace.InsertBlock(blkInsPnt_1, "D:\Siemens\Teamcenter14\CADMODEL\CADMODEL.dwg", 1#, 1#, 1#, 0)
myReference_1.Delete

For Each myObj In acadDoc.ModelSpace
    If myObj.ObjectName = "AcDbBlockReference" Then
        If InStr(myObj.Name, "KWC-") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "admin") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22><><EFBFBD><EFBFBD>ΰ") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22><><EFBFBD><EFBFBD>") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22><><EFBFBD><EFBFBD>") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22><><EFBFBD><EFBFBD>") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22><><EFBFBD>˽<EFBFBD>") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22><><EFBFBD><EFBFBD>ѩ") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22><>־<EFBFBD><D6BE>") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22><><EFBFBD><EFBFBD>") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22>Ĵ<EFBFBD><C4B4><EFBFBD>") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22><><EFBFBD><EFBFBD>") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22><><EFBFBD><EFBFBD>˹") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22><><EFBFBD><EFBFBD>ѧ") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "֣ˮ<D6A3><CBAE>") <> 0 Then
            myObj.Delete
        ElseIf InStr(myObj.Name, "<22>찬ά") <> 0 Then
            myObj.Delete
       End If
    End If
Next
 
 
 Dim delName
 Dim delSt
 delSt = 0
 
For Each myObj In acadDoc.ModelSpace

  ' If myObj.ObjectName = "AcDbBlockReference" Then
  '' MsgBox "ObjectName===" & myObj.ObjectName
   
  ' End If



    If myObj.ObjectName = "AcDbBlockReference" Then
   '' MsgBox "name===" & myObj.Name
    
       ' If InStr(myObj.Name, "XY_TITLE") <> 0 Then
       If InStr(myObj.Name, "XY_TITLE") Or InStr(myObj.Name, "XYA4") Or InStr(myObj.Name, "XYA3") Or InStr(myObj.Name, "XYA2") Or InStr(myObj.Name, "XYA1") Or InStr(myObj.Name, "XYA0") <> 0 Then
       ' If InStr(myObj.Name, "XY_MXB") <> 0 Then
            
            
         ''   MsgBox "jinlaile"
            
            
            Dim ref As ZcadBlockReference
            acCurDb = acadDoc.Database
            Set ref = myObj
            Dim P As Variant
            P = ref.InsertionPoint
            Dim blkInsPnt(0 To 2) As Double
            Dim userName As String
            Attrs = myObj.GetAttributes
            Dim x_s, y_s, z_s
             x_s = ref.XScaleFactor
            y_s = ref.YScaleFactor
            z_s = ref.ZScaleFactor
            
            
            
            
            For J = LBound(Attrs) To UBound(Attrs)
                
                For Each Value In Values
               
                    'If Value <> "" Then
                    'WScript.Echo  value
                        If Value <> "" Then
                             subvalue = Split(Value, "=")
                           
                       ''    MsgBox subvalue(0) & "<-subvalue"
                        ''   MsgBox Attrs(J).TagString & "<-Attrs"
                            If subvalue(0) = Attrs(J).TagString Then
                                userName = subvalue(1)
                                userName = Replace(userName, ".png", "")
                                userName = Replace(userName, "D:\\PICTURE\\", "KWC-")
                             ''   MsgBox "p->===========" & P(0)
                                'MsgBox "username" & userName
                                If delSt = 0 Then
                                  delName = delName & userName & "|"
                                End If
                                 'MsgBox "1111111111111"s
                                 'MsgBox subvalue(0)
                                If subvalue(0) = "<22><><EFBFBD><EFBFBD>" Then
                                
                                 
                                    blkInsPnt(0) = P(0) - 133 * x_s: blkInsPnt(1) = P(1) + 3 * y_s: blkInsPnt(2) = P(2)
                                    'blkInsPnt(0) = -283500.64: blkInsPnt(1) = -226500.98: blkInsPnt(2) = P(2)
                                    'MsgBox blkInsPnt(0)
                                    Set myReference = acadDoc.ModelSpace.InsertBlock(blkInsPnt, userName, x_s, y_s, z_s, 0)
                                   ' MsgBox "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>"
                                ElseIf subvalue(0) = "<22><><EFBFBD><EFBFBD>" Then
                                    blkInsPnt(0) = P(0) - 133 * x_s: blkInsPnt(1) = P(1) + 8 * y_s: blkInsPnt(2) = P(2)
                                    Set myReference = acadDoc.ModelSpace.InsertBlock(blkInsPnt, userName, x_s, y_s, z_s, 0)
                                ElseIf subvalue(0) = "<22><>׼" Then
                                    blkInsPnt(0) = P(0) - 133 * x_s: blkInsPnt(1) = P(1) - 2 * y_s: blkInsPnt(2) = P(2)
                                    Set myReference = acadDoc.ModelSpace.InsertBlock(blkInsPnt, userName, x_s, y_s, z_s, 0)
                                ElseIf subvalue(0) = "<22><><EFBFBD><EFBFBD>" Then
                                    blkInsPnt(0) = P(0) - 163 * x_s: blkInsPnt(1) = P(1) + 8 * y_s: blkInsPnt(2) = P(2)
                                    Set myReference = acadDoc.ModelSpace.InsertBlock(blkInsPnt, userName, x_s, y_s, z_s, 0)
                                ElseIf subvalue(0) = "<22><>ͼ" Then
                                    blkInsPnt(0) = P(0) - 163 * x_s: blkInsPnt(1) = P(1) + 3 * y_s: blkInsPnt(2) = P(2)
                                    Set myReference = acadDoc.ModelSpace.InsertBlock(blkInsPnt, userName, x_s, y_s, z_s, 0)
                                ElseIf subvalue(0) = "У<><D0A3>" Then
                                    blkInsPnt(0) = P(0) - 163 * x_s: blkInsPnt(1) = P(1) - 2 * y_s: blkInsPnt(2) = P(2)
                                    Set myReference = acadDoc.ModelSpace.InsertBlock(blkInsPnt, userName, x_s, y_s, z_s, 0)
                                ElseIf subvalue(0) = "<22><>׼<EFBFBD><D7BC>" Then
                                    blkInsPnt(0) = P(0) - 163 * x_s: blkInsPnt(1) = P(1) - 7 * y_s: blkInsPnt(2) = P(2)
                                    Set myReference = acadDoc.ModelSpace.InsertBlock(blkInsPnt, userName, x_s, y_s, z_s, 0)
                                    'Set myReference = acadDoc.ModelSpace.InsertBlock(blkInsPnt, userName, 1#, 1#, 1#, 0)
                                    
                                Else
                                    Attrs(J).TextString = userName
                                End If
                               
                                
'                                acadDoc.ModelSpace.InsertBlock(insertionPnt, "bbb.dwg", 1#, 1#, 1#, 0)
                               
                                If InStr(subvalue(0), "<22><>׼<EFBFBD><D7BC><EFBFBD><EFBFBD>") <> 0 Then
                                Attrs(J).TextString = subvalue(1)
                                Else
                                Attrs(J).StyleName = "USER1"
                                End If
                                'MsgBox subvalue(1)
                                Attrs(J).Update
                            End If
                        End If
                    'End If
                Next
            Next
            'Exit For
            delSt = 1
        End If
    End If

Next


'MsgBox delName
Values = Split(delName, "|")


Dim ttObj
Dim doDel
doDel = 0
For Each ttObj In acadDoc.Database.Blocks
    If ttObj.ObjectName = "AcDbBlockTableRecord" Then
         If InStr(ttObj.Name, "jk_") <> 0 Then
            doDel = 0
            
            For Each Value In Values
                If Value <> "" Then
                    If Value = ttObj.Name Then
                       doDel = 1
                    End If
                End If
            Next
            
            If doDel = 0 Then
                'MsgBox "DEL =>" & ttObj.Name
                ttObj.Delete
                
            End If
        End If
    End If
Next

acadDoc.Save

acadDoc.Close (False)




Close #1





If Not acadStarted Then
'acadApp.Quit
End If


'FinalRelease
End Sub