DRAWING - Cartouche personnalisé - Repositionnement Logo après changement de format de feuille

Bonjour,

J'ai réussi à modifier le code de base fournis pas DASSAULT pour générer un cartouche propre à la société où je travail.
Je me suis aussi inspirer de ce post pour y ajouter le logo de la société, le code fonctionne mais l'image ne se repositionne pas si je modifie le format du calque (ex: Passer d'un A4 à un A0) comme le fait l'ensemble du cartouche.

Avez vous une idée pour y remédier? (Voir code ci-dessous

Code:

'COPYRIGHT SOCIETE 2016

' ****************************************************************************
' Purpose:       To draw a Frame and TitleBlock
'
' Assumptions:   A Drafting document should be active
'
' Author:        SOCIETE
' Languages:     VBScript
' Version:       V5R20
' Reg. Settings: French (FRANCE)
' ****************************************************************************
Public ActiveDoc     As Document
Public Sheets
Public Sheet
Public Views
Public View
Public Texts         As DrawingTexts
Public Text          As DrawingText
Public Fact          As Factory2D
Public Selection     As Selection

Function Col(idx As Integer) As Variant
  Col=Array(-190, -173, -154, -132, -100, -36, -20, -20)(idx-1)
End Function

Function Row(idx As Integer) As Variant
  Row=Array( 6, 15, 19, 28, 33, 38, 43)(idx-1)  
End Function

Function GetRulerLength() as Double
  GetRulerLength = 200.
End Function

Function GetMacroID() as String
  GetMacroID = "Cartouche SOCIETE"
End Function

Function GetNbOfRevision() as Integer
  GetNbOfRevision = 1
End Function

Function GetRevRowHeight() as Double
  GetRevRowHeight = 7.
End Function

Function GetDisplayFormat() as String
  GetDisplayFormat = Array("Letter","Legal","A0","A1","A2","A3","A4","A","B","C","D","E","F","User")( Sheet.PaperSize )
End Function

Function GetOffset() as Double  
  If Sheet.PaperSize  = CatPaperA0 Or Sheet.PaperSize  = CatPaperA1 Or ( Sheet.PaperSize  = CatPaperUser And (GetWidth() > 594. Or GetHeight() > 594.)) Then
    GetOffset = 10.
  Else
    GetOffset = 10.
  End If
End Function

Function GetWidth() as Double
  Select Case TypeName(Sheet)
    Case "DrawingSheet" : GetWidth=Sheet.GetPaperWidth
    Case "Layout2DSheet": GetWidth=Sheet.PaperWidth  
  End Select
End Function
  
Function GetHeight() as Double
  Select Case TypeName(Sheet)
    Case "DrawingSheet" : GetHeight=Sheet.GetPaperHeight
    Case "Layout2DSheet": GetHeight=Sheet.PaperHeight  
  End Select
End Function
  
Function GetOH() as Double
  GetOH = GetWidth() - GetOffset()
End Function

Function GetOV() as Double
  GetOV = GetOffset()
End Function

Function GetColRev(index As Integer)
  GetColRev = Array(-190, -180, -154, -72, -36, -36)(index-1)
End Function

Function GetRevLetter(index As Integer)
   GetRevLetter = Chr(Asc("A")+index-1)
End Function

Function CreateLine( iX1 As Double, iY1 As Double, iX2 As Double, iY2 As Double, iName As String) As Curve2D  
  '-------------------------------------------------------------------------------
  ' Creates a sketcher lines thanks to the current 2D factory set to the global variable Fact
  ' The created line is reneamed to the given iName
  ' Start point  and End point are created and renamed iName&"_start", iName&"_end"
  '-------------------------------------------------------------------------------
  Set CreateLine = Fact.CreateLine( iX1, iY1, iX2, iY2)
  CreateLine.Name = iName
  Set point=CreateLine.StartPoint 'Create the start point
  point.Name = iName&"_start"
  Set point=CreateLine.EndPoint 'Create the start point
  point.Name = iName&"_end"
End Function

Function CreateText(iCaption as String, iX as Double, iY As Double, iName As String) As DrawingText
  '-------------------------------------------------------------------------------
  'How to create a text
  '-------------------------------------------------------------------------------
  Set CreateText = Texts.Add(iCaption, iX, iY)
  CreateText.Name= iName
  CreateText.AnchorPosition = catMiddleCenter
End Function

Function CreateTextAF(iCaption as String, iX as Double, iY As Double, iName As String, iAnchorPosition As CatTextAnchorPosition, iFontSize As Double) As DrawingText
  '-------------------------------------------------------------------------------
  'How to create a text
  '-------------------------------------------------------------------------------
  Set CreateTextAF = Texts.Add(iCaption, iX, iY)
  CreateTextAF.Name           = iName
  CreateTextAF.AnchorPosition = iAnchorPosition
  CreateTextAF.SetFontSize      0, 0, iFontSize  
End Function

Sub SelectAll( iQuery as String )
  Selection.Clear
  Selection.Add(View)
  'MsgBox iQuery
  Selection.Search iQuery&",sel"  
End Sub

Sub DeleteAll( iQuery as String )
  '-------------------------------------------------------------------------------
  'Delete all elements  matching the query string iQuery
  'Pay attention no to provide a localized query string.
  '-------------------------------------------------------------------------------
  Selection.Clear
  Selection.Add(View)
  'MsgBox iQuery
  Selection.Search iQuery&",sel"  
  ' Avoid Delete failure in case of an empty query result
  If Selection.Count2<>0 Then Selection.Delete      
End Sub

Sub CATMain()
  If Not CATInit(targetSheet) Then Exit Sub
  On Error Resume Next
    name = Texts.GetItem("Reference_" + GetMacroID()).Name
  If Err.Number <> 0 Then
    Err.Clear
    name = "none"
  End If
  On Error Goto 0
  If (name = "none") Then
    CATDrw_Creation
  Else  
    CATDrw_Resizing
    CATDrw_Update
  End If
  CATExit
End Sub

Sub CATDrw_Creation( targetSheet as CATIABase )
  '-------------------------------------------------------------------------------
  'How to create the FTB
  '-------------------------------------------------------------------------------
  If Not CATInit(targetSheet) Then Exit Sub  
  If CATCheckRef(1) Then Exit Sub 'To check whether a FTB exists already in the sheet
  CATCreateReference          'To place on the drawing a reference point
  CATCreateTitleBlockStandard 'To draw the standard representation
  CATFrame      'To draw the frame  
  CATCreateTitleBlockFrame    'To draw the geometry
  CATTitleBlockText     'To fill in the title block
  CATColorGeometry 'To change the geometry color
  CATExit targetSheet      'To save the sketch edition
End Sub

Sub CATDrw_Deletion( targetSheet as CATIABase )
  '-------------------------------------------------------------------------------
  'How to delete the FTB
  '-------------------------------------------------------------------------------
  If Not CATInit(targetSheet) Then Exit Sub  
  If CATCheckRef(0) Then Exit Sub
  DeleteAll "..Name=Frame_*"
  DeleteAll "..Name=TitleBlock_*"
  DeleteAll "..Name=RevisionBlock_*"
  DeleteAll "..Name=Reference_*"
  DeleteAll "..Name=TitleBlock_Logo_*"
  CATExit targetSheet
End Sub

Sub CATDrw_Resizing( targetSheet as CATIABase )
  '-------------------------------------------------------------------------------
  'How to resize the FTB
  '-------------------------------------------------------------------------------
  If Not CATInit(targetSheet) Then Exit Sub
  If CATCheckRef(0) Then Exit Sub  
  Dim TbTranslation(2)
  ComputeTitleBlockTranslation TbTranslation
  Dim RbTranslation(2)
  ComputeRevisionBlockTranslation RbTranslation
  If TbTranslation(0) <> 0 Or TbTranslation(1) <> 0 Then
    ' Redraw Sheet Frame
    DeleteAll "CATDrwSearch.DrwText.Name=Frame_Text_*"
    DeleteAll "CATDrwSearch.2DGeometry.Name=Frame_*"    
    DeleteAll "CATDrwSearch.2DGeometry.Name=TitleBlock_Logo_*"    
    CATFrame    
    
    ' Redraw Title Block Frame
    CATDeleteTitleBlockFrame
    CATCreateTitleBlockFrame    
    CATMoveTitleBlockText TbTranslation
    
    ' Redraw revision block    
    CATDeleteRevisionBlockFrame
    CATCreateRevisionBlockFrame    
    CATMoveRevisionBlockText RbTranslation

    ' Redraw TitleBlockStandard
    CATDeleteTitleBlockStandard
    CATCreateTitleBlockStandard  

    ' Move the views
    CATColorGeometry
    CATMoveViews TbTranslation
    CATLinks
    
  End If
  CATExit targetSheet
End Sub

Sub CATDrw_Update( targetSheet as CATIABase )
  '-------------------------------------------------------------------------------
  'How to update the FTB
  '-------------------------------------------------------------------------------
  If Not CATInit(targetSheet) Then Exit Sub  
  If CATCheckRef(0) Then Exit Sub
  CATLinks
  CATColorGeometry
  CATExit targetSheet

End Sub

Function GetContext()
  ' Find execution context  
  Select Case TypeName( Sheet )
    Case "DrawingSheet"
      Select Case TypeName( ActiveDoc )
        Case "DrawingDocument": GetContext="DRW"
        Case "ProductDocument": GetContext="SCH"
        Case Else: GetContext="Unexpected"
      End Select        
      
    Case "Layout2DSheet" : GetContext="LAY"
    Case Else : GetContext="Unexpected"
  End Select
End Function

Sub CATDrw_AddRevisionBlock( targetSheet as CATIABase )
  '-------------------------------------------------------------------------------
  'How to create or modify a revison block
  '-------------------------------------------------------------------------------
  If Not CATInit(targetSheet) Then Exit Sub
  If CATCheckRef(0) Then Exit Sub
  
  CATAddRevisionBlockText 'To fill in the title block
  CATDeleteRevisionBlockFrame
  CATCreateRevisionBlockFrame 'To draw the geometry
    
  CATColorGeometry
  CATExit targetSheet
End Sub

Function CATInit( targetSheet as CATIABase )
  '-------------------------------------------------------------------------------
  'How to init the dialog and create main objects
  '-------------------------------------------------------------------------------
  Set Selection    = CATIA.ActiveDocument.Selection
  Set Sheet        = targetSheet
  Set Sheets       = Sheet.Parent
  Set ActiveDoc    = Sheets.Parent
  Set Views        = Sheet.Views
  Set View         = Views.Item(2)'Get the background view
  Set Texts        = View.Texts
  Set Fact         = View.Factory2D
  
  If GetContext()="Unexpected" Then
      Msg = "The macro runs in an inappropriate environment."&chr(13)&"The script will terminate wihtout finishing the current action."
      Title ="Unexpected environement error"
      MsgBox Msg,16, Title
    CATInit=FALSE 'Exit with error
      Exit Function
  End If

  Selection.Clear
  CATIA.HSOSynchronized=False

  'Exit without error
  CATInit=TRUE 'Exit without error
End Function

Sub CATExit( targetSheet as CATIABase )
  '-------------------------------------------------------------------------------
  'How to restore the document working mode
  '-------------------------------------------------------------------------------
  Selection.Clear
  CATIA.HSOSynchronized=True

  View.SaveEdition
End Sub


Sub CATCreateReference()
  '-------------------------------------------------------------------------------
  'How to create a reference text
  '-------------------------------------------------------------------------------
  Set Text = Texts.Add("", GetWidth() - GetOffset(), GetOffset())
  Text.Name = "Reference_" + GetMacroID
End Sub

Function CATCheckRef(Mode As Integer) As Integer
  '-------------------------------------------------------------------------------
  'How to check that the called macro is the right one
  '-------------------------------------------------------------------------------
  nbTexts = Texts.Count
  i = 0
  notFound = 0
  While (notFound = 0 And i<nbTexts)
    i = i + 1    
    Set Text = Texts.Item(i)
    WholeName = Text.Name
    leftText = Left(WholeName, 10)
    If (leftText = "Reference_") Then
      notFound = 1
      refText = "Reference_" + GetMacroID()
      If (Mode = 1) Then
        MsgBox "Frame and Titleblock already created!"
        CATCheckRef = 1
        Exit Function
      ElseIf (Text.Name <> refText) Then
        MsgBox "Frame and Titleblock created using another style:" + Chr(10) + "        " + GetMacroID()
        CATCheckRef = 1
        Exit Function
      Else
        CATCheckRef = 0
        Exit Function        
      End If
    End If
  Wend

  If Mode = 1 Then
    CATCheckRef = 0
  Else
    MsgBox "No Frame and Titleblock!"
    CATCheckRef = 1    
  End If

End Function

Function CATCheckRev() As Integer
  '-------------------------------------------------------------------------------
  'How to check that a revision block alredy exists
  '-------------------------------------------------------------------------------
  SelectAll "CATDrwSearch.DrwText.Name=RevisionBlock_Text_Rev_*"
  CATCheckRev = Selection.Count2
End Function

Sub CATFrame()
  '-------------------------------------------------------------------------------
  'How to create the Frame
  '-------------------------------------------------------------------------------
  Dim Cst_1   As Double  'Length (in cm) between 2 horinzontal marks
  Dim Cst_2   As Double  'Length (in cm) between 2 vertical marks
  Dim Nb_CM_H As Integer 'Number/2 of horizontal centring marks
  Dim Nb_CM_V As Integer 'Number/2 of vertical centring marks
  Dim Ruler   As Integer 'Ruler length (in cm)

  CATFrameStandard     Nb_CM_H, Nb_CM_V, Ruler, Cst_1, Cst_2
  CATFrameBorder
  CATFrameCentringMark Nb_CM_H, Nb_CM_V, Ruler, Cst_1, Cst_2
  CATFrameText         Nb_CM_H, Nb_CM_V, Ruler, Cst_1, Cst_2
  CATFrameRuler        Ruler, Cst_1
End Sub

Sub CATFrameStandard(Nb_CM_H As Integer, Nb_CM_V As Integer, Ruler As Integer, Cst_1 As Double, Cst_2 As Double)
  '-------------------------------------------------------------------------------
  'How to compute standard values
  '-------------------------------------------------------------------------------
  Cst_1 = 74.2 '297, 594, 1189 are multiples of 74.2
  Cst_2 = 52.5 '210, 420, 841  are multiples of 52.2

  If Sheet.Orientation = CatPaperPortrait And _
     (Sheet.PaperSize  = CatPaperA0 Or _
      Sheet.PaperSize  = CatPaperA2 Or _
      Sheet.PaperSize  = CatPaperA4) Or _
      Sheet.Orientation = CatPaperLandscape And _
     (Sheet.PaperSize  = CatPaperA1 Or _
      Sheet.PaperSize  = CatPaperA3) Then
    Cst_1 = 52.5
    Cst_2 = 74.2
  End If

  Nb_CM_H = CInt(.5 * GetWidth() / Cst_1)
  Nb_CM_V = CInt(.5 * GetHeight() / Cst_2)
  Ruler   = CInt((Nb_CM_H - 1) * Cst_1 / 50) * 100 'here is computed the maximum ruler length
  If GetRulerLength() < Ruler Then Ruler = GetRulerLength()
End Sub

Sub CATFrameBorder()
  '-------------------------------------------------------------------------------
  'How to draw the frame border
  '-------------------------------------------------------------------------------
  On Error Resume Next
    CreateLine GetOV(),  GetOV()             ,  GetOH(),  GetOV()             , "Frame_Border_Bottom"
    CreateLine GetOH(),  GetOV()             ,  GetOH(),  GetHeight() - GetOffset(), "Frame_Border_Left"
    CreateLine GetOH(),  GetHeight() - GetOffset(),  GetOV(),  GetHeight() - GetOffset(), "Frame_Border_Top"
    CreateLine GetOV(),  GetHeight() - GetOffset(),  GetOV(),  GetOV()             , "Frame_Border_Right"
    If Err.Number <> 0 Then Err.Clear
  On Error Goto 0
End Sub

Sub CATFrameCentringMark(Nb_CM_H As Integer, Nb_CM_V As Integer, Ruler As Integer, Cst_1 As Double, Cst_2 As Double)
  '-------------------------------------------------------------------------------
  'How to draw the centring marks
  '-------------------------------------------------------------------------------
  On Error Resume Next
    CreateLine .5 * GetWidth()    ,  GetHeight() - GetOffset(),  .5 * GetWidth(),  GetHeight()     , "Frame_CentringMark_Top"
    CreateLine .5 * GetWidth()    ,  GetOV()             ,  .5 * GetWidth(),  .0         , "Frame_CentringMark_Bottom"
    CreateLine GetOV()            ,  .5 * GetHeight()    ,  .0        ,  .5 * GetHeight(), "Frame_CentringMark_Left"
    CreateLine GetWidth() - GetOffset(),  .5 * GetHeight()    ,  GetWidth()     ,  .5 * GetHeight(), "Frame_CentringMark_Right"
    For i = Nb_CM_H To Ruler/2/Cst_1 Step -1
      If (i * Cst_1 < .5 * GetWidth() - 1.) Then
        x=.5 * GetWidth() + i * Cst_1
        CreateLine x,  GetOV(),  x,  .25 * GetOffset(), "Frame_CentringMark_Bottom_"&Int(x)
        x=.5 * GetWidth() - i * Cst_1
        CreateLine x,  GetOV(),  x,  .25 * GetOffset(), "Frame_CentringMark_Bottom_"&Int(x)
      End If
    Next
    For i = 1 To Nb_CM_H
      If (i * Cst_1 < .5 * GetWidth() - 1.) Then
        x=.5 * GetWidth() + i * Cst_1
        CreateLine x,  GetHeight() - GetOffset(),  x,  GetHeight() - .25 * GetOffset(), "Frame_CentringMark_Top_"&Int(x)
        x=.5 * GetWidth() - i * Cst_1
        CreateLine x,  GetHeight() - GetOffset(),  x,  GetHeight() - .25 * GetOffset(), "Frame_CentringMark_Top_"&Int(x)
      End If
    Next

    For i = 1 To Nb_CM_V
      If (i * Cst_2 < .5 * GetHeight() - 1.) Then
        y= .5 * GetHeight() + i * Cst_2
        CreateLine GetOV(), y,              .25 * GetOffset(),  y, "Frame_CentringMark_Left_"&Int(y)
        CreateLine GetOH(), y, GetWidth() - .25 * GetOffset(),  y, "Frame_CentringMark_Right_"&Int(y)
        y= .5 * GetHeight() - i * Cst_2
        CreateLine GetOV(), y,               .25 * GetOffset(), y, "Frame_CentringMark_Left_"&Int(y)
        CreateLine GetOH(), y,  GetWidth() - .25 * GetOffset(), y, "Frame_CentringMark_Right_"&Int(y)
      End If
    Next
    If Err.Number <> 0 Then Err.Clear
  On Error Goto 0
End Sub

Sub CATFrameText(Nb_CM_H As Integer, Nb_CM_V As Integer, Ruler As Integer, Cst_1 As Double, Cst_2 As Double)
  '-------------------------------------------------------------------------------
  'How to create coordinates
  '-------------------------------------------------------------------------------
  On Error Resume Next

    For i = Nb_CM_H To (Ruler/2/Cst_1 + 1) Step -1
      CreateText Chr(65 + Nb_CM_H - i) ,.5 * GetWidth() + (i - .5) * Cst_1,.5 * GetOffset(),"Frame_Text_Bottom_1_"&Chr(65 + Nb_CM_H - i)
      CreateText Chr(64 + Nb_CM_H + i) ,.5 * GetWidth() - (i - .5) * Cst_1,.5 * GetOffset(),"Frame_Text_Bottom_2_"&Chr(65 + Nb_CM_H + i)
    Next
  
    For i = 1 To Nb_CM_H
      t=Chr(65 + Nb_CM_H - i)
      CreateText(t,.5 * GetWidth() + (i - .5) * Cst_1,GetHeight() - .5 * GetOffset(),"Frame_Text_Top_1_"&t).Angle=-90
      t=Chr(64 + Nb_CM_H + i)
      CreateText(t,.5 * GetWidth() - (i - .5) * Cst_1,GetHeight() - .5 * GetOffset(),"Frame_Text_Top_2_"&t).Angle=-90
    Next

    For i = 1 To Nb_CM_V
      t=CStr(Nb_CM_V + i)
      CreateText t ,GetWidth() - .5 * GetOffset(),.5 * GetHeight() + (i - .5) * Cst_2,"Frame_Text_Right_1_"&t
      CreateText(t  ,.5 * GetOffset() ,.5 * GetHeight() + (i - .5) * Cst_2,"Frame_Text_Left_1_"&t).Angle=-90
      
      t=CStr(Nb_CM_V - i + 1)
      CreateText t ,GetWidth() - .5 * GetOffset(),.5 * GetHeight() - (i - .5) * Cst_2,"Frame_Text_Right_1_"&t
      CreateText(t  ,.5 * GetOffset() ,.5 * GetHeight() - (i - .5) * Cst_2,"Frame_Text_Left_2"&t).Angle=-90
    Next

    If Err.Number <> 0 Then Err.Clear  
  On Error Goto 0
End Sub

Sub CATFrameRuler(Ruler As Integer, Cst_1 As Single)
  '-------------------------------------------------------------------------------
  'How to create a ruler
  '-------------------------------------------------------------------------------
  'Frame_Ruler_Guide -----------------------------------------------
  'Frame_Ruler_1cm   | | | | | | | | | | | | | | | | | | | | | | | |
  'Frame_Ruler_5cm   |         |         |         |         |      
  
  On Error Resume Next
    CreateLine .5 * GetWidth() - Ruler/2 ,  .75 * GetOffset(),  .5 * GetWidth() + Ruler/2,  .75 * GetOffset(), "Frame_Ruler_Guide"

    For i = 1 To Ruler/100
      CreateLine .5 * GetWidth() - 50 * i,  GetOV(),  .5 * GetWidth() - 50 * i,  .5 * GetOffset() , "Frame_Ruler_1_"&i
      CreateLine .5 * GetWidth() + 50 * i,  GetOV(),  .5 * GetWidth() + 50 * i,  .5 * GetOffset() , "Frame_Ruler_2_"&i
      For j = 1 To 4
        CreateLine .5 * GetWidth() - 50 * i + 10 * j,  GetOV(),  .5 * GetWidth() - 50 * i + 10 * j,  .75 * GetOffset(), "Frame_Ruler_3"&i&"_"&j
        CreateLine .5 * GetWidth() + 50 * i - 10 * j,  GetOV(),  .5 * GetWidth() + 50 * i - 10 * j,  .75 * GetOffset(), "Frame_Ruler_4"&i&"_"&j
      Next
    Next

    If Err.Number <> 0 Then Err.Clear  
  On Error Goto 0
End Sub
Sub CATDeleteTitleBlockFrame()
    DeleteAll "CATDrwSearch.2DGeometry.Name=TitleBlock_Line_*"
End Sub
Sub CATCreateTitleBlockFrame()
  '-------------------------------------------------------------------------------
  'How to draw the title block geometry
  '-------------------------------------------------------------------------------
    CreateLine GetOH() + Col(1),  GetOV()         ,  GetOH()         ,  GetOV()         , "TitleBlock_Line_Bottom"
    CreateLine GetOH() + Col(1),  GetOV()         ,  GetOH() + Col(1),  GetOV() + Row(7), "TitleBlock_Line_Left"
    CreateLine GetOH() + Col(1),  GetOV() + Row(7),  GetOH()         ,  GetOV() + Row(7), "TitleBlock_Line_Top"
    CreateLine GetOH()         ,  GetOV() + Row(7),  GetOH()         ,  GetOV()         , "TitleBlock_Line_Right"
    CreateLine GetOH() + Col(1),  GetOV() + Row(1),  GetOH()         ,  GetOV() + Row(1), "TitleBlock_Line_Row_1"
    CreateLine GetOH() + Col(4),  GetOV() + Row(2),  GetOH()         ,  GetOV() + Row(2), "TitleBlock_Line_Row_2"
    CreateLine GetOH() + Col(4),  GetOV() + Row(3),  GetOH()         ,  GetOV() + Row(3), "TitleBlock_Line_Row_3"
    CreateLine GetOH() + Col(4),  GetOV() + Row(4),  GetOH()         ,  GetOV() + Row(4), "TitleBlock_Line_Row_4"
    CreateLine GetOH() + Col(1),  GetOV() + Row(5),  GetOH()         ,  GetOV() + Row(5), "TitleBlock_Line_Row_5"
    CreateLine GetOH() + Col(6),  GetOV() + Row(6),  GetOH()         ,  GetOV() + Row(6), "TitleBlock_Line_Row_6"
    CreateLine GetOH() + Col(2),  GetOV() + Row(5),  GetOH() + Col(2),  GetOV() + Row(7), "TitleBlock_Line_Column_1"
    CreateLine GetOH() + Col(3),  GetOV() + Row(5),  GetOH() + Col(3),  GetOV() + Row(7), "TitleBlock_Line_Column_2"
    CreateLine GetOH() + Col(4),  GetOV() + Row(1),  GetOH() + Col(4),  GetOV() + Row(7), "TitleBlock_Line_Column_3"
    CreateLine GetOH() + Col(5),  GetOV() + Row(5),  GetOH() + Col(5),  GetOV() + Row(7), "TitleBlock_Line_Column_4"
    CreateLine GetOH() + Col(6),  GetOV() + Row(1),  GetOH() + Col(6),  GetOV() + Row(7), "TitleBlock_Line_Column_5"
    CreateLine GetOH() + Col(7),  GetOV() + Row(1),  GetOH() + Col(7),  GetOV() + Row(3), "TitleBlock_Line_Column_6"
End Sub


Sub CATTitleBlockText()
  '-------------------------------------------------------------------------------
  'How to fill in the title block
  '-------------------------------------------------------------------------------
  Text_01 = "DESIGNED BY"
  Text_02 = CATIA.SystemService.Environ("LOGNAME")
  If Text_02 = "" Then Text_02 = CATIA.SystemService.Environ("USERNAME")  
  Text_03 = "DATE"
  Text_04 = "XXX"
  Text_05 = "CHECKED BY"
  Text_06 = "DRAWN BY"
  Text_07 = "Ce document, propriété exclusive SOCIETE. est strictement confidentiel. Il ne peut être communiqué, copié ou reproduit sans l'autorisation écrite SOCIETE" + Chr(10) + _
        "This document, exclusive property of SOCIETE, is strictly confidential. It cannot be, copied or repoducted without SOCIETE. 's written authorization."

  Text_08 = "Echelle :" + Chr(10) + _
        "Scale :"
  Text_09 = "Masse / WEIGHT"
  Text_10 = "Folio/Sheet"
  Text_11 = "Format/Size"
  Text_12 = "XXX" ' Paper Format
  Text_13 = "DESIGNATION / Name"
  Text_14 = "Ind."
  Text_15 = "X"
  Text_16 = "PROJET / Project"
  Text_17 = "Référence :" + Chr(10) + _
        "Number :"
  Text_18 = "XXX"


  '-------------------------------------------------------------------------------
  'Ajout du logo SOCIETE
  '-------------------------------------------------------------------------------
  Set LogoPicture = View.Pictures.Add("E:\Programmes\Catia V5R20\win_b64\VBScript\FrameTitleBlock\SOCIETE.bmp", GetOH()-189, GetOV()+10.)
  LogoPicture.ratioLock = 1
  LogoPicture.Height = 19.4942094309026
  LogoPicture.Width = 56
  LogoPicture.Name = "TitleBlock_Logo"
  
  CreateTextAF Text_07,GetOH() + .5*(Col(1)+Col(7)),GetOV() + .5*Row(1)  ,"TitleBlock_Text_Rights"      ,catMiddleCenter,1.7
  CreateTextAF Text_08,GetOH() + Col(1) + 1        ,GetOV()+.5*(Row(5)+Row(7))  ,"TitleBlock_Text_Scale"      ,catMiddleLeft,2
  ' Insert Text Attribute link on sheet's scale
  Set Text=CreateTextAF(""     ,GetOH() + .5*(Col(2)+Col(3)),GetOV()+.5*(Row(5)+Row(7))   ,"TitleBlock_Text_Scale_1"    ,catMiddleCenter,3)
  Select Case GetContext():
    Case "LAY": Text.InsertVariable 0, 0, ActiveDoc.Part.GetItem("CATLayoutRoot").Parameters.Item(ActiveDoc.Part.GetItem("CATLayoutRoot").Name+"\"+Sheet.Name+"\ViewMakeUp2DL.1\Scale")
    Case "DRW": Text.InsertVariable 0, 0, ActiveDoc.DrawingRoot.Parameters.Item("Drawing\"+Sheet.Name+"\ViewMakeUp.1\Scale")    
    Case Else:Text.Text = "XX"
  End Select
  
  CreateTextAF Text_09,GetOH() + .5*Col(6) ,GetOV()+.5*(Row(6)+Row(7))  ,"TitleBlock_Text_Weight"     ,catMiddleCenter,3
  CreateTextAF Text_04,GetOH() + .5*Col(6) ,GetOV()+.5*(Row(5)+Row(6))  ,"TitleBlock_Text_Weight_1"   ,catMiddleCenter,3
  CreateTextAF Text_10,GetOH() + .5*Col(7) ,GetOV()+.5*(Row(2)+Row(3))  ,"TitleBlock_Text_Sheet"       ,catMiddleCenter,2
  CreateTextAF Text_04,GetOH() + .5*Col(7) ,GetOV()+.5*(Row(1)+Row(2))  ,"TitleBlock_Text_Sheet_1"     ,catMiddleCenter,3
  CreateTextAF Text_11,GetOH() + .5*Col(6) ,GetOV()+.5*(Row(4)+Row(5)) ,"TitleBlock_Text_Size"        ,catMiddleCenter   ,3
  CreateTextAF Text_12,GetOH() + .5*Col(6) ,GetOV()+.5*(Row(3)+Row(4)) ,"TitleBlock_Text_Size_1"      ,catMiddleCenter,3
  CreateTextAF Text_13,GetOH() + .5*(Col(4)+Col(6)) ,GetOV()+.5*(Row(2)+Row(3))  ,"TitleBlock_Text_Name"      ,catMiddleCenter  ,3
  CreateTextAF Text_04,GetOH() + .5*(Col(4)+Col(6)) ,GetOV()+.5*(Row(1)+Row(2))  ,"TitleBlock_Text_EnoviaV5_Effectivity"    ,catMiddleCenter,3
  CreateTextAF Text_14,GetOH() + .5*(Col(6)+Col(7)) ,GetOV()+.5*(Row(2)+Row(3))  ,"TitleBlock_Text_Rev"         ,catMiddleCenter,2
  CreateTextAF Text_15,GetOH() + .5*(Col(6)+Col(7)) ,GetOV()+.5*(Row(1)+Row(2))  ,"TitleBlock_Text_Rev_1"       ,catMiddleCenter,3
  CreateTextAF Text_16,GetOH() + .5*(Col(4)+Col(6)) ,GetOV()+.5*(Row(4)+Row(5))  ,"TitleBlock_Text_Project"       ,catMiddleCenter,3
  CreateTextAF Text_04,GetOH() + .5*(Col(4)+Col(6)) ,GetOV()+.5*(Row(3)+Row(4))  ,"TitleBlock_Text_Project_1"     ,catMiddleCenter,3
  CreateTextAF Text_17,GetOH() + .5*(Col(4)+Col(5)) ,GetOV()+.5*(Row(5)+Row(7))  ,"TitleBlock_Text_Number"     ,catMiddleCenter,3
  CreateTextAF Text_18,GetOH() + .5*(Col(5)+Col(6)) ,GetOV()+.5*(Row(5)+Row(7))  ,"TitleBlock_Text_Number_1"     ,catMiddleCenter,3

  CATLinks
End Sub

Sub CATDeleteRevisionBlockFrame
    DeleteAll "CATDrwSearch.2DGeometry.Name=RevisionBlock_Line_*"
End Sub

Sub CATCreateTitleBlockStandard()
  '-------------------------------------------------------------------------------
  'How to create the standard representation
  '-------------------------------------------------------------------------------
  Dim R1   As Double
  Dim R2   As Double
  Dim X(5) As Double
  Dim Y(7) As Double

  R1   = 2.
  R2   = 4.
  X(1) = GetOH()   + Col(3) +1.
  X(2) = X(1) + 1.5
  X(3) = X(1) + 9.5
  X(4) = X(1) + 15.5
  X(5) = X(1) + 20.
  Y(1) = GetOV()   + (Row(5)+Row(7))/2.
  Y(2) = Y(1) + R1
  Y(3) = Y(1) + R2
  Y(4) = Y(1) + 4.5
  Y(5) = Y(1) - R1
  Y(6) = Y(1) - R2
  Y(7) = 2*Y(1) - Y(4)

  If Sheet.ProjectionMethod  <> CatFirstAngle Then
    Xtmp = X(2)
    X(2) = X(1) + X(5) - X(3)
    X(3) = X(1) + X(5) - Xtmp
    X(4) = X(1) + X(5) - X(4)
  End If

  On Error Resume Next
    CreateLine X(1),  Y(1),  X(5),  Y(1), "TitleBlock_Standard_Line_Axis_1"
    CreateLine X(4),  Y(7),  X(4),  Y(4), "TitleBlock_Standard_Line_Axis_2"
    CreateLine X(2),  Y(5),  X(2),  Y(2), "TitleBlock_Standard_Line_1"
    CreateLine X(2),  Y(2),  X(3),  Y(3), "TitleBlock_Standard_Line_2"
    CreateLine X(3),  Y(3),  X(3),  Y(6), "TitleBlock_Standard_Line_3"
    CreateLine X(3),  Y(6),  X(2),  Y(5), "TitleBlock_Standard_Line_4"
    Set circle = Fact.CreateClosedCircle(X(4), Y(1), R1)
    circle.Name = "TitleBlock_Standard_Circle_1"
    Set circle = Fact.CreateClosedCircle(X(4), Y(1), R2)
    circle.Name = "TitleBlock_Standard_Circle_2"
    If Err.Number <> 0 Then Err.Clear  
  On Error Goto 0

End Sub

Sub CATCreateRevisionBlockFrame
  '-------------------------------------------------------------------------------
  'How to draw the revision block geometry
  '-------------------------------------------------------------------------------  
  revision = CATCheckRev()
  If revision=0 Then Exit Sub
  For ii=0 To revision
    iX = GetOH()
    iY1 = 53 + GetRevRowHeight()*ii
    iY2 = 53 + GetRevRowHeight()*(ii+1)
    CreateLine iX + GetColRev(1),  iY1,  iX + GetColRev(1), iY2, "RevisionBlock_Line_Column_" + GetRevLetter(ii) + "_1"
    CreateLine iX + GetColRev(2),  iY1,  iX + GetColRev(2), iY2, "RevisionBlock_Line_Column_" + GetRevLetter(ii) + "_2"
    CreateLine iX + GetColRev(3),  iY1,  iX + GetColRev(3), iY2, "RevisionBlock_Line_Column_" + GetRevLetter(ii) + "_3"
    CreateLine iX + GetColRev(4),  iY1,  iX + GetColRev(4), iY2, "RevisionBlock_Line_Column_" + GetRevLetter(ii) + "_4"
    CreateLine iX + GetColRev(5),  iY1,  iX + GetColRev(5), iY2, "RevisionBlock_Line_Column_" + GetRevLetter(ii) + "_5"
    CreateLine iX + GetColRev(1),  iY2,  iX                            , iY2, "RevisionBlock_Line_Row_" + GetRevLetter(ii)
  Next
End Sub

Sub CATAddRevisionBlockText
  '-------------------------------------------------------------------------------
  'How to fill in the revision block
  '-------------------------------------------------------------------------------
  revision = CATCheckRev()+1
  X = GetOH()
  Y = 53 + GetRevRowHeight()*(revision-.5)

  Init        = InputBox("This review has been done by:", "Reviewer's name", "XXX")
  Description = InputBox("Comment to be inserted:", "Description", "None")
  Verificateur = InputBox("This review has been checked by:", "Nom du vérificateur", "YYY")

  If revision = 1 Then
    CreateTextAF "Ind."        ,X + .5*(GetColRev(1)+GetColRev(2)),Y ,"RevisionBlock_Text_Rev"          ,catMiddleCenter,3
    CreateTextAF "DATE"         ,X + .5*(GetColRev(2)+GetColRev(3)),Y ,"RevisionBlock_Text_Date"         ,catMiddleCenter,3
    CreateTextAF "Description de la révision /" + Chr(10) + _
        "Description"                   ,X + .5*(GetColRev(3)+GetColRev(4)),Y ,"RevisionBlock_Text_Description"  ,catMiddleCenter,3
    CreateTextAF "Dessiné par /" + Chr(10) + _
        "Design by"                     ,X + .5*(GetColRev(4)+GetColRev(5)),Y ,"RevisionBlock_Text_Init"         ,catMiddleCenter,3
    CreateTextAF "Vérifié par /" + Chr(10) + _
        "Checked by"                  ,X + .5*(GetColRev(6)),Y ,"RevisionBlock_Text_Verificateur"         ,catMiddleCenter,3

  End If

  CreateTextAF GetRevLetter(revision)  ,X + .5*(GetColRev(1)+GetColRev(2)),Y + GetRevRowHeight(),"RevisionBlock_Text_Rev_" + GetRevLetter(revision)        ,catMiddleCenter,3
  CreateTextAF ""&Date                 ,X + .5*(GetColRev(2)+GetColRev(3)),Y + GetRevRowHeight(),"RevisionBlock_Text_Date_" + GetRevLetter(revision)       ,catMiddleCenter,3
  CreateTextAF Description             ,X + .5*(GetColRev(3)+GetColRev(4)),Y + GetRevRowHeight(),"RevisionBlock_Text_Description_" + GetRevLetter(revision),catMiddleCenter, 3
  CreateTextAF Init                    ,X + .5*(GetColRev(4)+GetColRev(5)),Y + GetRevRowHeight(),"RevisionBlock_Text_Init_" + GetRevLetter(revision)       ,catMiddleCenter,3
  CreateTextAF Verificateur      ,X + .5*(GetColRev(6)),Y + GetRevRowHeight(),"RevisionBlock_Text_Verificateur_" + GetRevLetter(revision)       ,catMiddleCenter,3

  On Error Resume Next
    Texts.GetItem("TitleBlock_Text_MDate_" + GetRevLetter(revision)).Text = ""&Date
    If Err.Number <> 0 Then Err.Clear
  On Error Goto 0
End Sub

Sub ComputeTitleBlockTranslation(TranslationTab As Variant)
  TranslationTab(0) = 0.
  TranslationTab(1) = 0.
  
  On Error Resume Next
    Set Text = Texts.GetItem("Reference_" + GetMacroID()) 'Get the reference text
    If Err.Number <> 0 Then
      Err.Clear
    Else

      TranslationTab(0) = GetWidth() - GetOffset() - Text.x
      TranslationTab(1) = GetOffset() - Text.y

      Text.x = Text.x + TranslationTab(0)
      Text.y = Text.y + TranslationTab(1)
    End If
  On Error Goto 0
End Sub

Sub ComputeRevisionBlockTranslation(TranslationTab As Variant)
  TranslationTab(0) = 0.
  TranslationTab(1) = 0.

  On Error Resume Next
    Set Text= Texts.GetItem("RevisionBlock_Text_Init") 'Get the reference text
    If Err.Number <> 0 Then
      Err.Clear
    Else
      TranslationTab(0) = GetWidth() -28. + GetColRev(5) - Text.x
      TranslationTab(1) = 53 + .5*GetRevRowHeight() - Text.y
    End If
  On Error Goto 0
End Sub



Sub CATRemoveFrame()
  '-------------------------------------------------------------------------------
  'How to remove the whole frame
  '-------------------------------------------------------------------------------
  DeleteAll "CATDrwSearch.DrwText.Name=Frame_Text_*"
  DeleteAll "CATDrwSearch.2DGeometry.Name=Frame_*"
  DeleteAll "CATDrwSearch.2DPoint.Name=TitleBlock_Line_*"

End Sub



Sub CATMoveTitleBlockText(Translation As Variant)
  '-------------------------------------------------------------------------------
  'How to translate the whole title block after changing the page setup
  '-------------------------------------------------------------------------------
  SelectAll "CATDrwSearch.DrwText.Name=TitleBlock_Text_*"
  count = Selection.Count2
  For ii = 1 To count
    Set Text=Selection.Item2(ii).Value
    Text.x  = Text.x + Translation(0)
    Text.y  = Text.y + Translation(1)
  Next  
End Sub

Sub CATMoveViews(Translation As Variant)
  '-------------------------------------------------------------------------------
  'How to translate the views after changing the page setup
  '-------------------------------------------------------------------------------  
  For i = 3 To Views.Count
    Views.Item(i).UnAlignedWithReferenceView
  Next
  For i = 3 To Views.Count
      Set View = Views.Item(i)
      View.X = View.X + Translation(0)
      View.Y = View.Y + Translation(1)
      View.AlignedWithReferenceView  
  Next
End Sub

Sub CATDeleteTitleBlockStandard()
  '-------------------------------------------------------------------------------
  'How to remove the standard representation
  '-------------------------------------------------------------------------------
  DeleteAll "CATDrwSearch.2DGeometry.Name=TitleBlock_Standard*"    
End Sub

Sub CATMoveRevisionBlockText(Translation As Varient)
  '-------------------------------------------------------------------------------
  'How to translate the whole revision block after changing the page setup
  '-------------------------------------------------------------------------------
  SelectAll "CATDrwSearch.DrwText.Name=RevisionBlock_Text_*"
  count = Selection.Count2
  For ii = 1 To count
    Set Text=Selection.Item2(ii).Value
    Text.x = Text.x + Translation(0)
    Text.y = Text.y + Translation(1)  
  Next
End Sub

Sub CATLinks()
  '-------------------------------------------------------------------------------
  'How to fill in texts with data of the part/product linked with current sheet
  '-------------------------------------------------------------------------------
  On Error Resume Next
  Dim ViewDocument
  
  Select Case GetContext():
    Case "LAY": Set ViewDocument = CATIA.ActiveDocument.Product
    Case "DRW":
      If Views.Count>=3 Then
        Set ViewDocument = Views.Item(3).GenerativeBehavior.Document
      Else
        Set ViewDocument = Nothing
      End If      
    Case Else:Set ViewDocument = Nothing
  End Select
  
  'Find the product document
  Dim ProductDrawn
  Set ProductDrawn=Nothing
  For i = 1 to 8    
    If TypeName(ViewDocument)="PartDocument" Then
      Set ProductDrawn=ViewDocument.Product
      Exit For
    End If
    If TypeName(ViewDocument)="Product" Then
      Set ProductDrawn=ViewDocument
      Exit For
    End If
    Set ViewDocument = ViewDocument.Parent
  Next
    
  If ProductDrawn <> Nothing Then
    Texts.GetItem("TitleBlock_Text_EnoviaV5_Effectivity").Text = ProductDrawn.PartNumber
    Texts.GetItem("TitleBlock_Text_Title_1").Text  = ProductDrawn.Definition
    Dim ProductAnalysis As Analyze
    Set ProductAnalysis = ProductDrawn.Analyze
    Texts.GetItem("TitleBlock_Text_Weight_1").Text = FormatNumber(ProductAnalysis.Mass,2)
  End If

  '-------------------------------------------------------------------------------
  'Display sheet format
  '-------------------------------------------------------------------------------
  Dim textFormat As DrawingText
  Set textFormat = Texts.GetItem("TitleBlock_Text_Size_1")
  textFormat.Text = GetDisplayFormat()
  If Len(GetDisplayFormat()) > 4 Then
    textFormat.SetFontSize 0, 0, 2.5
  Else
    textFormat.SetFontSize 0, 0, 4.
  End If

  '-------------------------------------------------------------------------------
  'Display sheet numbering
  '-------------------------------------------------------------------------------
  Dim nbSheet  As Integer
  Dim curSheet As Integer
  If Not DrwSheet.IsDetail Then
    For Each itSheet In Sheets
      If Not itSheet.IsDetail Then nbSheet = nbSheet + 1
    Next
    For Each itSheet In Sheets
      If Not itSheet.IsDetail Then
        curSheet = curSheet + 1        
        itSheet.Views.Item(2).Texts.GetItem("TitleBlock_Text_Sheet_1").Text = CStr(curSheet) & "/" & CStr(nbSheet)
      End If
    Next
  End If    
  On Error Goto 0
End Sub

Sub CATColorGeometry()
  '-------------------------------------------------------------------------------
  'How to color all geometric elements of the active view
  '-------------------------------------------------------------------------------
  
  ' Uncomment the following sections if needed
  Select Case GetContext():
    'Case "DRW":
    '    SelectAll "CATDrwSearch.2DGeometry"
    '    Selection.VisProperties.SetRealColor 0,0,0,0
    '    Selection.Clear
    Case "LAY":  
        SelectAll "CATDrwSearch.2DGeometry"
        Selection.VisProperties.SetRealColor 255,255,255,0
        Selection.Clear
    'Case "SCH":
    '    SelectAll "CATDrwSearch.2DGeometry"
    '    Selection.VisProperties.SetRealColor 0,0,0,0
    '    Selection.Clear
    
  End Select  
End Sub




Par ailleurs, il me reste quelque suptilités à trouver mais j'arrive aux limites de mes connaissances. En effet, je souhaiteriez que l'indice en cours (Cadre rouge en bas à droite) soit identique au dernier indice de révision (Cadre rouge en haut à gauche) dans ce cas le "X" devrai être égale à "A" mais si j'ajoute une révision il devrai passer à "B".

De plus, comment faire pour que les informations contenue dans les cadres vert soit renseigner par le biais d'une boite de dialogue?



Enfin, comment gérer les Polices et taille des textes? Par ensemble les texte en bas du cartouche doit être "ArialNarrow" taille 1.7 mais le texte "Projet" devrai être en "ArialBlack" d'une taille supérieur.
Pour les tailles il s'agit de la valeur en fin des champs concernant les Titleblock mais je vois pas comment modifier la police.

Bonjour Dimitri,

Pour la position de ton logo, utilises tu des coordonnées relatives?
Dans la macro toutes les positions sont définies par rapport à GetOH et GetOV
Ex: Set LogoPicture = View.Pictures.Add("C:\Temp\logo_cartouche.jpg", GetOH()-145, GetOV()+45)

Pour remplir le cartouche tu peux utiliser une InputBox :
Text_XX = InputBox ( "Saisir le projet") As String
Text_YY = InputBox ( "Saisir la référence") As String
(Tu ne peux pas faire une boîte de dialogue complexe en vbscript, il faudrait passer en VBA)

Pour la police essayes SteFontName
MyText.SetFontName 0, 0, "Courrier 10 BT"

Pour la révision, comment veux tu faire évoluer sa valeur?

Merci pour ta réponse .

lumpazepfel a écrit:
Pour la position de ton logo, utilises tu des coordonnées relatives?
Dans la macro toutes les positions sont définies par rapport à  GetOH et GetOV
Ex: Set LogoPicture = View.Pictures.Add("C:\Temp\logo_cartouche.jpg", GetOH()-145, GetOV()+45)

Oui, j'utilise les positions relative, c'est pour ça que je ne comprends pas pourquoi la position s'actualise pas après un redimensionnement du cartouche :S (Voir code ci-dessous) :

Code:

 Set LogoPicture = View.Pictures.Add("E:\Programmes\Catia V5R20\win_b64\VBScript\FrameTitleBlock\logo.bmp", GetOH()-189, GetOV()+10.)
  LogoPicture.ratioLock = 1
  LogoPicture.Height = 19.4942094309026
  LogoPicture.Width = 56
  LogoPicture.Name = "TitleBlock_Logo"

Je pense que le problème viendrais de la partie du code qui permet de redimensionner le cartouche, mais là je vois pas trop ce qu'il faudrait modifier.

lumpazepfel a écrit:
Pour remplir le cartouche tu peux utiliser une InputBox :
Text_XX = InputBox ( "Saisir le projet") As String
Text_YY = InputBox ( "Saisir la référence") As String
(Tu ne peux pas faire une boîte de dialogue complexe en vbscript, il faudrait passer en VBA)

Je vais tester ce bout de code. En toute sincérité je ne recherche pas des belles boite de dialogues, il faut que se soit simple et efficace .

lumpazepfel a écrit:Pour la police essayes SteFontName
MyText.SetFontName 0,  0, "Courrier 10 BT"

Ok, je vais tester aussi. Mais je ne vois pas trop à quel endroit l'introduire dans les lignes de code, avant chaque ligne qui permet le "remplissage" du texte? (Comme ci-dessous?) :

Code:

Sub CATTitleBlockText()
  '-------------------------------------------------------------------------------
  'How to fill in the title block
  '-------------------------------------------------------------------------------
  Text_07 = "Ce document, propriété exclusive d'X. est strictement confidentiel. Il ne peut être communiqué, copié ou reproduit sans l'autorisation écrite d'X." + Chr(10) + _
        "This document, exclusive property of X., is strictly confidential. It cannot be, copied or repoducted without X. 's written authorization."
  Text_07.SetFontName 0,  0, "Courrier 10 BT"
  
  CreateTextAF Text_07,GetOH() + .5*(Col(1)+Col(7)),GetOV() + .5*Row(1)  ,"TitleBlock_Text_Rights"      ,catMiddleCenter,1.7

  End Select
  


lumpazepfel a écrit:Pour la révision, comment veux tu faire évoluer sa valeur?

Concernant la révision, je me suis inspirer du code catia. Du coup, pour ajouter un indice de révision je clique sur "Addrevisionblock" dans le gestionnaire de cartouche :


Ce qui lance le bout de code ci-dessous pour générer le tableau de révision au dessus de cartouche. L'idée c'est peut être renvoyer la valeur donnée par la variable CATCheckRev() vers un text présent dans le cartouche. Mais là je ne vois pas comment faire, les quelques essais que j'ai tenté n'ont fait que planter le script :S.

Code:

Sub CATCreateRevisionBlockFrame
  '-------------------------------------------------------------------------------
  'How to draw the revision block geometry
  '-------------------------------------------------------------------------------  
  revision = CATCheckRev()
  If revision=0 Then Exit Sub
  For ii=0 To revision
    iX = GetOH()
    iY1 = 53 + GetRevRowHeight()*ii
    iY2 = 53 + GetRevRowHeight()*(ii+1)
    CreateLine iX + GetColRev(1),  iY1,  iX + GetColRev(1), iY2, "RevisionBlock_Line_Column_" + GetRevLetter(ii) + "_1"
    CreateLine iX + GetColRev(2),  iY1,  iX + GetColRev(2), iY2, "RevisionBlock_Line_Column_" + GetRevLetter(ii) + "_2"
    CreateLine iX + GetColRev(3),  iY1,  iX + GetColRev(3), iY2, "RevisionBlock_Line_Column_" + GetRevLetter(ii) + "_3"
    CreateLine iX + GetColRev(4),  iY1,  iX + GetColRev(4), iY2, "RevisionBlock_Line_Column_" + GetRevLetter(ii) + "_4"
    CreateLine iX + GetColRev(5),  iY1,  iX + GetColRev(5), iY2, "RevisionBlock_Line_Column_" + GetRevLetter(ii) + "_5"
    CreateLine iX + GetColRev(1),  iY2,  iX                            , iY2, "RevisionBlock_Line_Row_" + GetRevLetter(ii)
  Next
End Sub

Sub CATAddRevisionBlockText
  '-------------------------------------------------------------------------------
  'How to fill in the revision block
  '-------------------------------------------------------------------------------
  revision = CATCheckRev()+1
  X = GetOH()
  Y = 53 + GetRevRowHeight()*(revision-.5)

  Init        = InputBox("This review has been done by:", "Reviewer's name", "XXX")
  Description = InputBox("Comment to be inserted:", "Description", "None")
  Verificateur = InputBox("This review has been checked by:", "Nom du vérificateur", "YYY")

  If revision = 1 Then
    CreateTextAF "Ind."        ,X + .5*(GetColRev(1)+GetColRev(2)),Y ,"RevisionBlock_Text_Rev"          ,catMiddleCenter,3
    CreateTextAF "DATE"         ,X + .5*(GetColRev(2)+GetColRev(3)),Y ,"RevisionBlock_Text_Date"         ,catMiddleCenter,3
    CreateTextAF "Description de la révision /" + Chr(10) + _
        "Description"                   ,X + .5*(GetColRev(3)+GetColRev(4)),Y ,"RevisionBlock_Text_Description"  ,catMiddleCenter,3
    CreateTextAF "Dessiné par /" + Chr(10) + _
        "Design by"                     ,X + .5*(GetColRev(4)+GetColRev(5)),Y ,"RevisionBlock_Text_Init"         ,catMiddleCenter,3
    CreateTextAF "Vérifié par /" + Chr(10) + _
        "Checked by"                  ,X + .5*(GetColRev(6)),Y ,"RevisionBlock_Text_Verificateur"         ,catMiddleCenter,3

  End If

Bonjour Dimitri,


Effectivement pour la position de ton logo, il faut modifier la routine : Sub CATMoveTitleBlockText

Code:

Sub CATMoveTitleBlockText(Translation As Variant)
  '-------------------------------------------------------------------------------
  'How to translate the whole title block after changing the page setup
  '-------------------------------------------------------------------------------
  SelectAll "CATDrwSearch.DrwText.Name=TitleBlock_Text_*"
  count = Selection.Count2
  For ii = 1 To count
    Set Text=Selection.Item2(ii).Value
    Text.x  = Text.x + Translation(0)
    Text.y  = Text.y + Translation(1)
  Next
 Set LogoPicture = View.Pictures.item("TitleBlock_Logo")
 LogoPicture.x = LogoPicture.x + Translation(0)
 LogoPicture.y = LogoPicture.y + Translation(1)  
End Sub

Pour remplir le cartouche tu remplace la valeur "XXX" par une InputBox :
Text_11 = InputBox("Entrez le nom de la firme", "Titre de la boite", "Valeur par défaut")



Pour affecter une police différente à tous les textes, il faut rajouter dans la fonction  CreateTextAF la ligne CreateTextAF.SetFontName 0, 0, "ArialBlack"

Code:

Function CreateTextAF(iCaption as String, iX as Double, iY As Double, iName As String, iAnchorPosition As CatTextAnchorPosition, iFontSize As Double) As DrawingText
  '-------------------------------------------------------------------------------
  'How to create a text
  '-------------------------------------------------------------------------------
  Set CreateTextAF = Texts.Add(iCaption, iX, iY)
  CreateTextAF.Name           = iName
  CreateTextAF.AnchorPosition = iAnchorPosition
  CreateTextAF.SetFontSize      0, 0, iFontSize
  CreateTextAF.SetFontName 0, 0, "ArialBlack"
End Function

Si tu veux modifier un texte en particulier, il faut rajouter sous la ligne qui créée le texte :

Code:

CreateTextAF Text_11,GetOH() + .5*(Col(3)+Col(5)),GetOV() + .5*(Row(2)+Row(3)),"TitleBlock_Text_Company"     ,catMiddleCenter,5
 View.Texts.GetItem("TitleBlock_Text_Company").SetFontName 0, 0, "Playbill (TrueType)"

On pourrait aussi passer la type de police en tant que variable dans la fonction CreateTextAF.

Pour la révision, je vais regarder.

Merci pour ton retour.
Alors concernant la police des textes je vais partir sur le dernier code que tu propose, ça répond vraiment à mon besoin car j'ai plusieur type de police dans un cartouche :

Code:

CreateTextAF Text_11,GetOH() + .5*(Col(3)+Col(5)),GetOV() + .5*(Row(2)+Row(3)),"TitleBlock_Text_Company"    ,catMiddleCenter,5
 View.Texts.GetItem("TitleBlock_Text_Company").SetFontName 0, 0, "Playbill (TrueType)"

Et je vais tester de ce pas les modifications concernant le logo .

Pour remplir le cartouche tu remplace la valeur "XXX" par une InputBox :
Text_11 = InputBox("Entrez le nom de la firme", "Titre de la boite", "Valeur par défaut")

Ok, c'est exactement ce que je cherchais pour renseigner certain champs .

Pour ce qui est du repositionnement du logo, j'ai testé les modifications proposées mais il semblerait que ça ne marche pas. Je continu de creusé mais je suis preneur de toute idées .

Bon, le repositionnement du logo fonctionne depuis ce matin. Je comprends pas trop pourquoi d'ailleurs car j'ai rien modifié depuis hier soir .

Du coup, les Polices c'est bon, le Logo aussi. Il me reste à creuser le problème de l'indice de Révision dans le cartouche qui renvoie la valeur du dernier indice en cours. Je vais creuser ça cette après-midi .

Salut,

Voilà pour l'indice de modification, tu étais sur la bonne voie : il suffit de rajouter "Texts.GetItem("TitleBlock_Text_Rev_1").Text = GetRevLetter(revision)" dans la fonction "CATAddRevisionBlockText":

Code:

Sub CATAddRevisionBlockText
  '-------------------------------------------------------------------------------
  'How to fill in the revision block
  '-------------------------------------------------------------------------------
  revision = CATCheckRev()+1
  X = GetOH()
  Y = 53 + GetRevRowHeight()*(revision-.5)
 Texts.GetItem("TitleBlock_Text_Rev_1").Text = GetRevLetter(revision)
  Init        = InputBox("This review has been done by:", "Reviewer's name", "XXX")
  Description = InputBox("Comment to be inserted:", "Description", "None")
  Verificateur = InputBox("This review has been checked by:", "Nom du vérificateur", "YYY")

  If revision = 1 Then
    CreateTextAF "Ind."        ,X + .5*(GetColRev(1)+GetColRev(2)),Y ,"RevisionBlock_Text_Rev"          ,catMiddleCenter,3
    CreateTextAF "DATE"         ,X + .5*(GetColRev(2)+GetColRev(3)),Y ,"RevisionBlock_Text_Date"         ,catMiddleCenter,3
    CreateTextAF "Description de la révision /" + Chr(10) + _
        "Description"                   ,X + .5*(GetColRev(3)+GetColRev(4)),Y ,"RevisionBlock_Text_Description"  ,catMiddleCenter,3
    CreateTextAF "Dessiné par /" + Chr(10) + _
        "Design by"                     ,X + .5*(GetColRev(4)+GetColRev(5)),Y ,"RevisionBlock_Text_Init"         ,catMiddleCenter,3
    CreateTextAF "Vérifié par /" + Chr(10) + _
        "Checked by"                  ,X + .5*(GetColRev(6)),Y ,"RevisionBlock_Text_Verificateur"         ,catMiddleCenter,3

  End If

  CreateTextAF GetRevLetter(revision)  ,X + .5*(GetColRev(1)+GetColRev(2)),Y + GetRevRowHeight(),"RevisionBlock_Text_Rev_" + GetRevLetter(revision)        ,catMiddleCenter,3
  CreateTextAF ""&Date                 ,X + .5*(GetColRev(2)+GetColRev(3)),Y + GetRevRowHeight(),"RevisionBlock_Text_Date_" + GetRevLetter(revision)       ,catMiddleCenter,3
  CreateTextAF Description             ,X + .5*(GetColRev(3)+GetColRev(4)),Y + GetRevRowHeight(),"RevisionBlock_Text_Description_" + GetRevLetter(revision),catMiddleCenter, 3
  CreateTextAF Init                    ,X + .5*(GetColRev(4)+GetColRev(5)),Y + GetRevRowHeight(),"RevisionBlock_Text_Init_" + GetRevLetter(revision)       ,catMiddleCenter,3
  CreateTextAF Verificateur      ,X + .5*(GetColRev(6)),Y + GetRevRowHeight(),"RevisionBlock_Text_Verificateur_" + GetRevLetter(revision)       ,catMiddleCenter,3

  On Error Resume Next
    Texts.GetItem("TitleBlock_Text_MDate_" + GetRevLetter(revision)).Text = ""&Date
    If Err.Number <> 0 Then Err.Clear
  On Error Goto 0
End Sub

Super, je test ça tout de suite .

lumpazepfel a écrit:Salut,

Voilà pour l'indice de modification, tu étais sur la bonne voie : il suffit de rajouter "Texts.GetItem("TitleBlock_Text_Rev_1").Text = GetRevLetter(revision)" dans la fonction "CATAddRevisionBlockText":

Code:

Sub CATAddRevisionBlockText
  '-------------------------------------------------------------------------------
  'How to fill in the revision block
  '-------------------------------------------------------------------------------
  revision = CATCheckRev()+1
  X = GetOH()
  Y = 53 + GetRevRowHeight()*(revision-.5)
 Texts.GetItem("TitleBlock_Text_Rev_1").Text = GetRevLetter(revision)
  Init        = InputBox("This review has been done by:", "Reviewer's name", "XXX")
  Description = InputBox("Comment to be inserted:", "Description", "None")
  Verificateur = InputBox("This review has been checked by:", "Nom du vérificateur", "YYY")

  If revision = 1 Then
    CreateTextAF "Ind."        ,X + .5*(GetColRev(1)+GetColRev(2)),Y ,"RevisionBlock_Text_Rev"          ,catMiddleCenter,3
    CreateTextAF "DATE"         ,X + .5*(GetColRev(2)+GetColRev(3)),Y ,"RevisionBlock_Text_Date"         ,catMiddleCenter,3
    CreateTextAF "Description de la révision /" + Chr(10) + _
        "Description"                   ,X + .5*(GetColRev(3)+GetColRev(4)),Y ,"RevisionBlock_Text_Description"  ,catMiddleCenter,3
    CreateTextAF "Dessiné par /" + Chr(10) + _
        "Design by"                     ,X + .5*(GetColRev(4)+GetColRev(5)),Y ,"RevisionBlock_Text_Init"         ,catMiddleCenter,3
    CreateTextAF "Vérifié par /" + Chr(10) + _
        "Checked by"                  ,X + .5*(GetColRev(6)),Y ,"RevisionBlock_Text_Verificateur"         ,catMiddleCenter,3

  End If

  CreateTextAF GetRevLetter(revision)  ,X + .5*(GetColRev(1)+GetColRev(2)),Y + GetRevRowHeight(),"RevisionBlock_Text_Rev_" + GetRevLetter(revision)        ,catMiddleCenter,3
  CreateTextAF ""&Date                 ,X + .5*(GetColRev(2)+GetColRev(3)),Y + GetRevRowHeight(),"RevisionBlock_Text_Date_" + GetRevLetter(revision)       ,catMiddleCenter,3
  CreateTextAF Description             ,X + .5*(GetColRev(3)+GetColRev(4)),Y + GetRevRowHeight(),"RevisionBlock_Text_Description_" + GetRevLetter(revision),catMiddleCenter, 3
  CreateTextAF Init                    ,X + .5*(GetColRev(4)+GetColRev(5)),Y + GetRevRowHeight(),"RevisionBlock_Text_Init_" + GetRevLetter(revision)       ,catMiddleCenter,3
  CreateTextAF Verificateur      ,X + .5*(GetColRev(6)),Y + GetRevRowHeight(),"RevisionBlock_Text_Verificateur_" + GetRevLetter(revision)       ,catMiddleCenter,3

  On Error Resume Next
    Texts.GetItem("TitleBlock_Text_MDate_" + GetRevLetter(revision)).Text = ""&Date
    If Err.Number <> 0 Then Err.Clear
  On Error Goto 0
End Sub

Alors, c'est parfait! L'ensemble du cartouche est fonctionnel. Il me reste à le faire vivre en fonction des différents projets à venir. En tout cas, merci pour ton aide   !

Pour info, le repositionnement de l'image après un changement de format de feuille plante de temps en temps j'arrive à contourner se problème en relançant CATIA.

d.vincent567 a écrit:Pour info, le repositionnement de l'image après un changement de format de feuille plante de temps en temps j'arrive à contourner se problème en relançant CATIA.

J'ai trouver mon erreur! En effet, le repositionnement du Logo était dans la mauvaise "sous-routine" (Voir si dessous). Du coup, si il n'y avais pas de bloc de révision la macro ne déplaçais pas le logo, ce qui explique l'effet "aléatoire" du bug.

Code:

Sub CATMoveTitleBlockText(Translation As Variant)
  '-------------------------------------------------------------------------------
  'How to translate the whole title block after changing the page setup
  '-------------------------------------------------------------------------------
  SelectAll "CATDrwSearch.DrwText.Name=TitleBlock_Text_*"
  count = Selection.Count2
  For ii = 1 To count
    Set Text=Selection.Item2(ii).Value
    Text.x  = Text.x + Translation(0)
    Text.y  = Text.y + Translation(1)
  Next

End Sub

Sub CATMoveViews(Translation As Variant)
  '-------------------------------------------------------------------------------
  'How to translate the views after changing the page setup
  '-------------------------------------------------------------------------------  
  For i = 3 To Views.Count
    Views.Item(i).UnAlignedWithReferenceView
  Next
  For i = 3 To Views.Count
      Set View = Views.Item(i)
      View.X = View.X + Translation(0)
      View.Y = View.Y + Translation(1)
      View.AlignedWithReferenceView  
  Next
 Set LogoPicture = View.Pictures.item("TitleBlock_Logo")
 LogoPicture.x = LogoPicture.x + Translation(0)
 LogoPicture.y = LogoPicture.y + Translation(1)  
End Sub

Du coup, il faut l'intégrer à la sous-routine qui gère le repositionnement du "cartouche" et non pas celle du block de révision. La solution :

Code:

Sub CATMoveTitleBlockText(Translation As Variant)
  '-------------------------------------------------------------------------------
  'How to translate the whole title block after changing the page setup
  '-------------------------------------------------------------------------------
  SelectAll "CATDrwSearch.DrwText.Name=TitleBlock_Text_*"
  count = Selection.Count2
  For ii = 1 To count
    Set Text=Selection.Item2(ii).Value
    Text.x  = Text.x + Translation(0)
    Text.y  = Text.y + Translation(1)
  Next
 Set LogoPicture = View.Pictures.item("TitleBlock_Logo")
 LogoPicture.x = LogoPicture.x + Translation(0)
 LogoPicture.y = LogoPicture.y + Translation(1)
End Sub

Sub CATMoveViews(Translation As Variant)
  '-------------------------------------------------------------------------------
  'How to translate the views after changing the page setup
  '-------------------------------------------------------------------------------  
  For i = 3 To Views.Count
    Views.Item(i).UnAlignedWithReferenceView
  Next
  For i = 3 To Views.Count
      Set View = Views.Item(i)
      View.X = View.X + Translation(0)
      View.Y = View.Y + Translation(1)
      View.AlignedWithReferenceView  
  Next

End Sub

C'est parfait, content d'avoir pu t'aider.
Mais attention les macros quand y a gouté on devient vite accro.
Alors pour info (au cas où) dans ton installation CATIA il y a un fichier d'aide qui s'appelle "V5Automation.chm" et qui se trouve dans le répertoire  C:\Program Files\Dassault Systemes\Catia V5R19\win_b64\code\bin.
Le début du chemin dépend de ton installation.

lumpazepfel a écrit:C'est parfait, content d'avoir pu t'aider.
Mais attention les macros quand y a gouté on devient vite accro.
Alors pour info (au cas où) dans ton installation CATIA il y a un fichier d'aide qui s'appelle "V5Automation.chm" et qui se trouve dans le répertoire  C:\Program Files\Dassault Systemes\Catia V5R19\win_b64\code\bin.
Le début du chemin dépend de ton installation.

Oui je suis d’accords! J'ai déjà d'autre idée en cours pour améliorer ou ajouter des fonctionnalité au cartouche par exemple.

J'avais déjà "feuilleté" le fichier V5Automation.chm mais à l'époque je ne cherchais pas vraiment à comprendre comment m'en servir .

Bonjour à toutes et tous,

Je me permets de relancer ce fil de discussion, car je m'en suis fortement inspiré pour réaliser le cartouche de ma société.
Si tout fonctionne correctement, il me reste un problème avec les révisions qui ne bougent pas lorsque je fais un redimensionnement du cartouche.
Voici des images de mon souci:




De plus, j'aurais souhaité savoir s'il existait une macro facile à intégrer au code pour redimensionner un texte automatiquement, en fonction de l'emplacement où il se trouve dans le cartouche.
Voici ce que j'obtiens:

Voici ce que je souhaiterais:


A bientôt.
loic

Bonsoir,

Je ne travail plus sur Catia depuis 2018 :'(.

Je ne pourrai malheureusement pas t'aider sur ce point mais il est fort probable que d'autre pourront.

Cependant, je crois que j'avais le même soucis pour les révisions et il me semble que la macro permettait de réajuster l'ensemble. Sinon quand je n'arrivai pas à mes fins, je supprimais le cartouche et relançais la macro.

Bon courage .

Bonsoir Vincent,

Merci d'avoir répondu.
En effet, en effaçant le cartouche ça fonctionne mais on perd l'historique des révisions il faut donc les recréer.
Comme je vais déployer cette super macro sur plusieurs postes et plusieurs sites, j'aurais souhaité que les utilisateurs
n'aient pas gérer ce petit défaut.
Je compte aussi l'utiliser pour les cartouches de nos clients automobiles.

A bientôt.
loic

Et en utilisant la fonction redimensionner et/ou repositionner présent dans la macro ça ne donne rien?

Code:

Sub CATDrw_Resizing( targetSheet as CATIABase )
  '-------------------------------------------------------------------------------
  'How to resize the FTB
  '-------------------------------------------------------------------------------
  If Not CATInit(targetSheet) Then Exit Sub
  If CATCheckRef(0) Then Exit Sub  
  Dim TbTranslation(2)
  ComputeTitleBlockTranslation TbTranslation
  Dim RbTranslation(2)
  ComputeRevisionBlockTranslation RbTranslation
  If TbTranslation(0) <> 0 Or TbTranslation(1) <> 0 Then
    ' Redraw Sheet Frame
    DeleteAll "CATDrwSearch.DrwText.Name=Frame_Text_*"
    DeleteAll "CATDrwSearch.2DGeometry.Name=Frame_*"    
    DeleteAll "CATDrwSearch.2DGeometry.Name=TitleBlock_Logo_*"    
    CATFrame    
    
    ' Redraw Title Block Frame
    CATDeleteTitleBlockFrame
    CATCreateTitleBlockFrame    
    CATMoveTitleBlockText TbTranslation
    
    ' Redraw revision block    
    CATDeleteRevisionBlockFrame
    CATCreateRevisionBlockFrame    
    CATMoveRevisionBlockText RbTranslation

    ' Redraw TitleBlockStandard
    CATDeleteTitleBlockStandard
    CATCreateTitleBlockStandard  

    ' Move the views
    CATColorGeometry
    CATMoveViews TbTranslation
    CATLinks
    
  End If
  CATExit targetSheet

Bonsoir Vincent,

Merci je vais regarder de ce coté, sinon pour le moment en faisant une translation du texte ça pallie au problème.

Bonne soirée.
loic

Bonsoir Loïc,

Pour le déplacement des révisions, la procédure de déplacement (voir ci dessous) cherche les texte qui commencent par "RevisionBlock_Text_*"

Code:

Sub CATMoveRevisionBlockText(Translation As Varient)
  '-------------------------------------------------------------------------------
  'How to translate the whole revision block after changing the page setup
  '-------------------------------------------------------------------------------
  SelectAll "CATDrwSearch.DrwText.Name=RevisionBlock_Text_*"
  count = Selection.Count2
  For ii = 1 To count
    Set Text=Selection.Item2(ii).Value
    Text.x = Text.x + Translation(0)
    Text.y = Text.y + Translation(1)  
  Next
End Sub

Vérifie dans ton cartouche que les textes de révision soient bien nommés ainsi.
Pour cela : clique droit sur le texte, puis propriétés


Pour la taille de la zone de texte, tu peux ajouter (si ""TitleBlock_Text_Title_1" est bien le texte concerné):

Code:

if iName="TitleBlock_Text_Title_1" then
 CreateTextAF.wrappingwidth=50
  end if

dans la fonction

Code:

 Set CreateTextAF = Texts.Add(iCaption, iX, iY)
  CreateTextAF.Name           = iName
  CreateTextAF.AnchorPosition = iAnchorPosition
  CreateTextAF.SetFontSize      0, 0, iFontSize
 
  if iName="TitleBlock_Text_Title_1" then
 CreateTextAF.wrappingwidth=50 ' taille à ajuster
  end if
 
End Function

Ajuste la taille (ici 50) à la dimension de ton cartouche.

Bonsoir Lumpazepfel,

Merci pour tes explications !
Je viens d'essayer la fonction "wrappingwidth", ça correspond à ce que je recherchais dans le principe. Actuellement, le texte est justifié à gauche, je souhaiterais le centrer.
J'ai un peu cherché sur internet, mais je suis largué en programmation.
Pour la révision, vu que je n'utilise que le texte (et pas le cartouche de révision que j'ai désactivé) et que je commence directement à l'indice "B", j'ai du désactiver le point de référence de la position du texte, car j'ai bien le code dont tu parles dans la macro.
Je vais ré-investiguer sur le code d’origine pour voir le comportement.

A bientôt.

Loic

Salut Loïc,

La macro créée les différents textes et leurs donne un nom qui commence en  général par "TitleBlock_Text_". Cela est indispensable pour ensuite faire une recherche pour déplacer ou modifier la valeur de ces différents  texte.

Autre info, tu trouveras dans ton installation CATIA un fichier d'aide avec les différentes fonction pour les script CATIA : "V5Automation.chm"; il se trouve sous "C:\Program Files\Dassault Systemes\B23\win_b64\code\bin\ (à modifier suivant ta version CATIA)
Egalement ci dessous un lien vers fichier d'aide qui regroupe plusieurs petites macros et autres infos utiles:
https://files.engineering.com/getfile.aspx?folder=2c65e9c4-403e-46a8-b119-090d258a691e&file=CATIA_Portable_Script_Center_v2.0.7z&__hstc=212727627.9413155b89dcb2be9bc8daf4c1c132c2.1583782307687.1606498380525.1606645716072.11&__hssc=212727627.1.1606645716072&__hsfp=3023692804

Bonsoir Lumpazepfel,

Merci pour l'aide ainsi que les infos, j'ai maintenant plein de lecture pour les longues soirées d'hivers.

A bientôt.

Loic