Script BASIC - VB6 OCX Forms

[John]

I was able to get my OLD (On Line Dictionary) OCX to do the following.

• Compile
• Register
• Create instance
• Show the On Line Dictionary form
• Process a Fetch button callback to Script BASIC - (passing no arguments with no return value to VB)
  
• Process an About button callback to Script BASIC - (passing 3 arguments and returning a string back to VB)
  

      

Code: ScriptBasic

1. IMPORT COM.sbi
2. IMPORT DYC.sbi
3.  
4. FUNCTION Fetch_Clicked
5.   DYC::dyc("ms,i,USER32.DLL,MessageBox,PZZL",0,"Fetch Clicked" & CHR(0),"On Line Dictionary",0)
6.   Fetch_Clicked = TRUE
7. END FUNCTION
8.  
9. FUNCTION About_Clicked(arg0,arg1,arg2)
10.   DYC::dyc("ms,i,USER32.DLL,MessageBox,PZZL",0,"About Clicked\nAbout Me: " & arg0 & "\n" & _
11.                                                 arg1 & " " & arg2 & CHR(0), _
12.                                                 "On Line Dictionary",0)
13.   About_Clicked = "Return from About click"
14. END FUNCTION
15.  
16.  
17. obj = COM::CREATE(:SET, "OLD.OLDict")
18. oCollection = COM::CBN(obj, "CallBackHandlers", :GET)
19. COM::CBN oCollection, "Add", :CALL, ADDRESS(Fetch_Clicked()), "win.btnFetch_Click"
20. COM::CBN oCollection, "Add", :CALL, ADDRESS(About_Clicked()), "win.btnAbout_Click"
21. COM::CBN obj, "ShowOLD"
22. COM::RELEASE obj
23.  

OLD.cls

Code: Visual Basic

1. Public CallBackHandlers As New Collection
2.  
3. Public Function ShowOLD() As Long
4.     ShowOLD = win.ShowMain(Me)
5. End Function
6.  

Main.frm (win)

Code: Visual Basic

1. Private Declare Function ext_SBCallBack Lib "COM.dll" Alias "SBCallBack" (ByVal EntryPoint As Long, ByVal arg As Long) As Long
2. Private Declare Function ext_SBCallBackEx Lib "COM.dll" Alias "SBCallBackEx" (ByVal EntryPoint As Long, ByRef v As Variant) As Variant
3.  
4. Private m_owner As OLDict
5.  
6. Function ShowMain(owner As OLDict) As Long
7.     On Error Resume Next
8.     Set m_owner = owner
9.     Me.Show 1
10.     Set m_owner = Nothing
11.     ShowMain = 0
12.     Unload Me
13. End Function
14.  
15. Private Function TriggerCallBack(nodeID As Long, argValue As Long)
16.     TriggerCallBack = ext_SBCallBack(nodeID, argValue)
17. End Function
18. Private Function TriggerCallBackEx(nodeID As Long, v() As Variant)
19.     TriggerCallBackEx = ext_SBCallBackEx(nodeID, v)
20. End Function
21.  
22. Private Sub btnFetch_Click()
23.     Dim nodeID As Long
24.     Dim arg As Long
25.     Dim rtnVal As Long
26.    
27.     nodeID = m_owner.CallBackHandlers("win.btnFetch_Click")
28.     arg = False
29.     rtnVal = TriggerCallBack(nodeID, arg)
30. End Sub
31.  
32. Private Sub btnAbout_Click()
33.     Dim nodeID As Long
34.     Dim args(3)
35.     Dim rtnVal As String
36.    
37.     nodeID = m_owner.CallBackHandlers("win.btnAbout_Click")
38.     Set args(0) = Me
39.     args(1) = 99
40.     args(2) = "Bottles of beer."
41.     rtnVal = TriggerCallBackEx(nodeID, args)
42.     MsgBox rtnVal, vbExclamation
43. End Sub
44.  

[John]

I just wanted to mention I couln't be happier how well this is working even if no one else cares.

I see this saving me a tons of time building modern GUI applications that are easy to create and support.

Lets hope MS keeps COM/OLE automation around for awhile.

[AlyssonR]

I can't see COM/OLE disappearing in the near future - it is too deeply embedded into the current generation of applications.

Mind you, even if it does get cut, I'm sure the Open Source community (fingers crossed here) will end up producing a COM/OLE to whatever's new bridge (driver).

[John]

If Microsoft wants to keep the developers they have, taking things away isn't the way to do it.

[John]

I had forgotten about the MsgBox function in the NT extension module. Much easier to use than the DYC FFI call to the Windows MessageBox API function.

NT MsgBox Documentation

Code: ScriptBasic

1. IMPORT COM.sbi
2. IMPORT NT.sbi
3.  
4. FUNCTION Fetch_Clicked
5.   NT::MsgBox "Fetch Clicked", "On Line Dictionary", "OK","Info", 1
6.   Fetch_Clicked = TRUE
7. END FUNCTION
8.  
9. FUNCTION About_Clicked(arg0,arg1,arg2)
10.   NT::MsgBox "About Clicked\nAbout Me: " & arg0 & "\n" & _
11.               arg1 & " " & arg2, "On Line Dictionary", "OK","Info", 1
12.   About_Clicked = "Return from About click"
13. END FUNCTION
14.  
15.  
16. obj = COM::CREATE(:SET, "OLD.OLDict")
17. oCollection = COM::CBN(obj, "CallBackHandlers", :GET)
18. COM::CBN oCollection, "Add", :CALL, ADDRESS(Fetch_Clicked()), "win.btnFetch_Click"
19. COM::CBN oCollection, "Add", :CALL, ADDRESS(About_Clicked()), "win.btnAbout_Click"
20. COM::CBN obj, "ShowOLD"
21. COM::RELEASE obj
22.  

     

[John]

For those wondering if this runs on the current version of Windows 10.




      

[John]

The author of the VBCCR (Common Controls Replacement) OCX also wrote a MSFlexGrid Replacement OCX. It supports Unicode among other enhancements.

[AlyssonR]

░░░░░░░░░░░░▄▄░░░░░░░░░
░░░░░░░░░░░█░░█░░░░░░░░
░░░░░░░░░░░█░░█░░░░░░░░
░░░░░░░░░░█░░░█░░░░░░░░
░░░░░░░░░█░░░░█░░░░░░░░
███████▄▄█░░░░░██████▄░░
▓▓▓▓▓▓█░░░░░░░░░░░░░░█░
▓▓▓▓▓▓█░░░░░░░░░░░░░░█░
▓▓▓▓▓▓█░░░░░░░░░░░░░░█░
▓▓▓▓▓▓█░░░░░░░░░░░░░░█░
▓▓▓▓▓▓█░░░░░░░░░░░░░░█░
▓▓▓▓▓▓█████░░░░░░░░░█░░
██████▀░░░░▀▀██████▀░░░░

[John]

Here is the VB6 OCX version of the On Line Dictionary example. Compare it to the IUP version in post #12 of this thread.

Code: ScriptBasic

1. IMPORT COM.sbi
2. IMPORT NT.sbi
3.  
4. servers[0]="dict.org"
5. servers[1]="dict1.us.dict.org"
6. servers[2]="all.dict.org"
7.  
8. FUNCTION btnFetch_Clicked
9.   LOCAL dat, total, count
10.   ON ERROR GOTO G_NetError
11.   server_selection = COM::CBN(obj, "CurrentServer")
12.   OPEN server_selection & ":2628" FOR SOCKET AS #1
13.   PRINT#1,"SHOW DB\n"
14.   LINE INPUT#1, dat
15.   LINE INPUT#1, dat
16.   count = 0
17.   WHILE LEFT(dat, 1) <> "."
18.     LINE INPUT#1, dat
19.     IF LEFT(dat, 1) <> "." THEN total[count] = TRIM(dat)
20.     count+=1
21.   WEND
22.   PRINT#1,"QUIT\n"
23.   CLOSE(#1)
24.   FOR cnt = 0 TO count - 2
25.     COM::CBN obj, "AddDictionaries", :CALL, total[cnt]
26.   NEXT
27.   COM::CBN obj, "DefaultDictionary"
28.   btnFetch_Clicked = TRUE
29.   EXIT FUNCTION
30.  
31.   G_NetError:
32.   NT::MsgBox "Server " & server_selection & " not available. (" & ERROR & ")", "OLD Error", "OK","Info", 1
33. END FUNCTION
34.  
35. FUNCTION btnSearch_clicked
36.   LOCAL dict, dat, total, info
37.   ON ERROR GOTO L_NetError
38.   whichDictionary = COM::CBN(obj, "CurrentDictionary")
39.   searchword = COM::CBN(obj, "SearchWord", :GET)
40.   dict = LEFT(whichDictionary, INSTR(whichDictionary, " "))
41.   OPEN COM::CBN(obj, "CurrentServer") & ":2628" FOR SOCKET AS 1
42.   IF COM::CBN(obj, "AllDict", :GET) THEN
43.     PRINT#1,"DEFINE * " & searchword & "\n"
44.   ELSE
45.     PRINT#1,"DEFINE " & dict & " " & searchword & "\n"
46.   END IF
47.   REPEAT
48.     LINE INPUT#1, dat
49.     IF LEFT(dat, 3) = "151" THEN
50.       total$ &= "------------------------------\r\n"
51.       total$ &= RIGHT(dat, LEN(dat) - LEN(searchword) - LEN(dict))
52.       total$ &= "------------------------------\r\n"
53.       REPEAT
54.         LINE INPUT#1, info
55.         info = REPLACE(info, CHR(34), CHR(92) & CHR(34))
56.         IF LEFT(info, 1) <> "." THEN total &= TRIM(info) & "\r\n"
57.       UNTIL LEFT(info, 1) = "."
58.       total &= "\r\n"
59.     END IF
60.   UNTIL LEFT(dat, 3) = "250" OR VAL(LEFT(dat, 3)) > 499
61.   PRINT#1,"QUIT\n"
62.   CLOSE(#1)
63.   IF LEFT(dat, 3) = "552" THEN
64.     total = "No match found."
65.   ELSE IF LEFT(dat, 3) = "501" THEN
66.     total = "Select a dictionary first!"
67.   ELSE IF LEFT(dat, 3) = "550" THEN
68.     total = "Invalid database!"
69.   END IF
70.   COM::CBN(obj, "SetTranslation", :CALL, total)
71.   btnSearch_Clicked = TRUE
72. EXIT FUNCTION
73.  
74. L_NetError:
75.   dat[0] = "Could not lookup word! (" & ERROR & ")"
76.   COM::CBN(obj, "SetTranslation", :CALL, dat)
77. END FUNCTION
78.  
79. ' MAIN
80.  
81. obj = COM::CREATE(:SET, "OLD.OLDict")
82. oCollection = COM::CBN(obj, "CallBackHandlers", :GET)
83. COM::CBN oCollection, "Add", :CALL, ADDRESS(btnFetch_Clicked()), "win.btnFetch_Click"
84. COM::CBN oCollection, "Add", :CALL, ADDRESS(btnSearch_Clicked()), "win.btnSearch_Click"
85. FOR idx = 0 TO UBOUND(servers)
86.   COM::CBN obj, "AddServer", :CALL, servers[idx]
87. NEXT  
88. COM::CBN obj, "DefaultServer"
89. COM::CBN obj, "ShowOLD"
90. COM::RELEASE obj
91.  

FORM

Code: Visual Basic

1. Private Declare Function ext_SBCallBack Lib "COM.dll" Alias "SBCallBack" (ByVal EntryPoint As Long, ByVal arg As Long) As Long
2. Private Declare Function ext_SBCallBackEx Lib "COM.dll" Alias "SBCallBackEx" (ByVal EntryPoint As Long, ByRef v As Variant) As Variant
3.  
4. Private m_owner As OLDict
5. Private Type ControlPositionType
6.     Left As Single
7.     Top As Single
8.     Width As Single
9.     Height As Single
10.     FontSize As Single
11. End Type
12.  
13. Private m_ControlPositions() As ControlPositionType
14. Private m_FormWid As Single
15. Private m_FormHgt As Single
16.  
17.  
18. Function ShowMain(owner As OLDict) As Long
19.     On Error Resume Next
20.     Set m_owner = owner
21.     Me.Show 1
22.     Set m_owner = Nothing
23.     ShowMain = 0
24.     Unload Me
25. End Function
26.  
27. Private Function TriggerCallBack(nodeID As Long, argValue As Long) As Long
28.     TriggerCallBack = ext_SBCallBack(nodeID, argValue)
29. End Function
30.  
31. Private Function TriggerCallBackEx(nodeID As Long, v() As Variant)
32.     TriggerCallBackEx = ext_SBCallBackEx(nodeID, v)
33. End Function
34.  
35. Public Sub btnClear_Click()
36.     win.serverList.Clear
37.     win.dictTB.Text = ""
38.     win.entry.Text = ""
39.     win.btnFetch.SetFocus
40.     End Sub
41.  
42. Private Sub btnExit_Click()
43.     Set m_owner = Nothing
44.     btnExit = 0
45.     Unload Me
46. End Sub
47.  
48. Private Sub btnFetch_Click()
49.     Dim nodeID As Long
50.     Dim arg As Long
51.     Dim rtnVal As Long
52.    
53.     win.serverList.Clear
54.     nodeID = m_owner.CallBackHandlers("win.btnFetch_Click")
55.     arg = False
56.     rtnVal = TriggerCallBack(nodeID, arg)
57. End Sub
58.  
59. Private Sub btnSearch_Click()
60.     Dim nodeID As Long
61.     Dim arg As Long
62.     Dim rtnVal As Long
63.    
64.     nodeID = m_owner.CallBackHandlers("win.btnSearch_Click")
65.     arg = False
66.     rtnVal = TriggerCallBack(nodeID, arg)
67. End Sub
68.  
69. Private Sub btnAbout_Click()
70.     MsgBox "Script BASIC VB6" & vbCrLf & "On Line Dictionary", vbInformation, "About"
71. End Sub
72.  
73.  
74. ' Save the form's and controls' dimensions.
75. Private Sub SaveSizes()
76. Dim i As Integer
77. Dim ctl As Control
78.  
79.     ' Save the controls' positions and sizes.
80.    ReDim m_ControlPositions(1 To Controls.Count)
81.     i = 1
82.     For Each ctl In Controls
83.         With m_ControlPositions(i)
84.             If TypeOf ctl Is Line Then
85.                 .Left = ctl.X1
86.                 .Top = ctl.Y1
87.                 .Width = ctl.X2 - ctl.X1
88.                 .Height = ctl.Y2 - ctl.Y1
89.             Else
90.                 .Left = ctl.Left
91.                 .Top = ctl.Top
92.                 .Width = ctl.Width
93.                 .Height = ctl.Height
94.                 On Error Resume Next
95.                 .FontSize = ctl.Font.Size
96.                 On Error GoTo 0
97.             End If
98.         End With
99.         i = i + 1
100.     Next ctl
101.  
102.     ' Save the form's size.
103.    m_FormWid = ScaleWidth
104.     m_FormHgt = ScaleHeight
105. End Sub
106.  
107. Private Sub Form_Load()
108.     SaveSizes
109. End Sub
110.  
111. Private Sub Form_Resize()
112.     ResizeControls
113. End Sub
114.  
115. ' Arrange the controls for the new size.
116. Private Sub ResizeControls()
117. Dim i As Integer
118. Dim ctl As Control
119. Dim x_scale As Single
120. Dim y_scale As Single
121.  
122.     ' Don't bother if we are minimized.
123.    If WindowState = vbMinimized Then Exit Sub
124.  
125.     ' Get the form's current scale factors.
126.    x_scale = ScaleWidth / m_FormWid
127.     y_scale = ScaleHeight / m_FormHgt
128.  
129.     ' Position the controls.
130.    i = 1
131.     For Each ctl In Controls
132.         With m_ControlPositions(i)
133.             If TypeOf ctl Is Line Then
134.                 ctl.X1 = x_scale * .Left
135.                 ctl.Y1 = y_scale * .Top
136.                 ctl.X2 = ctl.X1 + x_scale * .Width
137.                 ctl.Y2 = ctl.Y1 + y_scale * .Height
138.             Else
139.                 ctl.Left = x_scale * .Left
140.                 ctl.Top = y_scale * .Top
141.                 ctl.Width = x_scale * .Width
142.                 If Not (TypeOf ctl Is ComboBox) Then
143.                     ' Cannot change height of ComboBoxes.
144.                    ctl.Height = y_scale * .Height
145.                 End If
146.                 On Error Resume Next
147.                 ctl.Font.Size = y_scale * .FontSize
148.                 On Error GoTo 0
149.             End If
150.         End With
151.         i = i + 1
152.     Next ctl
153. End Sub
154.  

CLASS

Code: Visual Basic

1. Public CallBackHandlers As New Collection
2.  
3. Public Function ShowOLD() As Long
4.     ShowOLD = win.ShowMain(Me)
5. End Function
6.  
7. Public Sub AddServer(server_url As String)
8.     win.serverCombo.AddItem server_url
9. End Sub
10.  
11. Public Sub DefaultServer()
12.     win.serverCombo.ListIndex = 0
13. End Sub
14.  
15. Public Function CurrentServer() As String
16.     CurrentServer = win.serverCombo.List(win.serverCombo.ListIndex)
17. End Function
18.  
19. Public Sub AddDictionaries(dictionary As String)
20.     win.serverList.AddItem dictionary
21. End Sub
22.  
23. Public Function CurrentDictionary() As String
24.     CurrentDictionary = win.serverList.List(win.serverList.ListIndex)
25. End Function
26.  
27. Public Sub DefaultDictionary()
28.     win.serverList.ListIndex = 0
29. End Sub
30.  
31. Public Sub SetTranslation(translation_text As String)
32.     win.dictTB.Text = translation_text
33. End Sub
34.  
35. Public Property Get SearchWord() As String
36.     win.dictTB.SetFocus
37.     SearchWord = win.entry.Text
38. End Property
39.  
40. Public Property Get AllDict() As Long
41.     AllDict = win.chkAll.Value
42. End Property
43.  

[John]

I've changed the GetALL and GetEntry methods to AllDict and SearchWord properties. The Script BASIC and VB CLASS code in the previous post has been updated with the GET property changes.

Here is how the Script BASIC COM interface browser sees the OCX DLL.

[John]

I've added resize ability to to On Line Dictionary form. The routines are simple to use and also handles resizing the fonts.  Code updated in post #23.

[John]

At this point, the VB6 based On Line Dictionary is functionally equivalent to the IUP version shown earlier in this thread. Other than not being cross platform, I like the VB6 direction more.

[John]

I have provided my proof of concept of using an OCX control to provide an intelligent GUI as a COM object.

I would be interested in how others feel about the concept and would you use it?

[AlyssonR]

Once I am back into development, I'll certainly take a long, hard look.

It is certainly an area that interests me to no end.

[John]

+1

Any others?

I'm trying to get Charles Pegge (Oxygen Basic author) to create a similar CallByName interface as what we have working with Script BASIC. It would be great to have a BASIC compiler support OCX forms (created with VB Classic or VB.NET) as well as having an interpretive solution.

I never did get a response to what BASIC languages support COM/OLE automation.