' -----------------------------------------------------------------------------
' --- CustomDialogClass.CATScript
' -----------------------------------------------------------------------------
' (c) 2023, Johann Oberdorfer - Engineering Support | CAD | Software
' johann.oberdorfer [at] gmail.com
' www.johann-oberdorfer.eu
' -----------------------------------------------------------------------------
' This source file is distributed under the BSD license.
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
' See the BSD License for more details.
' -----------------------------------------------------------------------------
' -----------------------------------------------------------------------------
'
' Purpose:
'
' A generic user dialog for Catia.
' This is a prove of concept and is based on HTA + mshta.exe, whereas
' the HTA:Application is configured to emulate "Edge" mode.
' Is it guaranteed so that mshta.exe will be supported in the future?
' Mshta.exe depends on mshta.dll which is part of the OS and most likely
' it will be supported. As we are speaking about MS, of course, this is
' only a good guess.
'
' Techniques/programming languages used:
' catscript class, HTML, CSS, javascript,
' HTA (running in edge emulation mode), WShell
'
' The dialog can be configured via a variety of input arguments.
' When calling up, the dialog window is positioned in the center
' of the Catia screen (multi screen environment also supported).
' The layout of the dialog can be styled via css and behavior and
' event management can be programmed via javascript as for any web
' application.
' As mentioned above, this is a prove of concept and the source code
' provided here might be a starting point for an even more elaborated
' user dialog.
' The return value(s) is(are) returned to the catscript caller via
' the "wshell stdout" stream and so the dialog keeps alive as long as
' the stdout stream does not return -eof- code (or similar).
' -----------------------------------------------------------------------------
' -----------------------------------------------------------------------------
' Option Explicit
Language="VBSCRIPT"
Class CustomDialogClass
Private H() As String
Private Image As String
Private Sub Class_Initialize()
ReDim H(0)
Image = ""
End Sub
' Private Sub Class_Terminate()
' End Sub
Private Sub LAdd (ByVal str As String)
' index always starts at position 1
ReDim Preserve H (UBound(H) + 1)
H (UBound(H)) = str
End Sub
Private Property Get Count() As Long
Count = UBound(H)
End Property
Private Property Get Item (ByVal index As Long) As String
Item = H(index)
End Property
Private Function CreateUniqueFileName ( _
ByVal file_name As String, _
ByVal file_ext As String, _
ByRef full_path_name As String) As Boolean
Dim d,m,y, _
date_str, time_str, temp_dir As String
Dim str As Folder
Dim fs As FileSystem
' get the user's temporary directory ...
' --------------------------------------
Set fs = CATIA.FileSystem
Set str = fs.TemporaryDirectory
temp_dir = CATIA.SystemService.Environ(str.Name)
IF ( Not fs.FolderExists(temp_dir) ) Then
CreateUniqueFileName = False
Exit Function
End IF
' create a unique time-stamp
' --------------------------
' note:
' date_str = FormatDateTime(Now(), vbGeneralDate)
' does not work very well as the function relies
' on system default settings which might be unpredictable
d = Day(Now())
m = Month(Now())
y = Right(Year(Now()), 2)
If Len(d) = 1 Then d = "0" & d
If Len(m) = 1 Then m = "0" & m
date_str = y & "-" & m & "-" & d
time_str = Replace (Time, ":", "-", 1, -1, vbTextCompare)
time_stamp = Replace (date_str & "-" & time_str, " ", "-", 1, -1, vbTextCompare)
' and finally, create a full pathname
file_name = file_name + "-" + time_stamp + file_ext
full_path_name = fs.ConcatenatePaths(temp_dir, file_name)
CreateUniqueFileName = True
End Function
' // attempt to open a data file
' //
Private Function OpenDataFileForWriting ( _
ByVal fileName As String, _
ByRef ostream As CATIATextStream) As Boolean
Dim Overwrite As Boolean : Overwrite = True
Dim fs As FileSystem
Dim f As File
OpenDataFileForWriting = False
Set fs = CATIA.FileSystem
Err.Clear : On Error Resume Next
Set f = fs.CreateFile(fileName, Overwrite)
On Error Goto 0
If (Err.Number <> 0) Then
Exit Function
End IF
' attempt to open the output file
Err.Clear : On Error Resume Next
Set ostream = f.OpenAsTextStream( "ForWriting" )
On Error Goto 0
If (Err.Number <> 0) Then
Exit Function
End If
OpenDataFileForWriting = True
End Function
' no external or add on files are used
'
Private Sub BuildDialog ( _
ByVal w As Long, ByVal h As Long, _
ByVal msg As String, ByVal params() As String)
Dim i As Integer
Dim label, rbutton As String
Dim left, top As Long
Dim fs As CATIAFileSystem
Set fs = CATIA.FileSystem
' header block...
LAdd "<html>"
LAdd "<head>"
LAdd "<title>Option Dialog</title>"
LAdd "<hta:application"
LAdd " id='myHTA' applicationname='Select Option:'"
LAdd " border='thin' borderstyle='normal' innerborder='no'"
LAdd " caption='yes'"
LAdd " singleinstance='yes'"
LAdd " showintaskbar='yes'"
LAdd " navigable='yes'"
LAdd " sysmenu='no' contextmenu='no'"
LAdd " maximizebutton='no' minimizebutton='no'"
LAdd " resizable='no'>"
LAdd "<meta http-equiv='x-ua-compatible' content='ie=edge'>"
LAdd "<style>"
LAdd "body {"
LAdd " padding:0; margin:0;"
LAdd " font-family: Arial,sans-serif; font-size:12px;"
LAdd "}"
LAdd ".container {"
LAdd " display:flex;"
LAdd " flex-direction:column;"
LAdd " align-items:center;"
LAdd " justify-content:center;"
LAdd " background-color:GhostWhite;"
LAdd "}"
LAdd "label {"
LAdd " display:block;"
LAdd " margin:5px;"
LAdd " padding:10px;"
LAdd " border:1px solid #ccc;"
LAdd " border-radius:10px;"
LAdd " cursor:pointer;"
LAdd " transition:background-color 0.2s ease;"
LAdd " background:GhostWhite;"
LAdd " min-width:200px;font-size:14px;"
LAdd "}"
LAdd " label:hover {"
LAdd " background-color:CornflowerBlue;"
LAdd "}"
LAdd "button {"
LAdd " margin:5px;"
LAdd " padding:5px 5px;"
LAdd " border:1px solid #ccc;"
LAdd " border-radius:5px;"
LAdd " cursor:pointer;"
LAdd " transition:background-color 0.2s ease;"
LAdd " min-width:100px;"
LAdd "}"
LAdd "button:hover {"
LAdd " background-color:CornflowerBlue;"
LAdd "}"
LAdd "#okButton:focus, #cancelButton:focus {"
LAdd " outline:none;"
LAdd "}"
LAdd "img {"
LAdd " max-width:100%;"
LAdd " height:auto;"
LAdd " margin-top:5px;margin-bottom:5px;"
LAdd "}"
LAdd "</style>"
LAdd "</head>"
LAdd "<body scroll='no' style='background-color:Lavender;' >"
' logo goes here ...
If (fs.FileExists(Image)) Then
LAdd "<div class='container'>"
LAdd "<img src='" + Image + "'>"
LAdd "</div>"
ElseIf _
(Len(Image) > 100) Then ' is a base64 encoded image ?
LAdd "<div class='container'>"
LAdd "<img src='data:image/png;base64, " + Image + " '>"
LAdd "</div>"
End If
LAdd "<div class='container' style='background-image: linear-gradient(GhostWhite,Lavender);'>"
' message goes here ...
If (Len(msg) <> 0) Then
LAdd "<h3>"
LAdd msg
LAdd "</h3>"
End If
LAdd "<div class='radio'>"
' "<label id='label1' onclick='selectLabel(""label1"")' style='background-color:CornflowerBlue;'>"
' "<input type='radio' id='myRadioButton1' name='myRadioGroup' value='Option 1' checked>"
' "Option 1"
' "</label>"
' "<br/>"
For i = 1 To Ubound(params)
label = "label" + CStr(i)
rbutton = "myRadioButton" + CStr(i)
value = Trim(params(i))
If (InStr(1, value, "*", vbTextCompare)) Then
value = Mid (value, 2, Len(value))
LAdd "<label id='" + label + "' onclick='selectLabel(""" + label + """)' style='background-color:CornflowerBlue;'>"
LAdd "<input type='radio' id='" + rbutton + "' name='myRadioGroup' value='" + value + "' checked>"
LAdd value
LAdd "</label>"
Else
LAdd "<label id='" + label + "' onclick='selectLabel(""" + label + """)'>"
LAdd "<input type='radio' id='" + rbutton + "' name='myRadioGroup' value='" + value + "'>"
LAdd value
LAdd "</label>"
End If
Next
LAdd "</div>"
LAdd "</div>"
LAdd "<div class='container' style='background:Gainsboro; border-radius: 0px; padding:10px;'>"
LAdd "<div>"
LAdd "<button id='okButton' onclick='OK_Click()'>OK</button>"
LAdd "<button id='cancelButton' onclick='Cancel_Click()'>Cancel</button>"
LAdd "</div>"
LAdd "</div>"
LAdd "<script type='text/javascript'>"
If (TypeName(CATIA) = "Application") Then
' some screen arithmetics required to place the dialog centered
' on-top of the CATIA window, should also work for dual screens...
left = CATIA.Left + (CATIA.Width/2)-(w/2)
top = CATIA.Top + (CATIA.Height/2)-(h/2)
LAdd "window.resizeTo(" + CStr(w) + "," + CStr(h) + ");"
LAdd "window.moveTo(" + CStr(left) + "," + CStr(top) + ");"
LAdd "window.focus();"
Else
' fallback solution
LAdd "const w = " + CStr(w) + ";"
LAdd "const h = " + CStr(h) + ";"
LAdd "window.resizeTo(w, h);"
LAdd "window.moveTo((screen.availWidth - w) / 2, (screen.availHeight - h) / 2);"
LAdd "window.focus();"
End If
LAdd "function selectLabel(labelId) {"
LAdd "const labels = document.getElementsByTagName('label');"
LAdd "for (let i = 0; i < labels.length; i++) {"
LAdd "labels[i].style.backgroundColor = '';"
LAdd "}"
LAdd "const selectedLabel = document.getElementById(labelId);"
LAdd "selectedLabel.style.backgroundColor = 'CornflowerBlue';"
LAdd "}"
class_LAdd "function OK_Click() {"
class_LAdd "const stdout = new ActiveXObject('Scripting.FileSystemObject').GetStandardStream(1);"
class_LAdd "var inputs = document.querySelectorAll('input[name=""myRadioGroup""]');"
class_LAdd "var usr = 0;"
class_LAdd "for (var i = 0; i < inputs.length; ++i) {"
class_LAdd "if (inputs[i].checked) {"
class_LAdd "usr = i+1;"
class_LAdd "break;"
class_LAdd "}"
class_LAdd "}"
class_LAdd "if (usr === 0) {"
class_LAdd "stdout.WriteLine('');"
class_LAdd "} else {"
class_LAdd "stdout.WriteLine(usr);"
class_LAdd "}"
class_LAdd "window.close(1);"
class_LAdd "}"
LAdd "function Cancel_Click() {"
LAdd "window.close();"
LAdd "}"
LAdd "document.addEventListener('keydown', function(event) {"
LAdd "if (event.key === 'Enter') {"
LAdd "event.preventDefault();"
LAdd "document.getElementById('okButton').click();"
LAdd "}"
LAdd "event = window.event;"
LAdd "if (event.keyCode == 27) {"
LAdd "event.preventDefault();"
LAdd "document.getElementById('cancelButton').click();"
LAdd "}"
LAdd "});"
LAdd "</script>"
LAdd "</body>"
End Sub
Public Sub SetImage (ByVal mmencoded_str As string) As String
Image = mmencoded_str
End Sub
Public Function ShowSelectionDialog ( _
ByVal w As Long, ByVal h As Long, _
ByVal msg As String, ByVal params() As String) As String
Dim usr, hta_dialog_filename As String
Dim fs As FileSystem
Dim ostream As CATIATextStream
Dim wsh As IWsgShell3
Dim hta As WshExec
Set fs = CATIA.FileSystem
' create unique temp File
If ( Not CreateUniqueFileName ("hta_dialog", ".hta", hta_dialog_filename)) Then
Err.Raise 1010, _
"CustomDialogClass", _
"Unable to create temporary file: " + hta_dialog_filename
End If
If (Not OpenDataFileForWriting (hta_dialog_filename, ostream) ) Then
Err.Raise 1011, _
"CustomDialogClass", _
"Unable to open file: " + hta_dialog_filename + " for writing!"
End If
' build dialog
Call BuildDialog (w,h, msg, params)
' write hta dialog information to temp file...
For i = 1 To Count
ostream.Write Item(i) + Chr(10)
Next
ostream.Close
' call up the the dialog
usr = ""
' mshta.exe
' - is based on mshta.dll which is part of the windows OS and is supported
' for the future (whereas IE is running out of support)
' - no more command line options, takes a script as argument,
' or a HTA dialog file, when using HTA a file is required,
' a string which holds the hta code is not accepted (!)
'
Set wsh = CreateObject("WScript.Shell")
Set hta = wsh.Exec("mshta.exe " + hta_dialog_filename)
If hta.ExitCode <> 0 Then
' handle error (if any)
MsgBox "Error occured while executing mshta.exe!"
Else
' get the selected value from the HTA window,
' CATIA keeps in frozen state as long as 'stdout stream'
' does not send eof-stream...
Do Until hta.StdOut.AtEndOfStream
usr = hta.StdOut.ReadLine()
Loop
End If
fs.DeleteFile (hta_dialog_filename)
' return value
ShowSelectionDialog = usr
End Function
End Class
' ------------------------
' dialog test goes here...
' ------------------------
Dim MMENCODED_LOGO As String
MMENCODED_LOGO = _
"iVBORw0KGgoAAAANSUhEUgAAAPoAAAA6CAMAAACu2rS7AAAABGdBTUEAALGPC" + _
"VQAAAL3UExURUdwTP8MAP7+/87Ozujo6P///9HR0ezs7O3t7evr683Nzf+KAO" + _
"...truncated, insert your own logo here (optional) ..."
Sub LAddValue (ByRef options() As String, ByVal str As String)
' index always starts at position 1
ReDim Preserve options (UBound(options) + 1)
options (UBound(options)) = str
End Sub
' example function, can be called directly from CATMain
Function CustomDialogClass_Cmd (ByVal options() As String) As String
Dim usr As String
Dim DLG As CustomDialogClass
Set DLG = New CustomDialogClass
' DLG.SetImage (MMENCODED_LOGO)
usr = DLG.ShowSelectionDialog (_
400, 500, "Select your required option:", options)
Set DLG = Nothing
CustomDialogClass_Cmd = usr
End Function
' example function, can be called via "CATIA.SystemService.ExecuteScript"
Function CustomDialogClass_Cmd1 ( _
ByVal opt_w As Integer, ByVal opt_h As Integer, _
ByVal option_str As String) As String
Dim arr As Array
Dim usr As String
Dim options() As String
Dim DLG As CustomDialogClass
ReDim options(0)
arr = Split(option_str, "@")
For i = 0 To Ubound(arr)
LAddValue options, arr(i)
Next
Set DLG = New CustomDialogClass
' DLG.SetImage (MMENCODED_LOGO)
DLG.SetImage ("<Your own path here>\job_engineering_logo_small-min.png")
usr = DLG.ShowSelectionDialog (_
opt_w, opt_h, "Select your required option:", options)
Set DLG = Nothing
CustomDialogClass_Cmd1 = usr
End Function
Sub CATMain ()
Dim usr, options() As String
' Dim catia_w, catia_h As Integer
' if a "*" is used at the 1st place,
' this option becomes the default one
ReDim options(4)
options(1) = "The quick brown fox"
options(2) = "*jumps over" 'default option
options(3) = "walks around"
options(4) = "the lazy dog."
' MsgBox CStr(catia_w) + " : " + CStr(catia_h)
CATIA.RefreshDisplay = False
' -----------------------------------
usr = CustomDialogClass_Cmd (options)
' -----------------------------------
If (Len(usr) = 0) Then
MsgBox "Nothing selected!"
Else
MsgBox "You selected: " + usr
End If
End Sub
