VB6 - Unicode PopupMenu Captions and PopupMenu Radio Buttons

This is just a simple class for allowing Popup Menus (also known as Context Menus) to display Unicode captions. It also shows how you can use Radio Buttons (also known as Option Buttons) instead of the classic Check Box behavior. Option Buttons are used when you need a single selection from a list of options while Check Boxes are used to select multiple individual items from a list.

PopupMenu Unicode Captions:

Attachment 188627

PopupMenu Radio Buttons:

Attachment 188628

Attachment 188629

Although this sample focuses on PopupMenus, the same concept can be applied to regular window menus.

Here is the demo project: Attachment 188630

Excellent work. Do I have to alter the code to see your beautiful Unicode languages? All I get when I run it are the check boxes and options.
Regardless, it would be awesome if beside your checkboxes, etc., the Unicode words were beside the English. Cheers

There's one commented line in "Form_Load" that loads the Unicode text from a file. Remove the comment and you'll see something similar to the first screenshot above.

Adding this message will allow you to stop IDE without error messages:

Code:

---

Const WM_UAHDESTROYWINDOW As Long = &H90&
Case WM_NCDESTROY, WM_UAHDESTROYWINDOW
            UnSubclassWnd hWnd, Subclass

---

P.S. Thanks for nice demo!

I think you will find that using CreatePopupMenu and subsequent AppendMenuW much more simple and flexible (for variable amount of items, sub menus tree, formatting, etc), no subclassing is needed.

Quote:

---

Originally Posted by Dragokas

Adding this message will allow you to stop IDE without error messages:

Code:

---

Const WM_UAHDESTROYWINDOW As Long = &H90&
Case WM_NCDESTROY, WM_UAHDESTROYWINDOW
            UnSubclassWnd hWnd, Subclass

---

P.S. Thanks for nice demo!

---

Hey, this is actually pretty cool, this strange and undocumented "WM_UAHDESTROYWINDOW" message really prevents crashing when clicking the Stop button in IDE on a project that employs subclassing! Unfortunately it only works if you subclass the form itself and it will still crash if you subclass anything else and then click the Stop button. I guess only the form receives this "WM_UAHDESTROYWINDOW" message...

Quote:

---

Originally Posted by Dry Bone

I think you will find that using CreatePopupMenu and subsequent AppendMenuW much more simple and flexible (for variable amount of items, sub menus tree, formatting, etc), no subclassing is needed.

---

Yeah maybe so, but I prefer the menu editor already present in the IDE. It also allows for variable amount of items (via Load/Unload menu items) and submenus nesting as well as keyboard shortcuts and Click Events. Subclassing is really unavoidable for many serious applications so might as well use it.

Is it possible for shortcuts to appear, for example CTRL + S?

Yes, it is possible for shortcuts to "appear" as you put it, just select them in the IDE menu editor and they will show up in the PopupMenu. However these shortcuts only work "out of the box" for regular menus, not for PopupMenus. You would need to implement any actions separately, like I did in my RichEdit and MsftEdit lightweight Unicode Textbox project. Take a look at the PopupMenu implemented there along with its shortcuts.

1, can be packaged to support JSON format or add a menu with code.
addmenu("item1")
addline
addnenu("item3")
dim item4 as object,item5 as object
set item4=addnenu("item4")
addnenu("item4-1",checkboxType,item4)
addnenu("item4-2",checkboxType,item4)
set item5=addnenu("item5")
addnenu("item5-1",optionTYPE,item5)
addnenu("item5-2",optionTYPE,item5)
It would be nice if you could encapsulate it and not subclass it.

Why is this garbled?

Code:

---

Private Sub Form_Load()
Dim s As String
s = StreamOpenfile(App.Path & "\utf8-str.txt")
MsgBox s
End Sub

Function StreamOpenfile(File1 As String, Optional Decode As String = "_autodetect_all") As String
    'codeid=45
    On Error GoTo err
    Dim dr As Object  ' As New ADODB.Stream
    Set dr = CreateObject("Adodb.Stream")
    dr.Type = 2
    dr.Open
    dr.Charset = Decode
    dr.LoadFromFile File1
    StreamOpenfile = dr.ReadText
    dr.Close
    Set dr = Nothing
    Exit Function
err:
    Set dr = Nothing
    Debug.Print "Err-StreamOpenfile:" & err.Number & ","; err.Description
End Function

---

You need to provide the correct "Charset" parameter because "_autodetect_all" doesn't work all the time. Try "utf-8" instead.

Here's a helper function that provides various charsets for the ADODB.Stream object:

Code:

---

Public Enum CODE_PAGE_IDS
    CP_Autodetect_All = 50001
    CP_Unicode_UTF_16_LE = 1200
    CP_Unicode_UTF_8 = 65001
    CP_Windows_1250_ANSI_Central_European_Latin_2 = 1250
    CP_Windows_1251_ANSI_Cyrillic = 1251
    CP_Windows_1252_ANSI_Western_European_Latin_1 = 1252
    CP_Windows_1253_ANSI_Greek = 1253
    CP_Windows_1254_ANSI_Turkish = 1254
    CP_Windows_1255_ANSI_Hebrew = 1255
    CP_Windows_1256_ANSI_Arabic = 1256
    CP_Windows_1257_ANSI_Baltic = 1257
    CP_Windows_1258_ANSI_Vietnamese = 1258
End Enum

Private Function GetCharset(Optional eCodePage As CODE_PAGE_IDS = CP_Autodetect_All) As String
    Select Case eCodePage
        Case CP_Autodetect_All
            GetCharset = "_autodetect_all"
        Case CP_Unicode_UTF_16_LE
            GetCharset = "unicode"
        Case CP_Unicode_UTF_8
            GetCharset = "utf-8"
        Case Else
            GetCharset = "windows-" & eCodePage
    End Select
End Function

Public Sub ReadFile(sFileName As String, vData As Variant, Optional eCodePage As CODE_PAGE_IDS = CP_Autodetect_All)
Dim oStream As New ADODB.Stream, wVarType As Integer
    wVarType = VarType(vData)
    With oStream
        If wVarType = vbString Then ' Text
            .Charset = GetCharset(eCodePage): .Type = adTypeText: .Open: .LoadFromFile sFileName: vData = .ReadText: .Close
        Else
            .Type = adTypeBinary: .Open: .LoadFromFile sFileName
            Select Case wVarType
                Case vbArray Or vbByte ' Byte array
                    vData = .Read: .Close
                Case vbObject ' ADODB.Stream
                    Set vData = oStream
                Case vbDataObject ' IStream
                    Dim byteData() As Byte
                    ReDim byteData(0 To .Size - 1): byteData = .Read: Set vData = SHCreateMemStream(byteData(0), .Size): .Close
            End Select
        End If
    End With
End Sub

---

hello VanGoghGaming

SHCreateMemStream ——Display error at runtime: subroutine or function not defined

Haha, at first I thought what were you talking about since I didn't use any streams in this "Unicode PopupMenu" project, but then I see you were referring to my generic "ReadFile" function posted above that can indeed read a file into an "IStream" object if that's really what you want (or you can safely remove that line from the code above since it's unlikely you'll ever need it)...

This is the definition of "SHCreateMemStream":

Code:

---

Private Declare Function SHCreateMemStream Lib "shlwapi" Alias "#12" (pInit As Any, ByVal cbInit As Long) As IUnknown

---

While we are on this subject, here's a better version that doesn't use "SHCreateMemStream" at all since the "IStream" object can be derived from the "ADODB.Stream" object that we are already using in this function:

Code:

---

Private Declare Function vbaCastObj Lib "msvbvm60" Alias "__vbaCastObj" (ByVal srcObject As Long, ByVal lpIID As Long) As Long
Private Declare Function vbaObjSet Lib "msvbvm60" Alias "__vbaObjSet" (ByVal dstObject As Long, ByVal srcObject As Long) As Long
Private Declare Function vbaObjSetAddref Lib "msvbvm60" Alias "__vbaObjSetAddref" (ByVal dstObject As Long, ByVal srcObject As Long) As Long

Public Enum CODE_PAGE_IDS
    CP_Autodetect_All = 50001
    CP_Unicode_UTF_16_LE = 1200
    CP_Unicode_UTF_8 = 65001
    CP_Windows_1250_ANSI_Central_European_Latin_2 = 1250
    CP_Windows_1251_ANSI_Cyrillic = 1251
    CP_Windows_1252_ANSI_Western_European_Latin_1 = 1252
    CP_Windows_1253_ANSI_Greek = 1253
    CP_Windows_1254_ANSI_Turkish = 1254
    CP_Windows_1255_ANSI_Hebrew = 1255
    CP_Windows_1256_ANSI_Arabic = 1256
    CP_Windows_1257_ANSI_Baltic = 1257
    CP_Windows_1258_ANSI_Vietnamese = 1258
End Enum

Private Function GetCharset(Optional eCodePage As CODE_PAGE_IDS = CP_Autodetect_All) As String
    Select Case eCodePage
        Case CP_Autodetect_All
            GetCharset = "_autodetect_all"
        Case CP_Unicode_UTF_16_LE
            GetCharset = "unicode"
        Case CP_Unicode_UTF_8
            GetCharset = "utf-8"
        Case Else
            GetCharset = "windows-" & eCodePage
    End Select
End Function

Public Function PtrToObj(lpObject As Long, Optional lQueryInterfaceIID As Long) As IUnknown
    If lQueryInterfaceIID Then vbaObjSet VarPtr(PtrToObj), vbaCastObj(lpObject, lQueryInterfaceIID) Else vbaObjSetAddref VarPtr(PtrToObj), lpObject
End Function

Public Sub ReadFile(sFileName As String, vData As Variant, Optional eCodePage As CODE_PAGE_IDS = CP_Autodetect_All)
Dim oStream As ADODB.Stream, wVarType As Integer, IID_IInterface(0 To 1) As Currency
Const IID_IStream0 As Currency = 0.0012@, IID_IStream1 As Currency = 504403158265495.5712@
    Set oStream = New ADODB.Stream: wVarType = VarType(vData)
    With oStream
        If wVarType = vbString Then ' Text
            .Charset = GetCharset(eCodePage): .Type = adTypeText: .Open: .LoadFromFile sFileName: vData = .ReadText: .Close
        Else
            .Type = adTypeBinary: .Open: .LoadFromFile sFileName
            Select Case wVarType
                Case vbArray Or vbByte ' Byte array
                    vData = .Read: .Close
                Case vbObject ' ADODB.Stream
                    Set vData = oStream
                Case vbDataObject ' IStream
                    IID_IInterface(0) = IID_IStream0: IID_IInterface(1) = IID_IStream1
                    Set vData = PtrToObj(ObjPtr(oStream), VarPtr(IID_IInterface(0)))
            End Select
        End If
    End With
End Sub

---

Quote:

---

Originally Posted by Dry Bone

I think you will find that using CreatePopupMenu and subsequent AppendMenuW much more simple and flexible (for variable amount of items, sub menus tree, formatting, etc), no subclassing is needed.

---

No subclassing is needed you say? How does one respond to menu item clicks on API created menus without subclassing?

Exclusively in the case of Popup Menus you would use the TrackPopupMenu API function that blocks execution until a selection has been made and then returns the menu item selected by the user.

I still prefer the VB6 menu editor though, just out of convenience.

Subclassing is a non-issue here since it's immediately disabled as soon as the user makes a selection from the Popup Menu.

Furthermore, have you seen my Simplest IDE-Safe Subclassing thread? No reason not to try it since it's completely crash-proof.