' Export all selected documents as PDFs:

Sub Action(Query, QueryBrowser)

	Set pdfexp = CreateObject("Comos.PDFExport.PDFExport")
  Set SelObjs = QueryBrowser.SelectedObjects
  strPath = SelectFolder( "" )
  For i = 1 To SelObjs.Count
    Set ObjItem = SelObjs.Item(i)
    If Not ObjItem Is Nothing Then
    	Set objdoc = ObjItem
    	DocRev = ""
    	EngNo = ""
    	If Not objdoc.spec("Y00T00263.Y00A02655") Is Nothing Then
				Set EngNoAtt = objdoc.spec("Y00T00263.Y00A02655")
				EngNo = EngNoAtt.DisplayValue
				If EngNo = "" Then
					EngNo = objdoc.Label
				End If
			End If
			If Not objdoc.LastReleasedRevision Is Nothing Then
				DocRev = objdoc.LastReleasedRevision.Label
			Else
				DocRev = "PRE"
			End If
			DocFile = strPath & "\" & EngNo & "_" & DocRev & ".pdf"
			Set docs = objdoc
			If Not pdfexp Is Nothing Then
				pdfexp.DoIntelligentExport = TRUE
				pdfexp.DoIntelligentExportDocuments = False
				pdfexp.DoIntelligentExportLocation = False
				pdfexp.DoIntelligentExportUnit = True
				pdfexp.NavigatorText = False
				pdfexp.SilentMode = TRUE
				pdfexp.Export DocFile, docs, Project.WorkSet
			End If
    End If
  Next
End Sub

Function SelectFolder(myStartFolder)
	SelectFolder = vbNull
	Set objShell  = CreateObject( "Shell.Application" )
	Set objFolder = objShell.BrowseForFolder( 0, "Select Folder", 0, myStartFolder )
	If IsObject(objfolder) Then 
		SelectFolder = objFolder.Self.Path
	End If
End Function

Sub Action(Query, QueryBrowser)
  For i = 1 To Query.RowCount
  	Set CellPipe = Query.Cell(i, "Object")
    Set CellStart = Query.Cell(i, "Start")
    Set CellEnd = Query.Cell(i, "End")
    If (Not CellStart Is Nothing) And (Not CellEnd Is Nothing) Then
      Set ObjStart = CellStart.Object
      Set ObjEnd = CellEnd.Object
      Set ObjPipe = CellPipe.Object
      If (Not ObjStart Is Nothing) And (Not ObjEnd Is Nothing) Then
      	ValueStartEnd = Split(GetStartEndPipe(ObjPipe),"@")
        ObjStart.Value = ValueStartEnd(0)
        ObjEnd.Value = ValueStartEnd(1)
      End If
    End If
  Next
  QueryBrowser.RefreshRows
  ' or for complete Refresh:
   Query.Refresh
   QueryBrowser.Refresh
End Sub

Sub CreateSearchCondition(sm, logicalOperator, numberOfOpeningParentheses, attributeType, attribute, comparisonOperator, value, numberOfClosingParentheses)
    Set cond = sm.GetSearchCondition
    cond.LogicalOperator = logicalOperator
    cond.NumberOfOpeningParentheses = numberOfOpeningParentheses
    cond.AttributeType = attributeType
    cond.Attribute = attribute
    cond.ComparisonOperator = comparisonOperator
    cond.Value = value
    cond.NumberOfClosingParentheses = numberOfClosingParentheses
    sm.SearchConditions.Add cond
End Sub

Function GetStartEndPipe(Pipe)
Set searchManager = Pipe.WorkSet.GetSearchManager
Set rootObjects = searchManager.RootObjects
rootObjects.add Pipe
searchManager.SystemType = 10
searchManager.IsUserAbortAllowed = true
CreateSearchCondition searchmanager, "", 0, "PROPERTY", "NAME", "=", "Y00A02607", 0
CreateSearchCondition searchmanager, "OR", 0, "PROPERTY", "NAME", "=", "Y00A02577", 0
Set resultSet = searchManager.Start
searchManager.RetrieveData(0)
Set dictfrom = CreateObject("Scripting.Dictionary")
Set dictto = CreateObject("Scripting.Dictionary")
For i = 1 To resultSet.count
    If (resultSet.Item(i).GetSpecOwner.Spec("Y00T00001.Y00A02607").DisplayValue <> "") And _
    (resultSet.Item(i).GetSpecOwner.Spec("Y00T00001.Y00A02577").DisplayValue <> "") Then
        If Not resultSet.Item(i).GetSpecOwner.Elements.Item("SEG1") Is Nothing Then
            Set SEG = resultSet.Item(i).GetSpecOwner.Elements.Item("SEG1")
            If Not SEG.BackPointerDocObjs.Item(1) Is Nothing Then
                If resultSet.Item(i).Name = "Y00A02607" Then
                		If resultSet.Item(i).LinkObject.ClassificationExists(1,"M22.A040.A030") Then 'T PIECE
                			newtext1 = resultSet.Item(i).LinkObject.OwnerByClass("P").spec("Y00T00402.Y00A07320AA01").DisplayValue
                			TPiece = resultSet.Item(i).LinkObject.OwnerByClass("P").spec("Y00T00402.Y00A07320AA01").DisplayValue
                		Else
                			If resultSet.Item(i).LinkObject.spec("Y00T00402.Y00A07320AA01").DisplayValue = "" Then
                				newtext1 = resultSet.Item(i).DisplayValue
                			Else
                				newtext1 = resultSet.Item(i).LinkObject.spec("Y00T00402.Y00A07320AA01").DisplayValue
                			End If
                		End If
                    dictfrom.Add newtext1, newtext1
                    On Error resume Next
                End If
                If resultSet.Item(i).Name = "Y00A02577" Then
                		If resultSet.Item(i).LinkObject.ClassificationExists(1,"M22.A040.A030") Then 'T PIECE
                			newtext2 = resultSet.Item(i).LinkObject.OwnerByClass("P").spec("Y00T00402.Y00A07320AA01").DisplayValue
                		Else
                			If resultSet.Item(i).LinkObject.spec("Y00T00402.Y00A07320AA01").DisplayValue = "" Then
                				newtext1 = resultSet.Item(i).DisplayValue
                			Else
                				newtext2 = resultSet.Item(i).LinkObject.spec("Y00T00402.Y00A07320AA01").DisplayValue
                			End If
                		End If
                    dictto.Add newtext2, newtext2
                    On Error resume Next
                End If
            End If
        End If
    End If
Next
For Each m In dictfrom.keys
        If dictto.Exists(m) Then
                dictto.Remove(m)
                dictfrom.Remove(m)
        Else
        				If ValFrom = "" Then
        					ValFrom = dictfrom(m)
        				Else
        					ValFrom = Valfrom & " / " & dictfrom(m)
        				End If
        End If
Next
For Each n In dictto.keys
        If dictfrom.Exists(n) Then
                dictfrom.Remove(n)
                dictto.Remove(n)
        Else
        				If ValTo = "" Then
        					ValTo = dictto(n)
        				Else
        					ValTo = Valto & " / " & dictto(n)
        				End If
        End If
Next

If (dictfrom.count = 0 And dictto.count = 0) Or _
	(dictfrom.count = 1 And dictto.count = 0) Or _
	(dictfrom.count = 0 And dictto.count = 1) Then
	ValFrom = "SAME PIPE: " & TPiece
	ValTo = "SAME PIPE: " & TPiece
End If

GetStartEndPipe = ValFrom & "@" & ValTo

searchManager.Stop()

End Function

'Option "Restore the original symbol" via Script 
Set Doc = A

CheckDoc Doc

Sub CheckDoc (Doc)

Set GC = CreateObject("ComosRoUtilities.GlobalCastings")

Set Rp = Doc.Report
If (Rp Is Nothing) Then Exit Sub

Rp.open

Set RepDoc = Rp.ReportDocument
If (RepDoc Is Nothing) Then Exit Sub

Set Items = RepDoc.Items
If (Items Is Nothing) Then Exit Sub

Set RItem= Nothing
For i = 0 To RepDoc.ItemCount - 1
	Set RItem= RepDoc.Item(Cint(i))
	Set IDev = GC.GC_GetIRoDevice(RItem)
	If Not IDev Is Nothing Then
		Set Dev = IDev.Device
			If Not (Dev Is Nothing) Then
				If Dev.ClassificationExists(1, "M40.A390.A080") Then
				Set ISymScr = GC.GC_GetISymbolScript(RItem)
					If Not ISymScr Is Nothing Then
						If ISymScr.IsSymbolScriptLocal Then
							Output Dev.SystemFullname
							' entfernt lokales SymbolScript
							ISymScr.SymbolScript = ""
						End If
					End If
				End If
			End If
	End If
Next

Rp.Save
Rp.Close

End Sub

' Copy & paste loop typical from locations to instruments

Sub Action(Query, QueryBrowser)
  Set InstFolder = QueryBrowser.SelectedObjects 												'Selected objects in query
	Set TypFold = Project.GetObjectByPathFullName("08L@Template§>08LOK")	'Folder containing typicals
  Set clip = Project.WorkSet.clipboard 																	'Copy and pastes
  
  For i = 1 To InstFolder.Count
    Set CellTyp = Query.Cell(i, "Col14") 																'Cell containing the defined typical
      If Not CellTyp Is Nothing Then
  			TypCode = CellTyp.Object.DisplayValue														'Get string for typical code
  		End If
  		If TypCode <> "" Then
  			Set TypCopy = TypFold.Elements.Item(TypCode) 										'Typical Folder with doc and objects
  			If TypCopy Is Nothing Then
  				Msgbox "Erro, tipico nao existe" & VbCrLf & TypCode & VbCrLf & InstFolder.Item(i).FullLabel
  			End If
  		End If
  		Set ObjFolder = InstFolder.Item(i)
    	If Not ObjFolder Is Nothing Then
    		If Not TypCopy Is Nothing Then
    			clip.copytoclipboard TypCopy
					clip.pastefromclipboard ObjFolder, clip.object(), vbtrue
				End If
    	End If
  Next
  QueryBrowser.RefreshSelectedRows
End Sub

' Change all selected objects:
Sub Action(Query, QueryBrowser)
  Set SelObjs = QueryBrowser.SelectedObjects
  For i = 1 To SelObjs.Count
    Set ObjItem = SelObjs.Item(i)
    If Not ObjItem Is Nothing Then
    	Set CellKKS = Query.Cell(i,"KKS")
    	StrKKS = CellKKS.Text
			StrKKS1 = Left(StrKKS,1)  '1
			StrKKS2 = Mid(StrKKS,2,3) 'ETF
			StrKKS3 = Mid(StrKKS,5,2) '10
			StrKKS4 = Mid(StrKKS,7,1) 'A
			StrKKS5 = Mid(StrKKS,8,1) 'F
			
			NewStrPFN = "08U" & StrKKS1 & "§>08U" & StrKKS2 & "§>08U" & StrKKS3 & "§>08U" & StrKKS4 & "§>08U" & StrKKS5
			Set NewKKSUnit = Project.GetObjectByPathFullName(NewStrPFN)
			
			If Not NewKKSUnit Is Nothing Then	
				Set MoveObj = ObjItem.Owner.Devices.Remove(ObjItem)
				NewKKSUnit.Paste2(MoveObj)
			End If

			
'08U1§>08UBFA§>08U01§>08UG§>08UH			
'a.owner.Devices.Remove(a)
'b.Paste2(a)			
			
    End If
  Next
  QueryBrowser.RefreshSelectedRows
End Sub

// .vbs file
Dim args, objExcel

set args = wscript.Arguments
set objExcel = createobject("Excel.Application")

objExcel.workbooks.open args(0) 
objExcel.visible = True

objExcel.Run "Module1.Macro1"
objExcel.Activeworkbook.Save 
objExcel.Activeworkbook.Close(0)
objExcel.Quit



// .bat file
cscript "C:\Users\phareh_92(2)\Documents\X.vbs" "C:\Users\phareh_92(2)\Documents\Y.xlsm"