'********************************************************************
'********************************************************************
'**** VBSCRIPT MACRO FOR THE GENERATION OF A ****
'**** HTML TOOL LIST DOCUMENTATION ****
'********************************************************************
'********************************************************************
'********************************************************************
'**** Notes ****
'**** ****
'**** La fonction CreateHtmlFilesRoot est dependante du systeme ****
'********************************************************************
Dim Language As String
Language = "VBSCRIPT"
'=============== USER DEFINED VARIABLES ==================
'=========================================================
' Put here the path to your HTML editor
'=========================================================
Dim DefaultHTMLEditor As String
'=========================================================
' Default tool list documentation directory
'=========================================================
Dim DefaultHtmlAppliName As String
'============ END OF USER DEFINED VARIABLES ==============
'============ SYSTEM DEPENDANT VARIABLES =================
Dim EOL As String ' Fin de ligne pour les fichiers textes
Dim CRLF As String
'=========================================================
'======================
' Test cession flag
'======================
Dim IsaTest As Boolean
Dim StdComponentsDir As String
Dim DefaultDocTarget, HtmlDefaultDocDir, HtmlFilesPath, CATIAComponentPath, HtmlFilesRoot As String
Dim ExistLogoDS As Boolean
Dim IgnoredParameters()
Dim NbIgnoredParameters As Integer
Dim theLogMode as Boolean
Dim theLogFile As File
Dim theLogStream As TextStream
Sub CATMain()
'------------------------------------------------------------------
' test Macro Atelier
' creation Juillet2000 : (kbb)
' lecture d'un modele
'------------------------------------------------------------------
dim EnvVar,BidVar as String
Dim AdlOdtTmp, AdlOdtTmpPath, AdlOdtOut, AdlOdtOutPath, Slash As String
EnvVar = CATIA.SystemService.Environ("ADL_ODT_IN")
CATIA.SystemService.Print "ADL_ODT_IN =" & EnvVar
if (len(EnvVar)<10) then
BidVar = EnvVar
else
BidVar = Mid(EnvVar,1,10)
end if
If (BidVar <> "ADL_ODT_IN") Then
CATIA.SystemService.Print "IN MKODT"
IsaTest = True
'------------------------------------------------------------------
CATIA.SystemService.Print "Lire le modele"
AdlOdtTmp = CATIA.SystemService.Environ("ADL_ODT_TMP")
CATIA.SystemService.Print "AdlOdtTmp=" & AdlOdtTmp
CATIA.SystemService.Print "Repertoire cible"
AdlOdtOut = CATIA.SystemService.Environ("ADL_ODT_OUT")
CATIA.SystemService.Print "AdlOdtOut=" & AdlOdtOut
Slash = CATIA.SystemService.Environ("ADL_ODT_SLASH")
CATIA.SystemService.Print "Slash=" & Slash
AdlOdtTmpPath = AdlOdtTmp & Slash
CATIA.SystemService.Print "Path=" & AdlOdtTmpPath
AdlOdtOutPath = AdlOdtOut & Slash
CATIA.SystemService.Print "Generation Path=" & AdlOdtOutPath
'------------------------------------------------------------------
CATIA.SystemService.Print "Lire le modele"
Dim Document1 As AnyObject
Set Document1 = CATIA.Documents.Open(AdlOdtTmpPath & "ToolList.CATProcess")
'------------------------------------------------------------------
Else
IsaTest = False
End If
Dim aPath As String
HtmlFilesRoot = CreateHtmlFilesRoot
If (Not IsaTest) Then
DefaultDocTarget = HtmlFilesRoot 'Pourrait etre initialise autrement
DefaultHtmlAppliName = "ToolList"
HtmlDefaultDocDir = DefaultDocTarget & DefaultHtmlAppliName
aPath = InputBox("Tool List directory", "Define Directory", HtmlDefaultDocDir)
Else
aPath = AdlOdtOutPath
End If
If (aPath = "") Then
If (Not IsaTest) Then
MsgBox "Document creation canceled", 4096
Else
CATIA.SystemService.Print "Document creation canceled"
End If
Exit Sub
End If
Dim RootActivityName As String
RootActivityName = "Process"
'=========================================================
' Default tool list documentation name
'=========================================================
Dim DefaultHTMLFileName As String
DefaultHTMLFileName = "MfgTool-List"
'pdu***
'on error resume next
CATDocument RootActivityName, DefaultHTMLFileName, aPath
If (IsaTest) Then
Document1.Close
CATIA.Quit
End If
End Sub
'---------------------------------------------------------------
' Initialisation des variables dependantes du systeme
' ---------------------------------------------------
'---------------------------------------------------------------
Sub CreateSystemVariables()
theLogMode = False
'Definition des parametres qui seront ignores lors de
'l'affichage du tableau d'une resource
NbIgnoredParameters = 3
ReDim IgnoredParameters(NbIgnoredParameters)
IgnoredParameters(1) = "MFG_CONE_DIAMETER_2"
IgnoredParameters(2) = "MFG_CONE_DIAMETER_1"
IgnoredParameters(3) = "MFG_CONE_LENGTH"
On Error Resume Next
EOL = Chr(10)
CRLF = Chr(13) & Chr(10)
StdComponentsDir = "Images"
ExistLogoDS = False
DefaultHTMLEditor = "IEXPLORE.EXE"
On Error GoTo 0 'pdu***
End Sub
'---------------------------------------------------------------
' Initialisation de la variable HtmlFilesRoot
' -------------------------------------------
'---------------------------------------------------------------
Function CreateHtmlFilesRoot()
Dim result As String
result = GetPath("CATStartupPath", "Manufacturing")
If (result = "") Then result = GetPath("TEMP", "")
If (result <> "") Then
If (Mid(result, Len(result), 1) <> "\" And Mid(result, Len(result), 1) <> "/") Then result = result & "/"
End If
CreateHtmlFilesRoot = result
End Function
'-------------------------------------------------------
' Ecriture d'une dans un CATIATextStrean
'-------------------------------------------------------
Sub WriteLine(aTextStream, aLine)
aTextStream.Write aLine & EOL
End Sub
' ------------------------------------------------------
' Correspondance Parameter -> valeur NLS
' ------------------------------------------------------
Function ToNLS(anObj, aParameterName)
Dim erreur as Integer
Dim NLSresult As String
On Error Resume Next
NLSresult = anObj.GetAttributeNLSName(aParameterName)
erreur = Err.Number
Err.Clear
If (erreur <> 0 Or NLSresult = "") Then NLSresult = aParameterName
On Error GoTo 0
ToNLS = NLSresult
End Function
' ------------------------------------------------------
' Copie d'un fichier
' Retourne : 0 -> pas d'erreur
' 1 -> source absent
' 2 -> destination existe et overwrite=False
' 3 -> autre erreur
' ------------------------------------------------------
Function FileCopy(source, destination, overwrite)
Dim ReturnedVal As Integer
Dim fso As FileSystem
Set fso = CATIA.FileSystem
If (Not (fso.FileExists(source))) Then
ReturnedVal = 1
Else
If (fso.FileExists(destination) And (Not overwrite)) Then
ReturnedVal = 2
Else
On Error Resume Next
fso.CopyFile source, destination, overwrite
Dim erreur As Integer
erreur = Err.Number
Err.Clear
If (erreur <> 0) Then ReturnedVal = 3
On Error GoTo 0
End If
End If
FileCopy = ReturnedVal
End Function
'--------------------------------------------------------------------
' Main Procedure
'--------------------------------------------------------------------
Sub CATDocument(RootActivityName, HtmlFilesName, FilesPath)
dim EnvVar,BidVar as String
EnvVar = CATIA.SystemService.Environ("ADL_ODT_IN")
CATIA.SystemService.Print "ADL_ODT_IN =" & EnvVar
if (len(EnvVar)<10) then
BidVar = EnvVar
else
BidVar = Mid(EnvVar,1,10)
end if
IsaTest = (BidVar <> "ADL_ODT_IN")
CreateSystemVariables
HtmlFilesPath = FilesPath
Dim L As Integer
L = Len(HtmlFilesPath)
If (Mid(HtmlFilesPath, L, 1) <> "\" And Mid(HtmlFilesPath, L, 1) <> "/") Then HtmlFilesPath = HtmlFilesPath & "/"
HtmlFilesPath = HtmlFilesPath & HtmlFilesName
L = Len(HtmlFilesPath)
If (Mid(HtmlFilesPath, L, 1) = "\" Or Mid(HtmlFilesPath, L, 1) = "/") Then HtmlFilesPath = Mid(HtmlFilesPath, 1, L - 1)
Dim fso As FileSystem
Set fso = CATIA.FileSystem
If (fso.FolderExists(HtmlFilesPath)) Then
If (Not IsaTest) Then
Dim repcont As Boolean
repcont = ContinueIfExistingFolder(HtmlFilesPath)
If (Not repcont) Then
MsgBox "Document creation canceled", 4096 '(vbSystemModal)
On Error GoTo 0
Err.Raise 1
End If
Else
Dim deldir As Integer
deldir = RemoveDirectory(HtmlFilesPath)
End If
End If
On Error Resume Next
If (Not fso.FolderExists(HtmlFilesPath)) Then
Dim CreatedFolder As Folder
Set CreatedFolder = fso.CreateFolder(HtmlFilesPath)
Dim erreur As Integer
erreur = Err.Number
Err.Clear
If (erreur <> 0) Then
If (Not IsaTest) Then
MsgBox HtmlFilesPath & CRLF & CRLF & "Error creating folder", 4144
Else
CATIA.SystemService.Print HtmlFilesPath & " : Error creating folder"
End If
Err.Raise erreur
End If
End If
On Error GoTo 0
HtmlFilesPath = HtmlFilesPath & "/"
OpenLogFile
Dim OutIndex As String
OutIndex = HtmlFilesName & ".html"
CATIAComponentPath = CreateHtmlFilesRoot & StdComponentsDir & "/"
CreateHtmlFile OutIndex
Dim OpenDocNow As Integer
Dim EndOfGenerationTxt As String
CloseLogFile
If (Not IsaTest) Then
EndOfGenerationTxt = "Tool List : " & OutIndex & CRLF & "Created In " & HtmlFilesPath & CRLF & "Open the document now?"
OpenDocNow = MsgBox(EndOfGenerationTxt, 4100)
If (OpenDocNow = 6) Then
Dim CmdLine As String
CmdLine = DefaultHTMLEditor & " " & HtmlFilesPath & OutIndex
Dim aCmdResult As Long
On Error Resume Next
aCmdResult = CATIA.SystemService.ExecuteBackgroundProcessus(CmdLine)
Dim cmderreur As Integer
cmderreur = Err.Number
Err.Clear
If (cmderreur <> 0) Then MsgBox "Error while opening HTML editor", 4096
On Error GoTo 0
End If
Else
CATIA.SystemService.Print "Tool List : " & OutIndex & " " & "Created In " & HtmlFilesPath
End If
End Sub
'---------------------------------------------------------------
' Creation de la liste de tous les outils
'---------------------------------------------------------------
Sub CreateHtmlFile(OutIndex)
Dim aFileSyst As FileSystem
Set aFileSyst = CATIA.FileSystem
Dim theHTMLFile As File
Dim aTextStream As TextStream
UpdateLogFile "Tool list documentation file : " & HtmlFilesPath & OutIndex
Set theHTMLFile = aFileSyst.CreateFile(HtmlFilesPath & OutIndex, True)
Set aTextStream = theHTMLFile.OpenAsTextStream("ForWriting")
'---------------------------------------------------------------
' Retrieve the active document
'---------------------------------------------------------------
Dim MfgDoc1 As Document
Set MfgDoc1 = CATIA.ActiveDocument
WriteLine aTextStream, "<html>"
WriteLine aTextStream, "<head>"
WriteLine aTextStream, " <title>Tools List Documentation</title>"
WriteLine aTextStream, "</head>"
WriteLine aTextStream, "<body>"
WriteLine aTextStream, "<table CELLSPACING=0 CELLPADDING=5>"
WriteLine aTextStream, "<tr>"
rep = FileCopy(CATIAComponentPath & "navlogocat.gif", HtmlFilesPath & "navlogocat.gif", True)
If (rep = 0) Then
WriteLine aTextStream, "<td><img SRC=""navlogocat.gif"" BORDER=0></td>"
ExistLogoDS = True
End If
WriteLine aTextStream, "<td BGCOLOR=""#000099""><b><font color=""#FFFFFF"" size=+2>"
WriteLine aTextStream, "TOOL LIST"
WriteLine aTextStream, "</font></b></td>"
WriteLine aTextStream, "</tr>"
WriteLine aTextStream, "<tr>"
If (rep = 0) Then WriteLine aTextStream, "<td></td>"
WriteLine aTextStream, "<td><b><font color=""#000099"" size=+3>" & MfgDoc1.Name & "</font></b></td>"
WriteLine aTextStream, "</tr>"
WriteLine aTextStream, "</table>"
WriteLine aTextStream, "<br>"
WriteLine aTextStream, "<i><p>Generation : " & Date & " at " & Time & "</i></p>"
Dim ProgramList As MfgActivities
Dim ActivityList As MfgActivities
Dim NumberOfProgram As Integer
Dim NumberOfActivity As Integer
Dim i As Integer
Dim J As Integer
Dim K As Integer
Dim ActivityName As String
Dim CurrentSetup As Activity
Dim CurrentProgram As ManufacturingActivity
Dim CurrentActivity As ManufacturingActivity
Dim CurrentTool As ManufacturingTool
Dim CurrentAssembly As ManufacturingToolAssembly
Dim AssemblyNumber as Integer
Dim ActivityType As String
Dim childs As Activities
Dim quantity As Integer
Dim aProcess As AnyObject
Dim ToolNumber As Integer
Dim ToolName As String
Dim erreur As Integer
'---------------------------------------------------------------
' Retrieve the current Process
'---------------------------------------------------------------
Set aProcess = MfgDoc1.GetItem("Process")
'---------------------------------------------------------------
' Scan the Process and print tools
'---------------------------------------------------------------
quantity = 0
If (aProcess.IsSubTypeOf("PhysicalActivity")) Then
Set childs = aProcess.ChildrenActivities
quantity = childs.Count
If quantity <= 0 Then
Exit Sub
End If
Dim TabTool()
Dim TabToolName()
Dim TabToolStatus() 'outil utilise ou non dans un assembly
Dim MaxToolNb As Integer
MaxToolNb = 32
ReDim TabTool(MaxToolNb)
ReDim TabToolName(MaxToolNb)
Dim TabAssembly()
Dim TabAssemblyName()
Dim MaxAssemblyNb As Integer
MaxAssemblyNb = 32
ReDim TabAssembly(MaxToolNb)
ReDim TabAssemblyName(MaxToolNb)
WriteLine aTextStream, "<font size=+1><a href=""#ProcessList"">Process List...</a></font></p>"
WriteLine aTextStream, "<a href=""#ToolList"">"
For i = 1 To quantity
Set CurrentSetup = childs.Item(i)
If (CurrentSetup.IsSubTypeOf("ManufacturingSetup")) Then
'---------------------------------------------------------------
' Read the Programs of the current Setup
'---------------------------------------------------------------
Set ProgramList = CurrentSetup.Programs
NumberOfProgram = ProgramList.Count
For J = 1 To NumberOfProgram
Set CurrentProgram = ProgramList.GetElement(J)
'---------------------------------------------------------------
' Read the Activities of the current Program
'---------------------------------------------------------------
Set ActivityList = CurrentProgram.Activities
NumberOfActivity = ActivityList.Count
For K = 1 To NumberOfActivity
Set CurrentActivity = ActivityList.GetElement(K)
ActivityName = CurrentActivity.Name
ActivityType = CurrentActivity.Type
'---------------------------------------------------------------
' Read the Activity Type
' If the Activity is a tool Change -> Add to the document
'---------------------------------------------------------------
UpdateLogFile "Activity : " & ActivityName & EOL & "Type : " & ActivityType
If (ActivityType = "ToolChange" Or ActivityType = "ToolChangeLathe") Then
'Traitement si presence d'un tool assembly
'On procede comme pour l'outil
On Error Resume Next
set CurrentAssembly = NOTHING
AssemblyNumber = -1
Err.Clear
Set CurrentAssembly = CurrentActivity.ToolAssembly
AssemblyNumber = CurrentAssembly.Number
erreur = Err.Number
Err.Clear
If (erreur = 0) Then
Dim Attribut As Parameter
Set Attribut = CurrentAssembly.getAttribute("MFG_NAME")
erreur = Err.Number
Err.Clear
If (erreur = 0) Then AssemblyName = Attribut.Value
If (AssemblyNumber > MaxAssemblyNb) Then
MaxAssemblyNb = AssemblyNumber
ReDim Preserve TabAssembly(MaxAssemblyNb)
ReDim Preserve TabAssemblyName(MaxAssemblyNb)
Set TabAssembly(AssemblyNumber) = CurrentAssembly
TabAssemblyName(AssemblyNumber) = AssemblyName
Else
If (TabAssemblyName(AssemblyNumber) <> AssemblyName) Then
Set TabAssembly(AssemblyNumber) = CurrentAssembly
TabAssemblyName(AssemblyNumber) = AssemblyName
End If
End If
Else
UpdateLogFile "No assembly (erreur=" & erreur & ")"
End If
Set CurrentTool = CurrentActivity.Tool
ToolNumber = CurrentTool.Number
ToolName = CurrentTool.Name
If (ToolNumber > MaxToolNb) Then
MaxToolNb = ToolNumber
ReDim Preserve TabTool(MaxToolNb)
ReDim Preserve TabToolName(MaxToolNb)
Set TabTool(ToolNumber) = CurrentTool
TabToolName(ToolNumber) = ToolName
Else
If (TabToolName(ToolNumber) <> ToolName) Then
Set TabTool(ToolNumber) = CurrentTool
TabToolName(ToolNumber) = ToolName
End If
End If
End If
Next
Next
End If
Next
UpdateLogFile "Nombre d'assemblies : " & MaxAssemblyNb
UpdateLogFile "Nombre d'outils : " & MaxToolNb
ReDim TabToolStatus(MaxToolNb)
For i = 0 To MaxToolNb
TabToolStatus(i) = 0
Next
'Ajout des tool-assembly dans le document
For i = 0 To MaxAssemblyNb
If (TabAssemblyName(i) <> "") Then
Dim anAssembly As ManufacturingToolAssembly
Set anAssembly = TabAssembly(i)
WriteAssembly anAssembly, aTextStream
CreateOneAssemblySheet anAssembly, MfgDoc1.Name
Dim UsedTool As ManufacturingTool
Set UsedTool = anAssembly.Tool
UsedToolNb = UsedTool.Number
TabToolStatus(UsedToolNb) = 1
End If
Next
'Ajout des outils dans le document
For i = 0 To MaxToolNb
If (TabToolName(i) <> "") Then
Dim aTool As ManufacturingTool
Set aTool = TabTool(i)
Dim aToolNb As Integer
aToolNb = aTool.Number
If (TabToolStatus(aToolNb) = 0) Then
WriteTool aTool, aTextStream
CreateOneToolSheet aTool, MfgDoc1.Name
End If
End If
Next
WriteLine aTextStream, "<p><hr></p>"
'---------------------------------------------------------------
' List of involved part operations, programs and cycles
'---------------------------------------------------------------
WriteLine aTextStream, "<p><a NAME=""ProcessList""></a>"
WriteProcessStructure aProcess, aTextStream
End If
WriteLine aTextStream, "</body>"
WriteLine aTextStream, "</html>"
aTextStream.Close
Set theHTMLFile = Nothing
Set aTextStream = Nothing
UpdateLogFile "End of creation."
End Sub
'---------------------------------------------------------------
' Ajout d'un outil dans la liste
'---------------------------------------------------------------
Sub WriteTool(aTool, aStream)
Dim ToolNumber As Variant
Dim ToolName, ToolType As String
ToolNumber = aTool.Number
ToolName = aTool.Name
ToolType = aTool.ToolType
WriteLine aStream, "<a NAME=""T" & ToolNumber & """></a>"
WriteLine aStream, "<center><table BORDER=1 CELLSPACING=2 CELLPADDING=5 WIDTH=""80%"">"
WriteLine aStream, "<tr VALIGN=""MIDDLE"">"
WriteLine aStream, "<td WIDTH=""50%"" BGCOLOR=""#C6C6FF""><b><font size=+1><a href=""Tool" & ToolNumber & ".html"">Tool " & ToolNumber & " : " & ToolName & "</a></font></b></td>"
Dim ImgName As String
ImgName = GetToolImage(aTool, True)
If (ImgName <> "") Then
WriteLine aStream, "<td ALIGN=""CENTER"" WIDTH=""100"">"
WriteLine aStream, "<img SRC=""" & ImgName & """>"
WriteLine aStream, "</td>"
End If
WriteLine aStream, "<td>"
WriteLine aStream, "Type : " & ToNLS(aTool, ToolType) & "<br>"
Dim DiameterId As String
If (ToolType = "MfgAPTTool") Then
DiameterId = "MFG_APT_DIAMETER"
Else
DiameterId = "MFG_NOMINAL_DIAM"
End If
On Error Resume Next
Set DiameterAttribut = aTool.getAttribute(DiameterId)
Dim erreur As Integer
erreur = Err.Number
Err.Clear
If (erreur = 0) Then
ToolDiameter = DiameterAttribut.Value
erreur = Err.Number
Err.Clear
If (erreur = 0) Then
WriteLine aStream, "Diameter : " & ToolDiameter
End If
End If
On Error GoTo 0
WriteLine aStream, "</td>"
WriteLine aStream, "</tr>"
WriteLine aStream, "</table></center>"
WriteLine aStream, "<br>"
End Sub
'---------------------------------------------------------------
' Liste des activites utilisant les outils (scan du process)
'---------------------------------------------------------------
Sub WriteProcessStructure(aProcess, aStream)
Dim erreur as Integer
Dim ProcessActivities As Activities
Dim anActivity As Activity
Dim CurrentSetup As ManufacturingActivity
Dim SetupName As String
Dim ProgramList As MfgActivities
Dim CurrentProgram As ManufacturingActivity
Dim ProgramName As String
Dim ActivityType As String
Dim anInsert As ManufacturingInsert
Dim InsertName As String
Dim AssemblyName As String
If (aProcess.IsSubTypeOf("PhysicalActivity")) Then
Set ProcessActivities = aProcess.ChildrenActivities
quantity = ProcessActivities.Count
If (quantity <= 0) Then
Exit Sub
End If
WriteLine aStream, "<p><b><font size=+1>Process List :</font></b>"
WriteLine aStream, "<ul>" 'liste des P.O.
For i = 1 To quantity
Set anActivity = ProcessActivities.Item(i)
If (anActivity.IsSubTypeOf("ManufacturingSetup")) Then
SetupName = anActivity.Name
Set ProgramList = anActivity.Programs
NumberOfProgram = ProgramList.Count
If (NumberOfProgram <= 0) Then
Exit Sub
End If
WriteLine aStream, "<p><li>Part Operation : <b>" & SetupName & "</b></li></p>"
WriteLine aStream, "<ul>" 'liste des programmes
For J = 1 To NumberOfProgram
Set CurrentProgram = ProgramList.GetElement(J)
ProgramName = CurrentProgram.Name
WriteLine aStream, "<p><li>Program : <b>" & ProgramName & "</b></li></p>"
Set ProgActivityList = CurrentProgram.Activities
NumberOfActivity = ProgActivityList.Count
WriteLine aStream, "<ul>" 'liste des cycles
For K = 1 To NumberOfActivity
Set CurrentActivity = ProgActivityList.GetElement(K)
ActivityName = CurrentActivity.Name
ActivityType = CurrentActivity.Type
If (ActivityType = "ToolChange" Or ActivityType = "ToolChangeLathe") Then
Dim Attribut As Parameter
Dim CurrentTool As ManufacturingTool
Dim ToolName As String
Dim ToolNumber As Integer
Dim CurrentAssembly As ManufacturingToolAssembly
Dim AssemblyNumber As Integer
Set CurrentTool = CurrentActivity.Tool
ToolNumber = CurrentTool.Number
ToolName = CurrentTool.Name
InsertName = ""
AssemblyName = ""
On Error Resume Next
set CurrentAssembly = NOTHING
AssemblyNumber = 0
Set CurrentAssembly = CurrentActivity.ToolAssembly
AssemblyNumber = CurrentAssembly.Number
erreur = Err.Number
Err.Clear
If (erreur = 0) Then
Dim AssemblyType As String
AssemblyNumber = CurrentAssembly.Number
Set Attribut = CurrentAssembly.getAttribute("MFG_NAME")
erreur = Err.Number
Err.Clear
If (erreur = 0) Then AssemblyName = Attribut.Value
AssemblyType = CurrentAssembly.AssemblyType
If (AssemblyType = "MfgLatheToolAssembly") Then
Set anInsert = CurrentAssembly.Insert
Set Attribut = anInsert.getAttribute("MFG_NAME")
erreur = Err.Number
Err.Clear
If (erreur = 0) Then InsertName = Attribut.Value
End If
End If
Dim ActivityLine As String
ActivityLine = "<li>" & ActivityName & " (" & ToNLS(CurrentActivity, ActivityType) & " : "
If (AssemblyName <> "") Then
ActivityLine = ActivityLine & "<a href=""Assembly" & AssemblyNumber & ".html"">" & AssemblyName & "</a> , "
ActivityLine = ActivityLine & "<a href=""Assembly" & AssemblyNumber & ".html#Tool"">" & ToolName & "</a>"
If (InsertName <> "") Then ActivityLine = ActivityLine & " , <a href=""Assembly" & AssemblyNumber & ".html#Insert"">" & InsertName & "</a>"
Else
ActivityLine = ActivityLine & "<a href=""Tool" & ToolNumber & ".html"">" & ToolName & "</a>"
End If
ActivityLine = ActivityLine & ")</li>"
WriteLine aStream, ActivityLine
Else
WriteLine aStream, "<li>" & ActivityName & " (" & ToNLS(CurrentActivity, ActivityType) & ")</li>"
End If
Next
WriteLine aStream, "</ul>" 'liste des cycles
Next
WriteLine aStream, "</ul>" 'liste des programmes
WriteLine aStream, "<br>"
End If
Next
WriteLine aStream, "</ul>" 'liste des P.O.
End If
End Sub
' --------------------------
' Creation d'une fiche outil
' --------------------------
Sub CreateOneToolSheet(aTool, aProcessName)
Dim Attribut as Parameter
Dim ToolNumber As Variant
Dim ToolName, ToolType, ToolComment As String
Dim ToolDiameter, ToolCornerRadius, ToolTotalLength, ToolCuttingLength, ToolLength, ToolBodyDiameter As Variant
ToolType = aTool.ToolType
ToolNumber = aTool.Number
On Error Resume Next
Set Attribut = aTool.getAttribute("MFG_NAME")
Dim erreur As Integer
erreur = Err.Number
Err.Clear
If (erreur = 0) Then ToolName = Attribut.Value
Dim aFileSyst As FileSystem
Set aFileSyst = CATIA.FileSystem
Dim theToolFile As File
Dim aStream As TextStream
Dim FileName As String
FileName = "Tool" & ToolNumber & ".html"
Set theHTMLFile = aFileSyst.CreateFile(HtmlFilesPath & FileName, True)
Set aStream = theHTMLFile.OpenAsTextStream("ForWriting")
'Debut de la page
WriteLine aStream, "<html>"
WriteLine aStream, "<head>"
WriteLine aStream, "<title>Tool " & ToolNumber & " : " & ToolName & "</title>"
WriteLine aStream, "</head>"
'Ecriture de l'entete
WriteLine aStream, "<table CELLSPACING=0 CELLPADDING=5><tr>"
If (ExistLogoDS) Then
WriteLine aStream, "<td ALIGN=CENTER><img SRC=""navlogocat.gif"" BORDER=0></td>"
End If
WriteLine aStream, "<td BGCOLOR=""#000099"">"
WriteLine aStream, "<b><font color=""#FFFFFF"" size=+2>"
WriteLine aStream, "TOOL LIST<br>"
WriteLine aStream, aProcessName
WriteLine aStream, "</font></b></td>"
WriteLine aStream, "</tr></table>"
WriteLine aStream, "<br><br>"
WriteLine aStream, "<table BORDER=0 CELLSPACING=0 CELLPADDING=5 WIDTH=""100%"" BGCOLOR=""#3366FF"">"
WriteLine aStream, "<tr>"
WriteLine aStream, "<td><b><font color=""#FFFFFF"" size=+3>Tool " & ToolNumber & " : " & ToolName & "</font></b></td>"
WriteLine aStream, "</tr>"
WriteLine aStream, "</table>"
'Fin de l'ecriture de l'entete
WriteLine aStream, "<br><br>"
WriteToolTable aTool, aStream, False
WriteLine aStream, "</body>"
WriteLine aStream, "</html>"
aStream.Close
Set theHTMLFile = Nothing
Set aStream = Nothing
On Error GoTo 0 'pdu***
End Sub
'-----------------------------------------------
' Ecriture du tableau de description d'un outil
' Parametres + Image + commentaire + correcteurs
'-----------------------------------------------
Sub WriteToolTable(aTool, aStream, writecaption)
Dim ToolName, ToolType As String
ToolName = aTool.Name
ToolType = aTool.ToolType
If (writecaption) Then WriteLine aStream, "<p><center><b><font color=""#3333FF"" size=+2>" & ToolName & "</font></b></center></p>"
WriteLine aStream, "<center><table BORDER=0 CELLSPACING=5>"
WriteLine aStream, "<tr>"
WriteLine aStream, "<td ALIGN=LEFT>"
AddResourceParameters aTool, aStream
WriteLine aStream, "</td>"
Dim ImgName As String
ImgName = GetToolImage(aTool, False)
If (ImgName <> "") Then
WriteLine aStream, "<td ALIGN=RIGHT>"
WriteLine aStream, "<center><img BORDER=0 SRC=""" & ImgName & """>"
WriteLine aStream, "<br>Type : " & ToNLS(aTool, ToolType) & "</center>"
WriteLine aStream, "</td>"
Else
WriteLine aStream, "<br>"
WriteLine aStream, "<center>Type : <b>" & ToNLS(aTool, ToolType) & "</b></center>"
End If
WriteLine aStream, "</tr>"
' Commentaire
'------------
ToolComment = aTool.Comment
If (ToolComment <> "") Then
WriteLine aStream, "<tr>"
WriteLine aStream, "<td COLSPAN=""2"">"
WriteLine aStream, "<center><table BORDER CELLSPACING=0 CELLPADDING=5 WIDTH=""75%"" BGCOLOR=""#FFFFFF"">"
WriteLine aStream, "<tr>"
WriteLine aStream, "<td>" & ToolComment & "</td>"
WriteLine aStream, "</tr>"
WriteLine aStream, "</table></center>"
WriteLine aStream, "</td>"
WriteLine aStream, "</tr>"
End If
WriteLine aStream, "</table></center>"
If (ToolType <> "MfgAPTTool") Then
WriteLine aStream, "<center><hr WIDTH=""60%""></center>"
' Correcteurs
'------------
WriteLine aStream, "<center><table CELLSPACING=10 CELLPADDING=5 WIDTH=""75%"">"
WriteLine aStream, "<tr VALIGN=""TOP"">"
WriteLine aStream, "<td>"
WriteLine aStream, "<p><center><b><font color=""#3333FF"" size=+1>Tool Compensation</font></b></center></p>"
WriteLine aStream, "<table CELLSPACING=3 CELLPADDING=3 BGCOLOR=""#C5C5E2"" WIDTH=""100%"">"
WriteLine aStream, "<tr><font size=-1>"
WriteLine aStream, "<td><center><b>Compensation Type</b></center></td>"
WriteLine aStream, "<td><center><b>Corrector Number</b></center></td>"
WriteLine aStream, "<td><center><b>Length Number</b></center></td>"
WriteLine aStream, "<td><center><b>Tool Diameter</b></center></td>"
WriteLine aStream, "</font></tr>"
Dim NbCorr, corr As Integer
Dim aCorr As ManufacturingToolCorrector
NbCorr = aTool.CorrectorCount
Dim CorrPoint As String
Dim CorrNumber, CorrLengthNumber As Integer
Dim CorrDiameter As Variant
For corr = 1 To NbCorr
CorrPoint = ""
CorrNumber = 0
CorrLengthNumber = 0
CorrDiameter = 0
Set aCorr = aTool.GetCorrector(corr)
CorrPoint = aCorr.Point
CorrNumber = aCorr.Number
CorrLengthNumber = aCorr.LengthNumber
CorrDiameter = aCorr.Diameter
If (CorrPoint <> "") Then
WriteLine aStream, "<tr>"
WriteLine aStream, "<td><center>" & aCorr.Point & "</center></td>"
WriteLine aStream, "<td><center>" & aCorr.Number & "</center></td>"
WriteLine aStream, "<td><center>" & aCorr.LengthNumber & "</center></td>"
WriteLine aStream, "<td><center>" & aCorr.Diameter & "</center></td>"
WriteLine aStream, "</tr>"
End If
Next
WriteLine aStream, "</table>"
WriteLine aStream, "</td>"
Dim ImageCorr As String
ImageCorr = CompensationImageFromTool(aTool)
If (ImageCorr <> "") Then
WriteLine aStream, "<td><img BORDER=0 SRC=""" & ImageCorr & """></td>"
End If
WriteLine aStream, "</tr>"
WriteLine aStream, "</table></center>"
End If
End Sub
'----------------------------------------------
' Recherche du fichier image associe a un outil
'----------------------------------------------
Function GetToolImage(aTool, IsSmall)
Dim erreur as Integer
Dim ToolPictureName, foldername, FileName As String
FileName = ""
foldername = ""
On Error Resume Next
If (Not IsSmall) Then
ToolPictureName = aTool.Picture
erreur = Err.Number
Err.Clear
If (erreur <> 0) Then
ToolPictureName = ""
Else
ToolPictureName = Trim(ToolPictureName)
End If
End If
If (ToolPictureName <> "") Then
If (fso.FileExists(ToolPictureName)) Then
Dim namelength, posdernierslash, i As Integer
posdernierslash = 0
namelength = Len(ToolPictureName)
For i = 1 To namelength
If (Mid(ToolPictureName, i, 1) = "\" Or Mid(ToolPictureName, i, 1) = "/") Then posdernierslash = i
Next
If (posdernierslash = 0) Then
FileName = ToolPictureName
Else
foldername = Mid(ToolPictureName, 1, posdernierslash)
FileName = Mid(ToolPictureName, posdernierslash + 1, namelength - posdernierslash)
End If
End If
End If
If (FileName = "") Then
FileName = GetToolStdImage(aTool, IsSmall)
foldername = CATIAComponentPath
End If
If (FileName <> "") Then
Dim target As String
target = HtmlFilesPath & FileName
If (Not (fso.FileExists(target))) Then
Dim rep As Integer
rep = FileCopy(foldername & FileName, target, True)
If (rep <> 0) Then FileName = ""
End If
End If
On Error GoTo 0 'pdu***
GetToolImage = FileName
End Function
Function GetToolStdImage(aTool, IsSmall)
Dim ToolType, FileName As String
ToolType = aTool.ToolType
Select Case ToolType
'Milling tools
Case "MfgDrillTool"
FileName = "ncdrills"
Case "MfgTapTool"
FileName = "nctaps"
Case "MfgCountersinkTool"
FileName = "nccounte"
Case "MfgReamerTool"
FileName = "ncreamer"
Case "MfgSpotDrillTool"
FileName = "ncspodri"
Case "MfgCenterDrillTool"
FileName = "nccenter"
Case "MfgMultiDiamDrillTool"
FileName = "ncmddrls"
Case "MfgBoringAndChamferingTool"
FileName = "ncbochmf"
Case "MfgTwoSidesChamferingTool"
FileName = "nctschmf"
Case "MfgBoringBarTool"
FileName = "ncborbar"
Case "MfgEndMillTool"
FileName = "ncendmil"
Case "MfgFaceMillTool"
FileName = "ncfacmil"
Case "MfgConicalMillTool"
FileName = "ncconmil"
Case "MfgTSlotterTool"
FileName = "nctslott"
Case "MfgAPTTool"
FileName = "ncapt"
Case "MfgThreadMillTool"
FileName = "ncthrmil"
'Lathe Tools
Case "MfgExternalTool"
FileName = "nlexttl"
Case "MfgInternalTool"
FileName = "nlinttl"
Case "MfgGrooveExternalTool"
FileName = "nlextgrv"
Case "MfgGrooveInternalTool"
FileName = "nlintgrv"
Case "MfgGrooveFrontalTool"
FileName = "nlgrvfrl"
Case "MfgThreadExternalTool"
FileName = "nlextthd"
Case "MfgThreadInternalTool"
FileName = "nlintthd"
Case Else
FileName = ""
End Select
If (FileName <> "") Then
If (IsSmall) Then FileName = FileName & "-small"
FileName = FileName & ".gif"
End If
GetToolStdImage = FileName
End Function
'----------------------------------------------
' Recherche du fichier image associe aux
' correcteurs d'un outil
'----------------------------------------------
Function CompensationImageFromTool(aTool)
Dim ToolType, FileName As String
ToolType = aTool.ToolType
Select Case ToolType
Case "MfgDrillTool"
FileName = "ncdrillscomp.gif"
Case "MfgTapTool"
FileName = "nctapscomp.gif"
Case "MfgCountersinkTool"
FileName = "nccountecomp.gif"
Case "MfgReamerTool"
FileName = "ncreamercomp.gif"
Case "MfgSpotDrillTool"
FileName = "ncspodricomp.gif"
Case "MfgCenterDrillTool"
FileName = "nccentercomp.gif"
Case "MfgMultiDiamDrillTool"
FileName = "ncmddrlscomp.gif"
Case "MfgBoringAndChamferingTool"
FileName = "ncbochmfcomp.gif"
Case "MfgTwoSidesChamferingTool"
FileName = "nctschmfcomp.gif"
Case "MfgBoringBarTool"
FileName = "ncborbarcomp.gif"
Case "MfgEndMillTool"
FileName = "ncendmilcomp.gif"
Case "MfgFaceMillTool"
FileName = "ncfacmilcomp.gif"
Case "MfgConicalMillTool"
FileName = "ncconmilcomp.gif"
Case "MfgTSlotterTool"
FileName = "nctslottcomp.gif"
Case "MfgThreadMillTool"
FileName = "ncthrmilcomp"
Case Else
FileName = ""
End Select
If (FileName <> "") Then
Dim aFileSyst As FileSystem
Set aFileSyst = CATIA.FileSystem
If (Not (aFileSyst.FileExists(HtmlFilesPath & FileName))) Then
Dim rep As Integer
rep = FileCopy(CATIAComponentPath & FileName, HtmlFilesPath & FileName, True)
If (rep <> 0) Then FileName = ""
End If
End If
CompensationImageFromTool = FileName
End Function
Function GetToolAssemblyImage(anAssembly, IsSmall)
Dim FileName As String
AssemblyType = anAssembly.AssemblyType
If (AssemblyType = "MfgLatheToolAssembly") Then
FileName = "nclathetoolassembly"
Else
FileName = "ncmillingtoolassembly"
End If
If (IsSmall) Then FileName = FileName & "-small"
FileName = FileName & ".gif"
Dim aFileSyst As FileSystem
Set aFileSyst = CATIA.FileSystem
If (Not (aFileSyst.FileExists(HtmlFilesPath & FileName))) Then
Dim rep As Integer
rep = FileCopy(CATIAComponentPath & FileName, HtmlFilesPath & FileName, True)
If (rep <> 0) Then FileName = ""
End If
GetToolAssemblyImage = FileName
End Function
'----------------------------------------------
' Ajout d'une ligne dans un tableau 2 colonnes
' NOM_DU_PARAMETRE - VALEUR_DU_PARAMETRE
'----------------------------------------------
Sub AddParameterToArray(anObj, aParam, aStream, AcceptComment)
If (Not AcceptComment And aParam = "MFG_COMMENT") Then Exit Sub
Dim anAttribut As AnyObject
Dim AttrVal As String
On Error Resume Next
Set anAttribut = anObj.getAttribute(aParam)
Dim erreur As Integer
erreur = Err.Number
Err.Clear
If (erreur = 0) Then
AttrVal = anAttribut.ValueAsString
erreur = Err.Number
Err.Clear
If (erreur = 0 And AttrVal <> "") Then
WriteLine aStream, "<tr><td><font size=-1><b>" & ToNLS(anObj, aParam) & "</b></font></td><td><font size=-1>" & ToNLS(anObj,AttrVal) & "</font></td></tr>"
End If
End If
On Error GoTo 0
End Sub
'----------------------------------------------------------------------
' Destruction d'un repertoire
' RemoveDirectory = 0 : Ok
' 1 : erreur de lecture du repertoire foldername
' 2 : erreur suppression de fichier ou de repertoire
'----------------------------------------------------------------------
Function RemoveDirectory(foldername)
Dim fso As FileSystem
Set fso = CATIA.FileSystem
Dim result As Integer
Dim aFolder As Folder
result = 0
On Error Resume Next
Set aFolder = fso.GetFolder(foldername)
Dim erreur As Integer
erreur = Err.Number
Err.Clear
If (erreur <> 0) Then
Set aFolder = Nothing
RemoveDirectory = 1
Exit Function
End If
Dim thefiles As Files
Dim nbfiles As Integer
Dim FilePath As String
Set thefiles = aFolder.Files
nbfiles = thefiles.Count
For index = nbfiles To 1 Step -1
FilePath = thefiles.Item(index).Path
fso.DeleteFile FilePath
erreur = Err.Number
Err.Clear
If (erreur <> 0) Then
Set thefiles = Nothing
Set aFolder = Nothing
RemoveDirectory = 2
Exit Function
End If
Next
Set thefiles = Nothing
Dim theFolders As Folders
Dim nbfolders As Integer
Dim FolderPath As String
Set theFolders = aFolder.SubFolders
nbfolders = theFolders.Count
For index = nbfolders To 1 Step -1
Dim delfolder As Integer
FolderPath = theFolders.Item(index).Path
delfolder = RemoveDirectory(FolderPath)
If (delfolder <> 0) Then
Set theFolders = Nothing
Set aFolder = Nothing
RemoveDirectory = delfolder
Exit Function
End If
Next
Set theFolders = Nothing
Set aFolder = Nothing
fso.DeleteFolder foldername
erreur = Err.Number
Err.Clear
If (erreur <> 0) Then result = 2
On Error GoTo 0
RemoveDirectory = result
End Function
Function ContinueIfExistingFolder(aPath)
Dim fso As FileSystem
Set fso = CATIA.FileSystem
Dim reponse As Boolean
reponse = False
EmptyFolder = False
On Error Resume Next
Dim aFolder As Folder
Dim subdir As Folders
Dim thefiles As Files
If (fso.FolderExists(aPath)) Then
Set aFolder = fso.GetFolder(aPath)
Dim erreur As Integer
erreur = Err.Number
Err.Clear
If (erreur = 0) Then
Set subdir = aFolder.SubFolders
Dim subdircount As Integer
subdircount = subdir.Count
If (subdircount = 0) Then
Set thefiles = aFolder.Files
Dim filecount As Integer
filecount = thefiles.Count
If (filecount = 0) Then reponse = True 'Ok si repertoire vide
Set thefiles = Nothing
End If
Set subdir = Nothing
End If
Set aFolder = Nothing
End If
If (reponse) Then
ContinueIfExistingFolder = True
Exit Function
End If
DeleteDirPrompt = "Existing directory : " & aPath & Chr(13) & "Delete it?"
Dim deldir As Integer
deldir = MsgBox(DeleteDirPrompt, 4385, "Delete directory?") 'boite modale
If (deldir = 1) Then
deldir = RemoveDirectory(aPath)
If (reponse <> 0) Then
Set fso = CATIA.FileSystem
If (fso.FolderExists(aPath)) Then
Set aFolder = fso.GetFolder(aPath)
erreur = Err.Number
Err.Clear
If (erreur = 0) Then
Set subdir = aFolder.SubFolders
subdircount = subdir.Count
If (subdircount = 0) Then
Set thefiles = aFolder.Files
filecount = thefiles.Count
If (filecount = 0) Then reponse = True
Set thefiles = Nothing
End If
Set subdir = Nothing
End If
Set aFolder = Nothing
End If
Else
reponse = True
End If
End If
On Error GoTo 0 'pdu***
ContinueIfExistingFolder = reponse
End Function
'----------------------------------------------------------------------
' Lecture d'un chemin defini par une variable d'environnement.
' Possibilite d'ajouter un sous repertoire de ce chemin.
'----------------------------------------------------------------------
Function GetPath(anEnvVar, aSubDir)
If (anEnvVar = "") Then
GetPath = ""
Exit Function
End If
Dim EnvValue As String
Dim ErrVal As Integer
On Error Resume Next
EnvValue = CATIA.SystemService.Environ(anEnvVar)
ErrVal = Err.Number
Err.Clear
If (ErrVal <> 0) Then
GetPath = ""
Exit Function
End If
Dim strlength As Integer
strlength = Len(EnvValue)
If (strlength < 1) Then
GetPath = ""
Exit Function
End If
Dim bidstr as String
For i = 1 To strlength
if(Mid(EnvValue, i, 1) = ":") then
bidstr = bidstr & ";"
else
bidstr = bidstr & Mid(EnvValue, i, 1)
end if
Next
EnvValue = bidstr
Dim aFileSystem As FileSystem
Dim issemicolon As Boolean
Dim i, prevpos As Integer
Dim aPath As String
Set aFileSystem = CATIA.FileSystem
If (Mid(EnvValue, strlength, 1) <> ";") Then
EnvValue = EnvValue & ";"
strlength = strlength + 1
End If
If (aSubDir <> "") Then
If (Mid(aSubDir, Len(aSubDir), 1) <> "/" And Mid(aSubDir, Len(aSubDir), 1) <> "\") Then aSubDir = aSubDir & "/"
End If
prevpos = 0
For i = 1 To strlength
issemicolon = (Mid(EnvValue, i, 1) = ";")
If (prevpos <> 0) Then
If (issemicolon) Then
aPath = Mid(EnvValue, prevpos, i - prevpos)
If (Mid(aPath, Len(aPath), 1) <> "/" And Mid(aPath, Len(aPath), 1) <> "\") Then aPath = aPath & "/"
aPath = aPath & aSubDir
If (aFileSystem.FolderExists(aPath)) Then
GetPath = aPath
Exit Function
End If
prevpos = 0
End If
Else
If (Not issemicolon) Then prevpos = i
End If
Next
aFileSystem = Nothing
On Error GoTo 0 'pdu***
GetPath = "" 'Pas trouve de chemin
End Function
'------------------------------------------------
' Teste si un parametre est dans la liste de ceux
' qui ne doivent pas etre traites
'------------------------------------------------
Function ParameterIsIgnored(aParam)
For i = 1 To NbIgnoredParameters
If (aParam = IgnoredParameters(i)) Then
ParameterIsIgnored = True
Exit Function
End If
Next
ParameterIsIgnored = False
End Function
'------------------------------------------------
' Ajout du tableau des parametres d'une resource
'------------------------------------------------
Sub AddResourceParameters(aResource, aStream)
Dim TabAtt()
Dim att As Integer
Dim nbatt As Integer
nbatt = aResource.NumberOfAttributes
If (nbatt = 0) Then Exit Sub
ReDim TabAtt(nbatt)
aResource.GetListOfAttributes TabAtt
WriteLine aStream, "<center><table BORDER=0 CELLSPACING=3 CELLPADDING=3 BGCOLOR=""#C5C5E2"">"
For att = 0 To nbatt - 1
If (Not ParameterIsIgnored(TabAtt(att))) Then
AddParameterToArray aResource, TabAtt(att), aStream, False
End If
Next
WriteLine aStream, "</table></center>"
End Sub
'---------------------------------------------------------------
' Tool assembly
'---------------------------------------------------------------
'---------------------------------------------------------------
' Ajout d'un assembly dans la liste
'---------------------------------------------------------------
Sub WriteAssembly(anAssembly, aStream)
Dim erreur As Integer
Dim AssemblyNumber As Integer
Dim aName, AssemblyType As String
AssemblyNumber = anAssembly.Number
AssemblyType = anAssembly.AssemblyType
On Error Resume Next
Set Attribut = anAssembly.getAttribute("MFG_NAME")
erreur = Err.Number
Err.Clear
If (erreur = 0) Then aName = Attribut.Value
On Error GoTo 0
WriteLine aStream, "<a NAME=""A" & AssemblyNumber & """></a>"
WriteLine aStream, "<center><table BORDER=1 CELLSPACING=2 CELLPADDING=5 WIDTH=""80%"">"
WriteLine aStream, "<tr VALIGN=""MIDDLE"">"
WriteLine aStream, "<td WIDTH=""50%"" BGCOLOR=""#C6C6FF""><b><font size=+1><a href=""Assembly" & AssemblyNumber & ".html"">Assembly " & AssemblyNumber & " : " & aName & "</a></font></b></td>"
aName = GetToolAssemblyImage(anAssembly, True)
If (aName <> "") Then
WriteLine aStream, "<td ALIGN=""CENTER"" WIDTH=""100"">"
WriteLine aStream, "<img SRC=""" & aName & """>"
WriteLine aStream, "</td>"
End If
WriteLine aStream, "<td>"
WriteLine aStream, "Type : " & ToNLS(anAssembly,AssemblyType) & "<br>"
Dim AssTool As ManufacturingTool
Set AssTool = anAssembly.Tool
On Error Resume Next
Set Attribut = AssTool.getAttribute("MFG_NAME")
erreur = Err.Number
Err.Clear
If (erreur = 0) Then aName = Attribut.Value
If (aName <> "") Then WriteLine aStream, "Tool : <a href=""Assembly" & AssemblyNumber & ".html#Tool"">" & aName & "</a><br>"
If (AssemblyType = "MfgLatheToolAssembly") Then
Dim anInsert As ManufacturingInsert
Set anInsert = anAssembly.Insert
Set Attribut = anInsert.getAttribute("MFG_NAME")
erreur = Err.Number
Err.Clear
If (erreur = 0) Then
aName = Attribut.Value
If (aName <> "") Then WriteLine aStream, "Insert : <a href=""Assembly" & AssemblyNumber & ".html#Insert"">" & aName & "</a><br>"
End If
End If
WriteLine aStream, "</td>"
WriteLine aStream, "</tr>"
WriteLine aStream, "</table></center>"
WriteLine aStream, "<br>"
End Sub
'---------------------------------------------------------------
' Page relative a un tool assembly
'---------------------------------------------------------------
Sub CreateOneAssemblySheet(anAssembly, aProcessName)
Dim erreur As Integer
Dim AssemblyNumber As Variant
Dim AssemblyName, AssemblyType As String
AssemblyType = anAssembly.AssemblyType
AssemblyNumber = anAssembly.Number
On Error Resume Next
Set Attribut = anAssembly.getAttribute("MFG_NAME")
erreur = Err.Number
Err.Clear
If (erreur = 0) Then AssemblyName = Attribut.Value
Dim aFileSyst As FileSystem
Set aFileSyst = CATIA.FileSystem
Dim theAssemblyFile As File
Dim aStream As TextStream
Dim FileName As String
FileName = "Assembly" & AssemblyNumber & ".html"
Set theHTMLFile = aFileSyst.CreateFile(HtmlFilesPath & FileName, True)
Set aStream = theHTMLFile.OpenAsTextStream("ForWriting")
'Debut de la page
WriteLine aStream, "<html>"
WriteLine aStream, "<head>"
WriteLine aStream, "<title>Assembly " & AssemblyNumber & " : " & AssemblyName & "</title>"
WriteLine aStream, "</head>"
'Ecriture de l'entete
WriteLine aStream, "<table CELLSPACING=0 CELLPADDING=5><tr>"
If (ExistLogoDS) Then
WriteLine aStream, "<td ALIGN=CENTER><img SRC=""navlogocat.gif"" BORDER=0></td>"
End If
WriteLine aStream, "<td BGCOLOR=""#000099"">"
WriteLine aStream, "<b><font color=""#FFFFFF"" size=+2>"
WriteLine aStream, "TOOL LIST<br>"
WriteLine aStream, aProcessName
WriteLine aStream, "</font></b></td>"
WriteLine aStream, "</tr></table>"
WriteLine aStream, "<br><br>"
WriteLine aStream, "<table BORDER=0 CELLSPACING=0 CELLPADDING=5 WIDTH=""100%"" BGCOLOR=""#3366FF"">"
WriteLine aStream, "<tr VALIGN=""TOP"" ALIGN=""LEFT"">"
WriteLine aStream, "<td><b><font color=""#FFFFFF"" size=+3>Assembly " & AssemblyNumber & " : </td></font></b>"
WriteLine aStream, "<td><b><font color=""#FFFFFF"" size=+3>" & AssemblyName & "</font>"
Dim AssToolName As String
Dim AssTool As ManufacturingTool
Set AssTool = anAssembly.Tool
Set Attribut = AssTool.getAttribute("MFG_NAME")
erreur = Err.Number
Err.Clear
If (erreur = 0) Then
AssToolName = Attribut.Value
WriteLine aStream, "<br>"
WriteLine aStream, "<font color=""#FFFFFF"" size=+2>Tool : " & AssToolName
If (AssemblyType = "MfgLatheToolAssembly") Then
Dim anInsert As ManufacturingInsert
Dim InsertName As String
Set anInsert = anAssembly.Insert
Set Attribut = anInsert.getAttribute("MFG_NAME")
erreur = Err.Number
Err.Clear
If (erreur = 0) Then
InsertName = Attribut.Value
WriteLine aStream, "<br>"
WriteLine aStream, "Insert : " & InsertName
End If
End If
WriteLine aStream, "</font>"
End If
WriteLine aStream, "</b></td>"
WriteLine aStream, "</tr>"
WriteLine aStream, "</table>"
'Fin de l'ecriture de l'entete
WriteLine aStream, "<br><br>"
WriteAssemblyTable anAssembly, aStream, False
WriteLine aStream, "<p><hr WIDTH=""60%""></p>"
Dim UsedTool As ManufacturingTool
Set UsedTool = anAssembly.Tool
WriteLine aStream, "<p><a NAME=""Tool""></a></p>"
WriteToolTable UsedTool, aStream, True
If (AssemblyType = "MfgLatheToolAssembly") Then
Dim UsedInsert As ManufacturingInsert
Dim theType As String
Set UsedInsert = anAssembly.Insert
theType = UsedInsert.InsertType
erreur = Err.Number
Err.Clear
If (erreur = 0) Then
WriteLine aStream, "<p><a NAME=""Insert""></a></p>"
WriteLine aStream, "<p><hr WIDTH=""60%""></p>"
WriteInsertTable UsedInsert, aStream, True
End If
End If
WriteLine aStream, "</body>"
WriteLine aStream, "</html>"
aStream.Close
Set theHTMLFile = Nothing
Set aStream = Nothing
On Error GoTo 0 'pdu***
End Sub
Sub WriteAssemblyTable(anAssembly, aStream, writecaption)
Dim AssemblyName, AssemblyType, AssemblyComment As String
AssemblyName = anAssembly.Name
AssemblyType = anAssembly.AssemblyType
If (writecaption) Then WriteLine aStream, "<p><center><b><font color=""#3333FF"" size=+2>" & AssemblyName & "</font></b></center></p>"
WriteLine aStream, "<center><table BORDER=0 CELLSPACING=5>"
WriteLine aStream, "<tr>"
WriteLine aStream, "<td ALIGN=LEFT>"
AddResourceParameters anAssembly, aStream
WriteLine aStream, "</td>"
Dim ImgName As String
ImgName = GetToolAssemblyImage(anAssembly, False)
If (ImgName <> "") Then
WriteLine aStream, "<td ALIGN=RIGHT>"
WriteLine aStream, "<center><img BORDER=0 SRC=""" & ImgName & """>"
WriteLine aStream, "<br>Type : " & ToNLS(anAssembly,AssemblyType) & "</center>"
WriteLine aStream, "</td>"
Else
WriteLine aStream, "<br>"
WriteLine aStream, "<center>Type : <b>" & ToNLS(anAssembly,AssemblyType) & "</b></center>"
End If
WriteLine aStream, "</tr>"
' Commentaire
'------------
AssemblyComment = anAssembly.Comment
If (AssemblyComment <> "") Then
WriteLine aStream, "<tr>"
WriteLine aStream, "<td COLSPAN=""2"">"
WriteLine aStream, "<center><table BORDER=1 CELLSPACING=0 CELLPADDING=5 WIDTH=""75%"" BGCOLOR=""#FFFFFF"">"
WriteLine aStream, "<tr>"
WriteLine aStream, "<td>" & AssemblyComment & "</td>"
WriteLine aStream, "</tr>"
WriteLine aStream, "</table></center>"
WriteLine aStream, "</td>"
WriteLine aStream, "</tr>"
End If
WriteLine aStream, "</table></center>"
End Sub
Sub WriteInsertTable(anInsert, aStream, writecaption)
Dim InsertName, aType As String
On Error Resume Next
Set Attribut = anInsert.getAttribute("MFG_NAME")
Dim erreur As Integer
erreur = Err.Number
Err.Clear
If (erreur = 0) Then InsertName = Attribut.Value
aType = anInsert.InsertType
If (writecaption) Then WriteLine aStream, "<p><center><b><font color=""#3333FF"" size=+2>" & InsertName & "</font></b></center></p>"
WriteLine aStream, "<center><table BORDER=0 CELLSPACING=5>"
WriteLine aStream, "<tr>"
WriteLine aStream, "<td ALIGN=LEFT>"
AddResourceParameters anInsert, aStream
WriteLine aStream, "</td>"
Dim ImgName As String
ImgName = GetInsertImage(anInsert, False)
If (ImgName <> "") Then
WriteLine aStream, "<td ALIGN=RIGHT>"
WriteLine aStream, "<center><img BORDER=0 SRC=""" & ImgName & """>"
WriteLine aStream, "<br>Type : " & ToNLS(anInsert,aType) & "</center>"
WriteLine aStream, "</td>"
Else
WriteLine aStream, "<br>"
WriteLine aStream, "<center>Type : <b>" & ToNLS(anInsert,aType) & "</b></center>"
End If
WriteLine aStream, "</tr>"
' Commentaire
'------------
Dim InsertComment As String
InsertComment = anInsert.Comment
If (InsertComment <> "") Then
WriteLine aStream, "<tr>"
WriteLine aStream, "<td COLSPAN=""2"">"
WriteLine aStream, "<center><table BORDER CELLSPACING=0 CELLPADDING=5 WIDTH=""75%"" BGCOLOR=""#FFFFFF"">"
WriteLine aStream, "<tr>"
WriteLine aStream, "<td>" & InsertComment & "</td>"
WriteLine aStream, "</tr>"
WriteLine aStream, "</table></center>"
WriteLine aStream, "</td>"
WriteLine aStream, "</tr>"
End If
WriteLine aStream, "</table></center>"
End Sub
Function GetInsertImage(anInsert, IsSmall)
Dim fso As FileSystem
Set fso = CATIA.FileSystem
Dim aType, FileName As String
aType = anInsert.InsertType
Select Case aType
Case "MfgDiamondInsert"
FileName = "nldiamnd"
Case "MfgSquareInsert"
FileName = "nlsquare"
Case "MfgTriangularInsert"
FileName = "nltriang"
Case "MfgRoundInsert"
FileName = "nlround"
Case "MfgTrigonInsert"
FileName = "nltrigon"
Case "MfgGrooveInsert"
FileName = "nlgroove"
Case "MfgThreadInsert"
FileName = "nlthread"
Case Else
FileName = ""
End Select
If (FileName <> "") Then
If (IsSmall) Then FileName = FileName & "-small"
FileName = FileName & ".gif"
End If
If (FileName <> "") Then
Dim target As String
target = HtmlFilesPath & FileName
If (Not (fso.FileExists(target))) Then
Dim rep As Integer
rep = FileCopy(CATIAComponentPath & FileName, target, True)
If (rep <> 0) Then FileName = ""
End If
End If
GetInsertImage = FileName
End Function
'-------------------------------------------------------------
' Gestion du fichier log
'-------------------------------------------------------------
Sub OpenLogFile
if(theLogMode) then
dim theLogName as String
Dim aFileSyst As FileSystem
Set aFileSyst = CATIA.FileSystem
theLogName = HtmlFilesPath & "ToolList.log"
Set theLogFile = aFileSyst.CreateFile(theLogName,True)
Set theLogStream = theLogFile.OpenAsTextStream("ForWriting")
End If
End Sub
Sub CloseLogFile
if(theLogMode) then
theLogStream.Close
Set theLogFile = Nothing
Set theLogStream = Nothing
End If
End Sub
Sub UpdateLogFile (aString)
if(theLogMode) then
WriteLine theLogStream, aString
WriteLine theLogStream, "--------------------------------------------------------------------------------"
End If
End Sub