From fbc1e6eff50210ba5f9d10c06e5e1a6b11f8f6be Mon Sep 17 00:00:00 2001 From: Mike Date: Mon, 17 Jun 2024 15:49:51 -0600 Subject: [PATCH] Delete Sources directory --- Sources/About.tbform | 256 ------- Sources/About.twin | 25 - Sources/Converter.tbform | 799 ------------------- Sources/Converter.twin | 70 -- Sources/Extractor.tbform | 435 ----------- Sources/Extractor.twin | 64 -- Sources/FormProcessing.twin | 1389 ---------------------------------- Sources/ImageProcessing.twin | 93 --- Sources/JsonConverter.bas | 1128 --------------------------- Sources/ReadMe | 15 - Sources/dllRegistration.twin | 49 -- Sources/myAddIn.twin | 125 --- 12 files changed, 4448 deletions(-) delete mode 100644 Sources/About.tbform delete mode 100644 Sources/About.twin delete mode 100644 Sources/Converter.tbform delete mode 100644 Sources/Converter.twin delete mode 100644 Sources/Extractor.tbform delete mode 100644 Sources/Extractor.twin delete mode 100644 Sources/FormProcessing.twin delete mode 100644 Sources/ImageProcessing.twin delete mode 100644 Sources/JsonConverter.bas delete mode 100644 Sources/ReadMe delete mode 100644 Sources/dllRegistration.twin delete mode 100644 Sources/myAddIn.twin diff --git a/Sources/About.tbform b/Sources/About.tbform deleted file mode 100644 index 492115b..0000000 --- a/Sources/About.tbform +++ /dev/null @@ -1,256 +0,0 @@ -[ - { - "AlwaysShowKeyboardCues": false, - "Appearance": "vbAppear3d", - "AutoRedraw": false, - "BackColor": -2147483633, - "BorderStyle": "vbFixedSingle", - "Caption": "About tBUserFormConverter", - "ClipControls": true, - "ControlBox": true, - "DrawMode": "vbCopyPen", - "DrawStyle": "vbSolid", - "DrawWidth": 1, - "Enabled": true, - "FillColor": 0, - "FillStyle": "vbFSTransparent", - "FontBold": false, - "FontItalic": false, - "FontName": "Segoe UI", - "FontSize": 8, - "FontStrikethru": false, - "FontTransparent": true, - "FontUnderline": false, - "ForeColor": -2147483630, - "FormDesignerId": "{AD8254FE-96CD-45BA-9FFC-44D12AFE5BBB}", - "HasDC": true, - "Height": 152, - "HelpContextID": 0, - "Icon": "", - "Index": -1, - "KeyPreview": false, - "Left": 0, - "LinkMode": "vbLinkNone", - "LinkTopic": null, - "MDIChild": false, - "MaxButton": false, - "MaxHeight": 0, - "MaxWidth": 0, - "MinButton": false, - "MinHeight": 0, - "MinWidth": 0, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Moveable": true, - "Name": "About", - "NegotiateMenus": false, - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Palette": "", - "PaletteMode": "vbPaletteModeHalftone", - "Picture": "", - "PictureDpiScaling": true, - "RightToLeft": false, - "ScaleHeight": 2280, - "ScaleLeft": 0, - "ScaleMode": "vbTwips", - "ScaleTop": 0, - "ScaleWidth": 4680, - "ShowInTaskbar": true, - "StartUpPosition": "vbStartUpScreen", - "TabFocusAutoSelect": false, - "Tag": null, - "Top": 0, - "TopMost": false, - "TransparencyKey": -1, - "Visible": true, - "WhatsThisButton": false, - "WhatsThisHelp": false, - "Width": 312, - "WindowState": "vbNormal", - "__IDEOptions": { - "alignToGrid": false, - "gridHeight": 10, - "gridWidth": 10, - "lockedControls": [], - "multiColoredGrabbers": false, - "showGrid": true, - "showOutlines": false - }, - "__lastUpdateMarker": 621404605, - "_children": [ - { - "Alignment": "vbLeftJustify", - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "AutoSize": false, - "BackColor": -2147483633, - "BackStyle": "vbBFOpaque", - "BorderStyle": "vbNoBorder", - "Caption": "Info Label", - "DataField": null, - "DataFormat": null, - "DataMember": null, - "DataSource": null, - "Dock": "vbDockNone", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Segoe UI", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 68, - "Index": -1, - "Left": 13, - "LinkItem": null, - "LinkMode": "vbLinkNone", - "LinkTimeout": 50, - "LinkTopic": null, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "lblInfo", - "OLEDropMode": "vbOLEDropNone", - "RightToLeft": false, - "TabIndex": 1, - "Tag": null, - "ToolTipText": null, - "Top": 18, - "UseMnemonic": true, - "Visible": true, - "WhatsThisHelpID": 0, - "Width": 273, - "WordWrap": true, - "_className": "Label", - "_clsid": "{33AD4ED8-6699-11CF-B70C-00AA0060D393}", - "_paintedByParent": true - }, - { - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483633, - "Cancel": false, - "Caption": "Dismiss", - "CausesValidation": true, - "Default": false, - "DisabledPicture": "", - "Dock": "vbDockNone", - "DownPicture": "", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Segoe UI", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 26, - "HelpContextID": 0, - "Index": -1, - "Left": 210, - "MaskColor": 12632256, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "cmdOK", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Padding": 2, - "Picture": "", - "PictureAlignment": "vbAlignTop", - "PictureDpiScaling": false, - "RightToLeft": false, - "Style": "vbButtonStandard", - "TabIndex": 2, - "TabStop": true, - "Tag": null, - "ToolTipText": null, - "Top": 118, - "TransparencyKey": -1, - "UseMaskColor": false, - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "Width": 89, - "_className": "CommandButton", - "_clsid": "{33AD4EF0-6699-11CF-B70C-00AA0060D393}" - }, - { - "Alignment": "vbLeftJustify", - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "AutoSize": false, - "BackColor": -2147483633, - "BackStyle": "vbBFOpaque", - "BorderStyle": "vbNoBorder", - "Caption": "Website Label", - "DataField": null, - "DataFormat": null, - "DataMember": null, - "DataSource": null, - "Dock": "vbDockNone", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Segoe UI", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 18, - "Index": -1, - "Left": 14, - "LinkItem": null, - "LinkMode": "vbLinkNone", - "LinkTimeout": 50, - "LinkTopic": null, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "lblWebsite", - "OLEDropMode": "vbOLEDropNone", - "RightToLeft": false, - "TabIndex": 3, - "Tag": null, - "ToolTipText": null, - "Top": 92, - "UseMnemonic": true, - "Visible": true, - "WhatsThisHelpID": 0, - "Width": 287, - "WordWrap": false, - "_className": "Label", - "_clsid": "{33AD4ED8-6699-11CF-B70C-00AA0060D393}", - "_paintedByParent": true - } - ], - "_className": "Form", - "_clsid": "{33AD4F38-6699-11CF-B70C-00AA0060D393}" - } -] \ No newline at end of file diff --git a/Sources/About.twin b/Sources/About.twin deleted file mode 100644 index bf99d39..0000000 --- a/Sources/About.twin +++ /dev/null @@ -1,25 +0,0 @@ -[Description("")] -[FormDesignerId("AD8254FE-96CD-45BA-9FFC-44D12AFE5BBB")] -[PredeclaredId] -Class About - - Sub New() - lblInfo.Caption = "Author: GCUser99" & vbCrLf & _ - "Version: " & App.Major & "." & App.Minor & vbCrLf & _ - "Description: A VBIDE add-in (complied with twinBASIC) that converts VBA UserForms for use in twinBASIC." - lblWebsite.Caption = "https://github.com/GCuser99/VBA-UserForm-to-twinBASIC" - Set Me.Icon = Global.LoadResPicture("About_32.ico", vbResIcon) - End Sub - - Private Sub cmdOK_Click() - Me.Close - End Sub - - Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) - If UnloadMode = vbFormControlMenu Then - Cancel = True - Me.Close - End If - End Sub - -End Class \ No newline at end of file diff --git a/Sources/Converter.tbform b/Sources/Converter.tbform deleted file mode 100644 index 7554b24..0000000 --- a/Sources/Converter.tbform +++ /dev/null @@ -1,799 +0,0 @@ -[ - { - "AlwaysShowKeyboardCues": false, - "Appearance": "vbAppear3d", - "AutoRedraw": false, - "BackColor": -2147483633, - "BorderStyle": "vbFixedSingle", - "Caption": "UserForm Converter", - "ClipControls": true, - "ControlBox": true, - "DrawMode": "vbCopyPen", - "DrawStyle": "vbSolid", - "DrawWidth": 1, - "Enabled": true, - "FillColor": 0, - "FillStyle": "vbFSTransparent", - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontTransparent": true, - "FontUnderline": false, - "ForeColor": -2147483630, - "FormDesignerId": "{BCA94248-FB88-D34B-AE3D-E887439ECECF}", - "HasDC": true, - "Height": 370, - "HelpContextID": 0, - "Icon": "", - "Index": -1, - "KeyPreview": false, - "Left": 0, - "LinkMode": "vbLinkNone", - "LinkTopic": null, - "MDIChild": false, - "MaxButton": false, - "MaxHeight": 0, - "MaxWidth": 0, - "MinButton": false, - "MinHeight": 0, - "MinWidth": 0, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Moveable": true, - "Name": "Converter", - "NegotiateMenus": false, - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Palette": "", - "PaletteMode": "vbPaletteModeHalftone", - "Picture": "", - "PictureDpiScaling": true, - "RightToLeft": false, - "ScaleHeight": 5550, - "ScaleLeft": 0, - "ScaleMode": "vbTwips", - "ScaleTop": 0, - "ScaleWidth": 4375.00000000001, - "ShowInTaskbar": true, - "StartUpPosition": "vbStartUpScreen", - "TabFocusAutoSelect": false, - "Tag": null, - "Top": 0, - "TopMost": false, - "TransparencyKey": -1, - "Visible": true, - "WhatsThisButton": false, - "WhatsThisHelp": false, - "Width": 291.666666666667, - "WindowState": "vbNormal", - "__IDEOptions": { - "alignToGrid": false, - "gridHeight": 10, - "gridWidth": 10, - "lockedControls": [], - "multiColoredGrabbers": false, - "showGrid": true, - "showOutlines": false - }, - "__lastUpdateMarker": 4163898559, - "_children": [ - { - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483643, - "BorderStyle": "vbFixedSingleBorder", - "CausesValidation": true, - "Columns": 0, - "DataField": null, - "DataFormat": null, - "DataMember": null, - "DataSource": null, - "Dock": "vbDockNone", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483640, - "Height": 110.733337402344, - "HelpContextID": 0, - "Index": -1, - "IntegralHeight": true, - "ItemData": [], - "Left": 24, - "List": [], - "MaxCheckboxSize": 15, - "MouseIcon": "", - "MousePointer": "vbDefault", - "MultiSelect": "vbMultiSelectExtended", - "Name": "lbxDialogs", - "OLEDragMode": "vbOLEDragManual", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "RightToLeft": false, - "Sorted": false, - "Style": "vbListBoxStandard", - "TabIndex": 0, - "TabStop": true, - "Tag": "", - "ToolTipText": null, - "Top": 32, - "TransparencyKey": -1, - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "WheelScrollEvent": true, - "Width": 245.266662597656, - "_className": "ListBox", - "_clsid": "{33AD4F10-6699-11CF-B70C-00AA0060D393}" - }, - { - "Alignment": "vbLeftJustify", - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "AutoSize": false, - "BackColor": -2147483633, - "BackStyle": "vbBFOpaque", - "BorderStyle": "vbNoBorder", - "Caption": "Select UserForm(s) to Convert to tB Form(s):", - "DataField": null, - "DataFormat": null, - "DataMember": null, - "DataSource": null, - "Dock": "vbDockNone", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 16, - "Index": -1, - "Left": 24, - "LinkItem": null, - "LinkMode": "vbLinkNone", - "LinkTimeout": 50, - "LinkTopic": null, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "Label1", - "OLEDropMode": "vbOLEDropNone", - "RightToLeft": false, - "TabIndex": 2, - "Tag": "", - "ToolTipText": null, - "Top": 16, - "UseMnemonic": true, - "Visible": true, - "WhatsThisHelpID": 0, - "Width": 216, - "WordWrap": false, - "_className": "Label", - "_clsid": "{33AD4ED8-6699-11CF-B70C-00AA0060D393}", - "_paintedByParent": true - }, - { - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483633, - "Cancel": false, - "Caption": "Convert", - "CausesValidation": true, - "Default": false, - "DisabledPicture": "", - "Dock": "vbDockNone", - "DownPicture": "", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 24, - "HelpContextID": 0, - "Index": -1, - "Left": 181, - "MaskColor": 12632256, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "cmdConvert", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Padding": 2, - "Picture": "", - "PictureAlignment": "vbAlignTop", - "PictureDpiScaling": false, - "RightToLeft": false, - "Style": "vbButtonStandard", - "TabIndex": 3, - "TabStop": true, - "Tag": "", - "ToolTipText": null, - "Top": 335, - "TransparencyKey": -1, - "UseMaskColor": false, - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "Width": 88, - "_className": "CommandButton", - "_clsid": "{33AD4EF0-6699-11CF-B70C-00AA0060D393}" - }, - { - "Alignment": "tbLeftJustify", - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483633, - "Caption": "Use VBA UserForm Font Properties", - "CausesValidation": true, - "DisabledPicture": "", - "Dock": "vbDockNone", - "DownPicture": "", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 24, - "HelpContextID": 0, - "Index": -1, - "Left": 27, - "MaskColor": 12632256, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "optUseVBAFonts", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Padding": 2, - "Picture": "", - "PictureAlignment": "vbAlignTop", - "PictureDpiScaling": false, - "RightToLeft": false, - "Style": "vbButtonStandard", - "TabIndex": 3, - "TabStop": true, - "Tag": "", - "ToolTipText": null, - "Top": 178, - "TransparencyKey": -1, - "UseMaskColor": false, - "Value": true, - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "Width": 208, - "_className": "OptionButton", - "_clsid": "{33AD4F00-6699-11CF-B70C-00AA0060D393}" - }, - { - "Alignment": "tbLeftJustify", - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483633, - "Caption": "Use Default tB Form Font Properties", - "CausesValidation": true, - "DisabledPicture": "", - "Dock": "vbDockNone", - "DownPicture": "", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 24, - "HelpContextID": 0, - "Index": -1, - "Left": 27, - "MaskColor": 12632256, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "optUsetBFonts", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Padding": 2, - "Picture": "", - "PictureAlignment": "vbAlignTop", - "PictureDpiScaling": false, - "RightToLeft": false, - "Style": "vbButtonStandard", - "TabIndex": 4, - "TabStop": true, - "Tag": "", - "ToolTipText": null, - "Top": 201, - "TransparencyKey": -1, - "UseMaskColor": false, - "Value": false, - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "Width": 215.666666666667, - "_className": "OptionButton", - "_clsid": "{33AD4F00-6699-11CF-B70C-00AA0060D393}" - }, - { - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483633, - "Cancel": true, - "Caption": "Cancel", - "CausesValidation": true, - "Default": false, - "DisabledPicture": "", - "Dock": "vbDockNone", - "DownPicture": "", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 24, - "HelpContextID": 0, - "Index": -1, - "Left": 88, - "MaskColor": 12632256, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "cmdCancel", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Padding": 2, - "Picture": "", - "PictureAlignment": "vbAlignTop", - "PictureDpiScaling": false, - "RightToLeft": false, - "Style": "vbButtonStandard", - "TabIndex": 9, - "TabStop": true, - "Tag": "", - "ToolTipText": null, - "Top": 336, - "TransparencyKey": -1, - "UseMaskColor": false, - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "Width": 80, - "_className": "CommandButton", - "_clsid": "{33AD4EF0-6699-11CF-B70C-00AA0060D393}" - }, - { - "Alignment": "tbLeftJustify", - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483633, - "Caption": "Translate UserForm(s) Code to .twin File(s) ", - "CausesValidation": true, - "DataField": null, - "DataFormat": null, - "DataMember": null, - "DataSource": null, - "DisabledPicture": "", - "Dock": "vbDockNone", - "DownPicture": "", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 20, - "HelpContextID": 0, - "Index": -1, - "Left": 27, - "MaskColor": 12632256, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "ckbOutputCode", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Padding": 2, - "Picture": "", - "PictureAlignment": "vbAlignTop", - "PictureDpiScaling": false, - "RightToLeft": false, - "Style": "vbButtonStandard", - "TabIndex": 7, - "TabStop": true, - "Tag": "", - "ToolTipText": "Well, kinda translate - this will hopefully get the simple stuff...", - "Top": 285, - "TransparencyKey": -1, - "UseMaskColor": false, - "Value": "vbUnchecked", - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "Width": 241.333333333333, - "_className": "CheckBox", - "_clsid": "{33AD4EF8-6699-11CF-B70C-00AA0060D393}" - }, - { - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483633, - "Cancel": false, - "Caption": "Select All", - "CausesValidation": true, - "Default": false, - "DisabledPicture": "", - "Dock": "vbDockNone", - "DownPicture": "", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 24, - "HelpContextID": 0, - "Index": -1, - "Left": 62, - "MaskColor": 12632256, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "cmdSelectAll", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Padding": 2, - "Picture": "", - "PictureAlignment": "vbAlignTop", - "PictureDpiScaling": false, - "RightToLeft": false, - "Style": "vbButtonStandard", - "TabIndex": 1, - "TabStop": true, - "Tag": "", - "ToolTipText": null, - "Top": 144, - "TransparencyKey": -1, - "UseMaskColor": false, - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "Width": 80, - "_className": "CommandButton", - "_clsid": "{33AD4EF0-6699-11CF-B70C-00AA0060D393}" - }, - { - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483633, - "Cancel": false, - "Caption": "Deselect All", - "CausesValidation": true, - "Default": false, - "DisabledPicture": "", - "Dock": "vbDockNone", - "DownPicture": "", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 24, - "HelpContextID": 0, - "Index": -1, - "Left": 152, - "MaskColor": 12632256, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "cmdDeselectAll", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Padding": 2, - "Picture": "", - "PictureAlignment": "vbAlignTop", - "PictureDpiScaling": false, - "RightToLeft": false, - "Style": "vbButtonStandard", - "TabIndex": 2, - "TabStop": true, - "Tag": "", - "ToolTipText": null, - "Top": 144, - "TransparencyKey": -1, - "UseMaskColor": false, - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "Width": 80, - "_className": "CommandButton", - "_clsid": "{33AD4EF0-6699-11CF-B70C-00AA0060D393}" - }, - { - "Alignment": "tbLeftJustify", - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483633, - "Caption": "Set Visual Styles for All Controls", - "CausesValidation": true, - "DataField": null, - "DataFormat": null, - "DataMember": null, - "DataSource": null, - "DisabledPicture": "", - "Dock": "vbDockNone", - "DownPicture": "", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 20, - "HelpContextID": 0, - "Index": -1, - "Left": 27, - "MaskColor": 12632256, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "ckbUseVisualStyles", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Padding": 2, - "Picture": "", - "PictureAlignment": "vbAlignTop", - "PictureDpiScaling": false, - "RightToLeft": false, - "Style": "vbButtonStandard", - "TabIndex": 5, - "TabStop": true, - "Tag": null, - "ToolTipText": null, - "Top": 232, - "TransparencyKey": -1, - "UseMaskColor": false, - "Value": "vbUnchecked", - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "Width": 230, - "_className": "CheckBox", - "_clsid": "{33AD4EF8-6699-11CF-B70C-00AA0060D393}" - }, - { - "Alignment": "tbLeftJustify", - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483633, - "Caption": "Set 3D Appearance for All Controls", - "CausesValidation": true, - "DataField": null, - "DataFormat": null, - "DataMember": null, - "DataSource": null, - "DisabledPicture": "", - "Dock": "vbDockNone", - "DownPicture": "", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 20, - "HelpContextID": 0, - "Index": -1, - "Left": 27, - "MaskColor": 12632256, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "ckb3DAppearance", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Padding": 2, - "Picture": "", - "PictureAlignment": "vbAlignTop", - "PictureDpiScaling": false, - "RightToLeft": false, - "Style": "vbButtonStandard", - "TabIndex": 6, - "TabStop": true, - "Tag": null, - "ToolTipText": null, - "Top": 261, - "TransparencyKey": -1, - "UseMaskColor": false, - "Value": "vbUnchecked", - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "Width": 230, - "_className": "CheckBox", - "_clsid": "{33AD4EF8-6699-11CF-B70C-00AA0060D393}" - }, - { - "Alignment": "tbLeftJustify", - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483633, - "Caption": "Hide Icon Box on Title Bar", - "CausesValidation": true, - "DataField": null, - "DataFormat": null, - "DataMember": null, - "DataSource": null, - "DisabledPicture": "", - "Dock": "vbDockNone", - "DownPicture": "", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 20, - "HelpContextID": 0, - "Index": -1, - "Left": 27, - "MaskColor": 12632256, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "ckbHideIconBox", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Padding": 2, - "Picture": "", - "PictureAlignment": "vbAlignTop", - "PictureDpiScaling": false, - "RightToLeft": false, - "Style": "vbButtonStandard", - "TabIndex": 8, - "TabStop": true, - "Tag": null, - "ToolTipText": null, - "Top": 309, - "TransparencyKey": -1, - "UseMaskColor": false, - "Value": "vbUnchecked", - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "Width": 225, - "_className": "CheckBox", - "_clsid": "{33AD4EF8-6699-11CF-B70C-00AA0060D393}" - } - ], - "_className": "Form", - "_clsid": "{33AD4F38-6699-11CF-B70C-00AA0060D393}" - } -] \ No newline at end of file diff --git a/Sources/Converter.twin b/Sources/Converter.twin deleted file mode 100644 index 557c678..0000000 --- a/Sources/Converter.twin +++ /dev/null @@ -1,70 +0,0 @@ -[Description("")] -[FormDesignerId("BCA94248-FB88-D34B-AE3D-E887439ECECF")] -[PredeclaredId] - -Class Converter - - Private mCancelPressed As Boolean - Private mUserFormSelected As Boolean - - Public Property Get CancelPressed() As Boolean - CancelPressed = mCancelPressed - End Property - - Private Sub cmdConvert_Click() - Me.Hide - End Sub - - Private Sub cmdCancel_Click() - mCancelPressed = True - Me.Hide - End Sub - - Private Sub cmdDeselectAll_Click() - Dim i As Long - For i = 0 To Me.lbxDialogs.ListCount - 1 - Me.lbxDialogs.Selected(i) = False - Next i - cmdConvert.Enabled = False - cmdDeselectAll.Enabled = False - End Sub - - Private Sub cmdSelectAll_Click() - Dim i As Long - For i = 0 To Me.lbxDialogs.ListCount - 1 - Me.lbxDialogs.Selected(i) = True - Next i - End Sub - - Private Sub lbxDialogs_Click() - mUserFormSelected = True - If Me.lbxDialogs.ListCount > 0 Then - cmdConvert.Enabled = True - cmdDeselectAll.Enabled = True - Else - cmdConvert.Enabled = False - cmdDeselectAll.Enabled = False - End If - End Sub - - Private Sub New() - cmdConvert.Enabled = False - ckbOutputCode.Value = vbChecked - cmdDeselectAll.Enabled = False - ckbUseVisualStyles.Value = vbUnchecked - ckb3DAppearance.Value = vbChecked - optUseVBAFonts.Value = True - ckbHideIconBox.Value = vbChecked - 'Set Me.Icon = GetImageFromResources("twinBASIC.ico", "IMAGES") - Set Me.Icon = Global.LoadResPicture("ConvertForms_32.ico", vbResIcon) - End Sub - - Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) - If UnloadMode = vbFormControlMenu Then - mCancelPressed = True - Cancel = True - Me.Hide - End If - End Sub - -End Class diff --git a/Sources/Extractor.tbform b/Sources/Extractor.tbform deleted file mode 100644 index 572a4f6..0000000 --- a/Sources/Extractor.tbform +++ /dev/null @@ -1,435 +0,0 @@ -[ - { - "AlwaysShowKeyboardCues": false, - "Appearance": "vbAppear3d", - "AutoRedraw": false, - "BackColor": -2147483633, - "BorderStyle": "vbFixedSingle", - "Caption": "Extract UserForm Image Resources", - "ClipControls": true, - "ControlBox": true, - "DrawMode": "vbCopyPen", - "DrawStyle": "vbSolid", - "DrawWidth": 1, - "Enabled": true, - "FillColor": 0, - "FillStyle": "vbFSTransparent", - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontTransparent": true, - "FontUnderline": false, - "ForeColor": -2147483630, - "FormDesignerId": "{F81F4A88-531A-4DB5-BB8C-1414C82FBF25}", - "HasDC": true, - "Height": 219, - "HelpContextID": 0, - "Icon": "", - "Index": -1, - "KeyPreview": false, - "Left": 0, - "LinkMode": "vbLinkNone", - "LinkTopic": null, - "MDIChild": false, - "MaxButton": false, - "MaxHeight": 0, - "MaxWidth": 0, - "MinButton": false, - "MinHeight": 0, - "MinWidth": 0, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Moveable": true, - "Name": "Extractor", - "NegotiateMenus": false, - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Palette": "", - "PaletteMode": "vbPaletteModeHalftone", - "Picture": "", - "PictureDpiScaling": true, - "RightToLeft": false, - "ScaleHeight": 3285, - "ScaleLeft": 0, - "ScaleMode": "vbTwips", - "ScaleTop": 0, - "ScaleWidth": 4375.00000000001, - "ShowInTaskbar": true, - "StartUpPosition": "vbStartUpScreen", - "TabFocusAutoSelect": false, - "Tag": null, - "Top": 0, - "TopMost": false, - "TransparencyKey": -1, - "Visible": true, - "WhatsThisButton": false, - "WhatsThisHelp": false, - "Width": 291.666666666667, - "WindowState": "vbNormal", - "__IDEOptions": { - "alignToGrid": false, - "gridHeight": 10, - "gridWidth": 10, - "lockedControls": [], - "multiColoredGrabbers": false, - "showGrid": true, - "showOutlines": false - }, - "__lastUpdateMarker": 2677943343, - "_children": [ - { - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483643, - "BorderStyle": "vbFixedSingleBorder", - "CausesValidation": true, - "Columns": 0, - "DataField": null, - "DataFormat": null, - "DataMember": null, - "DataSource": null, - "Dock": "vbDockNone", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483640, - "Height": 110.733337402344, - "HelpContextID": 0, - "Index": -1, - "IntegralHeight": true, - "ItemData": [], - "Left": 24, - "List": [], - "MaxCheckboxSize": 15, - "MouseIcon": "", - "MousePointer": "vbDefault", - "MultiSelect": "vbMultiSelectExtended", - "Name": "lbxDialogs", - "OLEDragMode": "vbOLEDragManual", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "RightToLeft": false, - "Sorted": false, - "Style": "vbListBoxStandard", - "TabIndex": 0, - "TabStop": true, - "Tag": "", - "ToolTipText": null, - "Top": 32, - "TransparencyKey": -1, - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "WheelScrollEvent": true, - "Width": 245.266662597656, - "_className": "ListBox", - "_clsid": "{33AD4F10-6699-11CF-B70C-00AA0060D393}" - }, - { - "Alignment": "vbLeftJustify", - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "AutoSize": false, - "BackColor": -2147483633, - "BackStyle": "vbBFOpaque", - "BorderStyle": "vbNoBorder", - "Caption": "Select UserForm(s) to Process:", - "DataField": null, - "DataFormat": null, - "DataMember": null, - "DataSource": null, - "Dock": "vbDockNone", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 16, - "Index": -1, - "Left": 24, - "LinkItem": null, - "LinkMode": "vbLinkNone", - "LinkTimeout": 50, - "LinkTopic": null, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "Label1", - "OLEDropMode": "vbOLEDropNone", - "RightToLeft": false, - "TabIndex": 2, - "Tag": "", - "ToolTipText": null, - "Top": 16, - "UseMnemonic": true, - "Visible": true, - "WhatsThisHelpID": 0, - "Width": 216, - "WordWrap": false, - "_className": "Label", - "_clsid": "{33AD4ED8-6699-11CF-B70C-00AA0060D393}", - "_paintedByParent": true - }, - { - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483633, - "Cancel": false, - "Caption": "Extract", - "CausesValidation": true, - "Default": false, - "DisabledPicture": "", - "Dock": "vbDockNone", - "DownPicture": "", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 24, - "HelpContextID": 0, - "Index": -1, - "Left": 181, - "MaskColor": 12632256, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "cmdExtract", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Padding": 2, - "Picture": "", - "PictureAlignment": "vbAlignTop", - "PictureDpiScaling": false, - "RightToLeft": false, - "Style": "vbButtonStandard", - "TabIndex": 3, - "TabStop": true, - "Tag": "", - "ToolTipText": null, - "Top": 180, - "TransparencyKey": -1, - "UseMaskColor": false, - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "Width": 88, - "_className": "CommandButton", - "_clsid": "{33AD4EF0-6699-11CF-B70C-00AA0060D393}" - }, - { - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483633, - "Cancel": true, - "Caption": "Cancel", - "CausesValidation": true, - "Default": false, - "DisabledPicture": "", - "Dock": "vbDockNone", - "DownPicture": "", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 24, - "HelpContextID": 0, - "Index": -1, - "Left": 92, - "MaskColor": 12632256, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "cmdCancel", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Padding": 2, - "Picture": "", - "PictureAlignment": "vbAlignTop", - "PictureDpiScaling": false, - "RightToLeft": false, - "Style": "vbButtonStandard", - "TabIndex": 3, - "TabStop": true, - "Tag": "", - "ToolTipText": null, - "Top": 180, - "TransparencyKey": -1, - "UseMaskColor": false, - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "Width": 80, - "_className": "CommandButton", - "_clsid": "{33AD4EF0-6699-11CF-B70C-00AA0060D393}" - }, - { - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483633, - "Cancel": false, - "Caption": "Select All", - "CausesValidation": true, - "Default": false, - "DisabledPicture": "", - "Dock": "vbDockNone", - "DownPicture": "", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 24, - "HelpContextID": 0, - "Index": -1, - "Left": 62, - "MaskColor": 12632256, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "cmdSelectAll", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Padding": 2, - "Picture": "", - "PictureAlignment": "vbAlignTop", - "PictureDpiScaling": false, - "RightToLeft": false, - "Style": "vbButtonStandard", - "TabIndex": 1, - "TabStop": true, - "Tag": "", - "ToolTipText": null, - "Top": 144, - "TransparencyKey": -1, - "UseMaskColor": false, - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "Width": 80, - "_className": "CommandButton", - "_clsid": "{33AD4EF0-6699-11CF-B70C-00AA0060D393}" - }, - { - "Anchors": { - "Bottom": false, - "Left": true, - "Right": false, - "Top": true, - "_className": "Anchors", - "_clsid": "{8524D4B5-72A9-40A9-A189-29E7905C40CA}" - }, - "Appearance": "vbAppear3d", - "BackColor": -2147483633, - "Cancel": false, - "Caption": "Deselect All", - "CausesValidation": true, - "Default": false, - "DisabledPicture": "", - "Dock": "vbDockNone", - "DownPicture": "", - "DragIcon": "", - "DragMode": "vbManual", - "Enabled": true, - "FontBold": false, - "FontItalic": false, - "FontName": "Tahoma", - "FontSize": 8, - "FontStrikethru": false, - "FontUnderline": false, - "ForeColor": -2147483630, - "Height": 24, - "HelpContextID": 0, - "Index": -1, - "Left": 152, - "MaskColor": 12632256, - "MouseIcon": "", - "MousePointer": "vbDefault", - "Name": "cmdDeselectAll", - "OLEDropMode": "vbOLEDropNone", - "Opacity": 100, - "Padding": 2, - "Picture": "", - "PictureAlignment": "vbAlignTop", - "PictureDpiScaling": false, - "RightToLeft": false, - "Style": "vbButtonStandard", - "TabIndex": 2, - "TabStop": true, - "Tag": "", - "ToolTipText": null, - "Top": 144, - "TransparencyKey": -1, - "UseMaskColor": false, - "Visible": true, - "VisualStyles": true, - "WhatsThisHelpID": 0, - "Width": 80, - "_className": "CommandButton", - "_clsid": "{33AD4EF0-6699-11CF-B70C-00AA0060D393}" - } - ], - "_className": "Form", - "_clsid": "{33AD4F38-6699-11CF-B70C-00AA0060D393}" - } -] \ No newline at end of file diff --git a/Sources/Extractor.twin b/Sources/Extractor.twin deleted file mode 100644 index 7a9fc50..0000000 --- a/Sources/Extractor.twin +++ /dev/null @@ -1,64 +0,0 @@ -[Description("")] -[FormDesignerId("F81F4A88-531A-4DB5-BB8C-1414C82FBF25")] -[PredeclaredId] - -Class Extractor - - Private mCancelPressed As Boolean - Private mUserFormSelected As Boolean - - Public Property Get CancelPressed() As Boolean - CancelPressed = mCancelPressed - End Property - - Private Sub cmdExtract_Click() - Me.Hide - End Sub - - Private Sub cmdCancel_Click() - mCancelPressed = True - Me.Hide - End Sub - - Private Sub cmdDeselectAll_Click() - Dim i As Long - For i = 0 To Me.lbxDialogs.ListCount - 1 - Me.lbxDialogs.Selected(i) = False - Next i - cmdExtract.Enabled = False - cmdDeselectAll.Enabled = False - End Sub - - Private Sub cmdSelectAll_Click() - Dim i As Long - For i = 0 To Me.lbxDialogs.ListCount - 1 - Me.lbxDialogs.Selected(i) = True - Next i - End Sub - - Private Sub lbxDialogs_Click() - mUserFormSelected = True - If Me.lbxDialogs.ListCount > 0 Then - cmdExtract.Enabled = True - cmdDeselectAll.Enabled = True - Else - cmdExtract.Enabled = False - cmdDeselectAll.Enabled = False - End If - End Sub - - Private Sub New() - cmdExtract.Enabled = False - cmdDeselectAll.Enabled = False - Set Me.Icon = Global.LoadResPicture("ExtractResources_32.ico", vbResIcon) - End Sub - - Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) - If UnloadMode = vbFormControlMenu Then - mCancelPressed = True - Cancel = True - Me.Hide - End If - End Sub - -End Class diff --git a/Sources/FormProcessing.twin b/Sources/FormProcessing.twin deleted file mode 100644 index 19f7d14..0000000 --- a/Sources/FormProcessing.twin +++ /dev/null @@ -1,1389 +0,0 @@ -' ========================================================================== -' tBUserFormConverter v2.8 -' -' A VBIDE add-in (complied with twinBASIC) that converts VBA UserForms for use in twinBASIC. -' -' https://github.com/GCuser99/VBA-UserForm-to-twinBASIC -' -' Contact Info: -' -' https://github.com/GCUser99 -' ========================================================================== -' MIT License -' -' Copyright (c) 2023-2024, GCUser99 (https://github.com/GCuser99/VBA-UserForm-to-twinBASIC) -' -' Permission is hereby granted, free of charge, to any person obtaining a copy -' of this software and associated documentation files (the "Software"), to deal -' in the Software without restriction, including without limitation the rights -' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -' copies of the Software, and to permit persons to whom the Software is -' furnished to do so, subject to the following conditions: -' -' The above copyright notice and this permission notice shall be included in all -' copies or substantial portions of the Software. -' -' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -' SOFTWARE. -' ========================================================================== - -Module FormProcessing - - /* - Notes: - As of v544, all covered controls have Opacity except for Label and Image controls - */ - - '--------------------------------------------------------------------- - ' MS Forms Enums - '--------------------------------------------------------------------- - - Private Enum fmMousePointer - fmMousePointerDefault = 0 - fmMousePointerArrow = 1 - fmMousePointerCross = 2 - fmMousePointerIBeam = 3 - fmMousePointerSizeNESW = 6 - fmMousePointerSizeNS = 7 - fmMousePointerSizeNWSE = 8 - fmMousePointerSizeWE = 9 - fmMousePointerUpArrow = 10 - fmMousePointerHourGlass = 11 - fmMousePointerNoDrop = 12 - fmMousePointerAppStarting = 13 - fmMousePointerHelp = 14 - fmMousePointerSizeAll = 15 - fmMousePointerCustom = 99 - End Enum - - Private Enum fmScrollBars - fmScrollBarsNone = 0 - fmScrollBarsHorizontal = 1 - fmScrollBarsVertical = 2 - fmScrollBarsBoth = 3 - End Enum - - Private Enum fmBorderStyle - fmBorderStyleNone = 0 - fmBorderStyleSingle = 1 - End Enum - - Private Enum fmTextAlign - fmTextAlignLeft = 1 - fmTextAlignCenter = 2 - fmTextAlignRight = 3 - End Enum - - Private Enum fmBackStyle - fmBackStyleTransparent = 0 - fmBackStyleOpaque = 1 - End Enum - - Private Enum fmOrientation - fmOrientationAuto = -1 - fmOrientationVertical = 0 - fmOrientationHorizontal = 1 - End Enum - - Private Enum fmMultiSelect - fmMultiSelectSingle = 0 - fmMultiSelectMulti = 1 - fmMultiSelectExtended = 2 - End Enum - - Private Enum fmListStyle - fmListStylePlain = 0 - fmListStyleOption = 1 - End Enum - - Private Enum fmSpecialEffect - fmSpecialEffectFlat = 0 - fmSpecialEffectRaised = 1 - fmSpecialEffectSunken = 2 - fmSpecialEffectEtched = 3 - fmSpecialEffectBump = 6 - End Enum - - Private Enum fmStyle - fmStyleDropDownCombo = 0 - fmStyleDropDownList = 2 - End Enum - - '--------------------------------------------------------------------- - ' Public Forms Processing (called by Menu entries) - '--------------------------------------------------------------------- - - Public Sub ExportUserForm(activeVBProject As VBProject) - Dim ctl As Object - Dim json As String - Dim fso As New FileSystemObject - Dim ts As TextStream - Dim i As Long - Dim j As Long - Dim guid As String - Dim ptsToPixels As Double - Dim useVBAFont As Boolean - Dim savVBATrusted As Boolean - Dim useVisualStyles As Boolean - Dim use3DAppearance As Boolean - Dim dialogName As String - Dim outputCode As Boolean - Dim tBControlTypeName As String - Dim rootDoc As Collection - Dim tbControl As Dictionary - Dim tBForm As Dictionary - Dim sorted As Collection - Dim vbaControlTypeName As String - Dim userForm As VBComponent - Dim vbc As VBComponent - Dim dialogNames As New Collection - Dim idlg As Long - Dim checkBoxes As Collection - Dim textBoxes As Collection - Dim codelines As ArrayList - Dim codeline As String - Dim hideIconBox As Boolean - Dim saveImageResourcesToFile As Boolean - - 'Initialize the form - For Each vbc In activeVBProject.VBComponents - If vbc.Type = vbext_ct_MSForm Then Converter.lbxDialogs.AddItem vbc.Name - Next vbc - - 'show form to user - Converter.Show vbModal - If Converter.CancelPressed Then - Converter.Close - Set Converter = Nothing - Exit Sub - End If - - 'gather up the selected dialog names - For idlg = 0 To Converter.lbxDialogs.ListCount - 1 - If Converter.lbxDialogs.Selected(idlg) Then dialogNames.Add Converter.lbxDialogs.List(idlg) - Next idlg - - 'browse for output folder path - Dim filePath As String - Dim folderPath As String - Dim comdlg As New VBComDlg.CommonDialog - Dim res As Boolean - Dim activeVBProjectFileName As String - Dim activeVBProjectFolderName As String - - comdlg.DialogTitle = "Select Output Folder to Save Forms:" - - 'it's possible that user created a useform in a new unsaved document - 'in which case activeVBProject.FileName will fail - On Error Resume Next - activeVBProjectFileName = activeVBProject.FileName - If Err.Number <> 0 Then - activeVBProjectFolderName = CurDir() - Else - activeVBProjectFolderName = fso.GetParentFolderName(activeVBProjectFileName) - End If - On Error GoTo 0 - - On Error GoTo EH - - comdlg.InitDir = activeVBProjectFolderName - - res = comdlg.ShowFolderBrowser() - If Not res Then - MsgBox "No UserForms were converted.", , "Convert UserForm(s) to twinBASIC" - 'unload the form - Converter.Close - Set Converter = Nothing - Exit Sub - End If - folderPath = comdlg.FileName - - 'get other user-supplied parameters - useVBAFont = Converter.optUseVBAFonts.Value - outputCode = (Converter.ckbOutputCode.Value = vbChecked) - useVisualStyles = (Converter.ckbUseVisualStyles.Value = vbChecked) - use3DAppearance = (Converter.ckb3DAppearance.Value = vbChecked) - hideIconBox = (Converter.ckbHideIconBox.Value = vbChecked) - - 'unload the form - Converter.Close - Set Converter = Nothing - - 'conversion factor for going from UserForm pts to tb Form scaled pixels - '(96 pixels/logical inch)/(72 pts/logical inch) = scaled pixels for tb - ptsToPixels = 96# / 72# - - 'loop through and process each selected UserForm - For idlg = 1 To dialogNames.Count - - dialogName = dialogNames(idlg) - - Set userForm = activeVBProject.VBComponents(dialogName) - - 'generate GUID to be used for twinBASIC form designer and code module - guid = VBA.CreateGUID() - - 'sort controls in order of descendancy - must process parent controls first! - Set sorted = SortControls(userForm.Designer, dialogName) - - 'create the tB form dictionary from resources - Set tBForm = JsonConverter.ParseJson(ReadControlJson("Form")) - - 'set properties of tB form that have matching UserForm counterparts - ProcessForm userForm, tBForm, ptsToPixels, useVBAFont, use3DAppearance, guid, hideIconBox - - 'enumerate and process each UserForm control - For Each ctl In sorted - vbaControlTypeName = TypeName(ctl) - 'assign the matching tB control to the input UserForm control - If IsSupported(ctl) Then - Select Case vbaControlTypeName - Case "ScrollBar" - tBControlTypeName = tbScrollBarTypeName(ctl) - Case "SpinButton" - tBControlTypeName = "UpDown" - Case "ToggleButton" - tBControlTypeName = "CheckBox" - Case Else - tBControlTypeName = vbaControlTypeName - End Select - Else - If vbaControlTypeName = "MultiPage" Then - 'MultiPage can contain other controls, so use a Frame which can serve as a container - tBControlTypeName = "Frame" - Else - tBControlTypeName = "Label" - End If - vbaControlTypeName = "Unsupported" - End If - - 'create the tB control dictionary from a json string read from Resources - Set tbControl = JsonConverter.ParseJson(ReadControlJson(tBControlTypeName)) - - 'set properties of tB control that have matching UserForm control counterparts - Select Case vbaControlTypeName - Case "Label" - ProcessLabel ctl, tbControl, ptsToPixels, useVBAFont, use3DAppearance - Case "CommandButton" - ProcessCommandButton ctl, tbControl, ptsToPixels, useVBAFont, useVisualStyles, use3DAppearance - Case "TextBox" - ProcessTextBox ctl, tbControl, ptsToPixels, useVBAFont, useVisualStyles, use3DAppearance - Case "Frame" - ProcessFrame ctl, tbControl, ptsToPixels, useVBAFont, useVisualStyles, use3DAppearance - Case "CheckBox" - ProcessCheckBox ctl, tbControl, ptsToPixels, useVBAFont, useVisualStyles, use3DAppearance - Case "ComboBox" - ProcessComboBox ctl, tbControl, ptsToPixels, useVBAFont, useVisualStyles, use3DAppearance - Case "ListBox" - ProcessListBox ctl, tbControl, ptsToPixels, useVBAFont, useVisualStyles, use3DAppearance - Case "OptionButton" - ProcessOptionButton ctl, tbControl, ptsToPixels, useVBAFont, useVisualStyles, use3DAppearance - Case "ScrollBar" - ProcessScrollBar ctl, tbControl, ptsToPixels, useVisualStyles - Case "Image" - ProcessImage ctl, tbControl, ptsToPixels, use3DAppearance - Case "SpinButton" - ProcessSpinButton ctl, tbControl, ptsToPixels, useVisualStyles - Case "ToggleButton" - ProcessToggleButton ctl, tbControl, ptsToPixels, useVBAFont, useVisualStyles, use3DAppearance - Case Else 'Unsupported - ProcessUnsupported ctl, tbControl, ptsToPixels - End Select - 'add tB control dictionary to tB form dictionary - AddToParent tBForm, ctl, tbControl - Next ctl - - 'prepare for output to file - Set rootDoc = New Collection - rootDoc.Add tBForm - - filePath = folderPath & "\" & tBForm.Item("Name") & ".tbform" - If fso.FileExists(filePath) Then fso.DeleteFile filePath, True - Set ts = fso.CreateTextFile(filePath, False) - - 'write json string to file - ts.Write JsonConverter.ConvertToJson(rootDoc, 4) - ts.Close - - If outputCode Then - 'write the associated code file - Set codelines = New ArrayList(BaseIndex:=1) - - 'build Class header - codelines.Add "[ Description ("""") ]" - codelines.Add "[ FormDesignerId (""" & guid & """) ]" - codelines.Add "[ PredeclaredId ]" - codelines.Add "" - codelines.Add "Class " & dialogName - codelines.Add "" - - 'copy module code (and add a vbTab prefix while we are at it) - With userForm.CodeModule - For i = 1 To .CountOfLines - codelines.Add vbTab & .Lines(i, 1) - Next i - End With - - 'process special cases for CheckBoxes and ToggleButtons (which in tB are CheckBoxes) - 'and TextBoxes - Set checkBoxes = New Collection - Set textBoxes = New Collection - For Each ctl In sorted - If TypeName(ctl) = "CheckBox" Or TypeName(ctl) = "ToggleButton" Then - checkBoxes.Add ctl.Name - ElseIf TypeName(ctl) = "TextBox" Then - textBoxes.Add ctl.Name - End If - Next ctl - - 'map the events handlers that tb Form and UserForm have in common - For i = 1 To codelines.Count - 'translate UserForm_QueryClose - If InStr(codelines(i), "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)") Then - codelines(i) = Replace(codelines(i), "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)", "Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)") - 'roll forward until 'End Sub' found - For j = i + 1 To codelines.Count - If InStr(codelines(j), "End Sub") Then Exit For - codelines(j) = Replace(codelines(j), "CloseMode", "UnloadMode") - Next j - End If - - 'replace CheckBox Value property boolean assignments with vbChecked and vbUnchecked - For j = 1 To checkBoxes.Count - codelines(i) = Replace(codelines(i), checkBoxes(j) & ".Value = True", checkBoxes(j) & ".Value = vbChecked") - codelines(i) = Replace(codelines(i), checkBoxes(j) & ".Value = False", checkBoxes(j) & ".Value = vbUnchecked") - codelines(i) = Replace(codelines(i), "If " & checkBoxes(j) & ".Value Then", "If " & checkBoxes(j) & ".Value = vbChecked Then") - codelines(i) = Replace(codelines(i), "If Not " & checkBoxes(j) & ".Value Then", "If " & checkBoxes(j) & ".Value = vbUnchecked Then") - codelines(i) = Replace(codelines(i), "= Not " & checkBoxes(j) & ".Value", "= IIf(" & checkBoxes(j) & ".Value = vbUnchecked, vbChecked, vbUnchecked)") - Next j - - 'replace TextBox Value property with Text property - For j = 1 To textBoxes.Count - codelines(i) = Replace(codelines(i), textBoxes(j) & ".Value", textBoxes(j) & ".Text") - Next j - - 'translate initialize event handler with New() - codelines(i) = Replace(codelines(i), "Sub UserForm_Initialize()", "Sub New()") - - 'translate Mouse and Keyboard event handlers - codelines(i) = Replace(codelines(i), "UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)", "Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)") - codelines(i) = Replace(codelines(i), "UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)", "Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)") - codelines(i) = Replace(codelines(i), "UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)", "Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)") - - codelines(i) = Replace(codelines(i), "UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)", "Form_KeyDown(KeyCode As Integer, Shift As Integer)") - codelines(i) = Replace(codelines(i), "UserForm_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)", "Form_KeyUp(KeyCode As Integer, Shift As Integer)") - codelines(i) = Replace(codelines(i), "UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)", "Form_KeyPress(KeyAscii As Integer)") - - 'translate other common event handlers - codelines(i) = Replace(codelines(i), "UserForm_Activate", "Form_Activate") - codelines(i) = Replace(codelines(i), "UserForm_Deactivate", "Form_Deactivate") - codelines(i) = Replace(codelines(i), "UserForm_Click", "Form_Click") - codelines(i) = Replace(codelines(i), "UserForm_DblClick(ByVal Cancel As MSForms.ReturnBoolean)", "Form_DblClick()") - codelines(i) = Replace(codelines(i), "UserForm_Resize()", "Form_Resize()") - codelines(i) = Replace(codelines(i), "UserForm_Terminate()", "Form_Terminate()") - - 'replace VBA's unload with tB's close method - codelines(i) = Replace(codelines(i), "Unload Me", "Me.Close") - Next i - - 'build Class footer - codelines.Add "" - codelines.Add "End Class" - - 'prepare to write translated code module to file - Dim fname As String - fname = Replace(fso.GetFileName(filePath), ".tbform", ".twin") - filePath = fso.GetParentFolderName(filePath) & "\" & fname - - 'write the file - If fso.FileExists(filePath) Then fso.DeleteFile filePath, True - Set ts = fso.CreateTextFile(filePath, False) - - For i = 1 To codelines.Count - ts.WriteLine codelines(i) - Next i - - ts.Close - - Set codelines = Nothing - Set checkBoxes = Nothing - End If - Next idlg - - MsgBox dialogNames.Count & " UserForms were converted!", , "Convert UserForm(s) to twinBASIC" - Exit Sub - EH: - MsgBox "A problem was encountered in processing the Userform(s)", , "Convert UserForm(s) to twinBASIC" - End Sub - - Public Sub ExtractImageResources(activeVBProject As VBProject) - Dim ctl As Object - Dim fso As New FileSystemObject - Dim dialogName As String - Dim userForm As VBComponent - Dim vbc As VBComponent - Dim dialogNames As New Collection - Dim idlg As Long - Dim imageCount As Long - - 'Initialize the form - For Each vbc In activeVBProject.VBComponents - If vbc.Type = vbext_ct_MSForm Then Extractor.lbxDialogs.AddItem vbc.Name - Next vbc - - 'show form to user - Extractor.Show vbModal - If Extractor.CancelPressed Then - Extractor.Close - Set Extractor = Nothing - Exit Sub - End If - - 'gather up the selected dialog names - For idlg = 0 To Extractor.lbxDialogs.ListCount - 1 - If Extractor.lbxDialogs.Selected(idlg) = True Then dialogNames.Add Extractor.lbxDialogs.List(idlg) - Next idlg - - 'browse for output folder path - Dim filePath As String - Dim folderPath As String - Dim comdlg As New VBComDlg.CommonDialog - Dim res As Boolean - Dim activeVBProjectFileName As String - Dim activeVBProjectFolderName As String - - comdlg.DialogTitle = "Select Output Folder to Save Resources:" - - 'it's possible that user created a useform in a new unsaved document - 'in which case activeVBProject.FileName will fail - On Error Resume Next - activeVBProjectFileName = activeVBProject.FileName - If Err.Number <> 0 Then - activeVBProjectFolderName = CurDir() - Else - activeVBProjectFolderName = fso.GetParentFolderName(activeVBProjectFileName) - End If - On Error GoTo 0 - - On Error GoTo EH - - comdlg.InitDir = activeVBProjectFolderName - - res = comdlg.ShowFolderBrowser() - If Not res Then - MsgBox "No UserForms were processed.", , "Extract UserForm Image Resources" - 'unload the form - Extractor.Close - Set Extractor = Nothing - Exit Sub - End If - folderPath = comdlg.FileName - - 'unload the form - Extractor.Close - Set Extractor = Nothing - - 'loop through and process each selected UserForm - For idlg = 1 To dialogNames.Count - dialogName = dialogNames(idlg) - Set userForm = activeVBProject.VBComponents(dialogName) - SaveFormImagesToFile userForm, folderPath, imageCount - 'enumerate and process each UserForm control - For Each ctl In userForm.Designer.Controls - If IsSupported(ctl) Then - SaveControlImagesToFile ctl, folderPath, dialogName, imageCount - End If - Next ctl - Next idlg - - MsgBox dialogNames.Count & " UserForms were processed." & vbCrLf & imageCount & " images were extracted and saved!", , "Extract UserForm Image Resources" - Exit Sub - EH: - MsgBox "A problem was encountered in processing the Userform(s)", , "Extract UserForm Image Resources" - End Sub - - '--------------------------------------------------------------------- - ' Private Support Procedures - '--------------------------------------------------------------------- - - 'recursive routine to search the dictionary for the parent key of ctl, - 'and then if found, add ctl's tB dictionary to parent - Private Function AddToParent(parent As Dictionary, ctl As Object, tbControl As Dictionary) As Boolean - Dim child As Dictionary - If parent.Exists("_children") Then - If parent("Name") = GetParentName(ctl) Then - parent.Item("_children").Add tbControl - Exit Function - Else - For Each child In parent("_children") - If AddToParent(child, ctl, tbControl) Then AddToParent = True: Exit For - Next child - End If - End If - End Function - - 'sort controls in order of descendancy - must process parent controls before their descendants! - Private Function SortControls(frm As Object, ByVal dialogName As String) As Collection - Dim sorted As New Collection - Dim unsorted As New Collection - Dim ctl As Object - Dim i As Long - Dim j As Long - Dim k As Long = 1 - - 'create two collections sorted and unsorted - 'can assign all controls that are direct descendants of form to sorted - For Each ctl In frm.Controls - If ctl.parent.Name = dialogName Then - sorted.Add ctl - Else - unsorted.Add ctl - End If - Next ctl - - 'loop through unsorted looking for parent in sorted - - 'if found add to sorted and remove from unsorted. - 'Repeat until all controls are in sorted - Do - k = k + 1 - For i = unsorted.Count To 1 Step -1 - For j = 1 To sorted.Count - If GetParentName(unsorted(i)) = sorted(j).Name Then - sorted.Add unsorted(i) - unsorted.Remove i - Exit For - End If - Next j - Next i - DoEvents - If k > 1000 Then Exit Do 'this should not happen but just in case - Loop Until unsorted.Count = 0 - Set SortControls = sorted - End Function - - Private Sub SetFontProperties(tbControl As Dictionary, ctl As Object) - tbControl.Item("FontName") = ctl.Font.Name - tbControl.Item("FontSize") = ctl.Font.Size - tbControl.Item("FontBold") = ctl.Font.Bold - tbControl.Item("FontItalic") = ctl.Font.Italic - tbControl.Item("FontStrikethru") = ctl.Font.Strikethrough - tbControl.Item("FontUnderline") = ctl.Font.Underline - End Sub - - Private Function GetMousePointerString(ByVal vbacode As Long) As String - Select Case vbacode - Case fmMousePointerDefault '0 Standard pointer. The image is determined by the object (default). - GetMousePointerString = "vbDefault" - Case fmMousePointerArrow '1 Arrow. - GetMousePointerString = "vbArrow" - Case fmMousePointerCross '2 Cross-hair pointer. - GetMousePointerString = "vbCrosshair" - Case fmMousePointerIBeam '3 I-beam. - GetMousePointerString = "vbIbeam" - Case fmMousePointerSizeNESW '6 Double arrow pointing northeast and southwest. - GetMousePointerString = "vbSizeNESW" - Case fmMousePointerSizeNS '7 Double arrow pointing north and south. - GetMousePointerString = "vbSizeNS" - Case fmMousePointerSizeNWSE '8 Double arrow pointing northwest and southeast. - GetMousePointerString = "vbSizeNWSE" - Case fmMousePointerSizeWE '9 Double arrow pointing west and east. - GetMousePointerString = "vbSizeWE" - Case fmMousePointerUpArrow '10 Up arrow. - GetMousePointerString = "vbUpArrow" - Case fmMousePointerHourGlass '11 Hourglass. - GetMousePointerString = "vbHourglass" - Case fmMousePointerNoDrop '12 "Not" symbol (circle with a diagonal line) on top of the object being dragged. Indicates an invalid drop target. - GetMousePointerString = "vbNoDrop" - Case fmMousePointerAppStarting '13 Arrow with an hourglass. - GetMousePointerString = "vbArrowHourglass" - Case fmMousePointerHelp '14 Arrow with a question mark. - GetMousePointerString = "vbArrowQuestion" - Case fmMousePointerSizeAll '15 Size all cursor (arrows pointing north, south, east, and west). - GetMousePointerString = "vbSizeAll" - Case fmMousePointerCustom '99 Uses the icon specified by the MouseIcon property. - GetMousePointerString = "vbCustom" - End Select - End Function - - Private Function GetParentName(ctl As Object) As String - Select Case TypeName(ctl.parent) - Case "Page" - 'Page control is an "internal" child of MultiPage control. So if a ctl - 'is contained by Page, must skip to grand-parent to find public "parent" - GetParentName = ctl.parent.parent.Name - Case Else - GetParentName = ctl.parent.Name - End Select - End Function - - Private Function IsSupported(ctl As Object) As Boolean - Select Case TypeName(ctl) - Case "Label", "CommandButton", "TextBox", "Frame", "CheckBox", "ComboBox", "ListBox", "OptionButton", "Image", "ScrollBar", "SpinButton", "ToggleButton" - IsSupported = True - Case "TabStrip", "MultiPage" - IsSupported = False - Case Else - IsSupported = False - End Select - End Function - - Private Function tbScrollBarTypeName(ctl As Object) As String - Select Case ctl.Orientation - Case fmOrientationVertical - tbScrollBarTypeName = "VScrollBar" - Case fmOrientationHorizontal - tbScrollBarTypeName = "HScrollBar" - Case fmOrientationAuto - If ctl.Width > ctl.Height Then tbScrollBarTypeName = "HScrollBar" Else tbScrollBarTypeName = "VScrollBar" - End Select - End Function - - Private Sub ProcessLabel(ctl As Object, tbControl As Dictionary, ByVal ptsToPixels As Double, ByVal useVBAFont As Boolean, ByVal use3DAppearance As Boolean) - tbControl.Item("Name") = ctl.Name - tbControl.Item("Height") = ctl.Height * ptsToPixels - tbControl.Item("Width") = ctl.Width * ptsToPixels - tbControl.Item("Left") = ctl.Left * ptsToPixels - - Select Case TypeName(ctl.Parent) - Case "Frame" - 'tB is from top left corner of frame, vba references from the inside - tbControl.Item("Top") = (ctl.Top + 5) * ptsToPixels - Case "Page" - tbControl.Item("Top") = (ctl.Top + 15) * ptsToPixels - Case Else - tbControl.Item("Top") = ctl.Top * ptsToPixels - End Select - - tbControl.Item("Enabled") = ctl.Enabled - tbControl.Item("Visible") = ctl.Visible - tbControl.Item("Tag") = ctl.Tag - tbControl.Item("MousePointer") = GetMousePointerString(ctl.MousePointer) - - If ctl.MouseIcon <> 0 Then - tbControl.Item("MouseIcon") = GetImageString(ctl.MouseIcon) - End If - - If TypeName(ctl.Parent) = "Frame" Then - 'tB is from top left corner of frame, vba references from the inside - tbControl.Item("Top") = (ctl.Top + 5) * ptsToPixels - 'tBControl.Item("Top") = ctl.Top * ptsToPixels + 7 - End If - - If useVBAFont Then SetFontProperties tbControl, ctl - tbControl.Item("BorderColor") = ctl.BorderColor - tbControl.Item("BackColor") = ctl.BackColor - tbControl.Item("ForeColor") = ctl.ForeColor - tbControl.Item("Caption") = ctl.Caption - tbControl.Item("AutoSize") = ctl.AutoSize - - If ctl.BackStyle = fmBackStyleTransparent Then tbControl.Item("BackStyle") = "vbBFTransparent" - - If ctl.SpecialEffect = fmSpecialEffectFlat Then - tbControl.Item("BorderStyle") = IIf(ctl.BorderStyle = fmBorderStyleNone, "vbNoBorder", "vbFixedSingleBorder") - Else - tbControl.Item("BorderStyle") = "vbFixedSingleBorder" - End If - - 'tbControl.Item("HelpContextID") = ctl.HelpContextID - tbControl.Item("ToolTipText") = ctl.ControlTipText - tbControl.Item("WordWrap") = ctl.WordWrap - - Select Case ctl.TextAlign - Case fmTextAlignCenter - tbControl.Item("Alignment") = "vbCenter" - Case fmTextAlignLeft - tbControl.Item("Alignment") = "vbLeftJustify" - Case fmTextAlignRight - tbControl.Item("Alignment") = "vbRightJustify" - End Select - tbControl.Item("ToolTipText") = ctl.ControlTipText - If use3DAppearance Then tbControl.Item("Appearance") = vbAppear3d Else tbControl.Item("Appearance") = vbAppearFlat - End Sub - - Private Sub ProcessCommandButton(ctl As Object, tbControl As Dictionary, ByVal ptsToPixels As Double, ByVal useVBAFont As Boolean, ByVal useVisualStyles As Boolean, ByVal use3DAppearance As Boolean) - tbControl.Item("Name") = ctl.Name - tbControl.Item("Height") = ctl.Height * ptsToPixels - tbControl.Item("Width") = ctl.Width * ptsToPixels - tbControl.Item("Left") = ctl.Left * ptsToPixels - - Select Case TypeName(ctl.Parent) - Case "Frame" - 'tB is from top left corner of frame, vba references from the inside - tbControl.Item("Top") = (ctl.Top + 5) * ptsToPixels - Case "Page" - tbControl.Item("Top") = (ctl.Top + 15) * ptsToPixels - Case Else - tbControl.Item("Top") = ctl.Top * ptsToPixels - End Select - - tbControl.Item("Enabled") = ctl.Enabled - tbControl.Item("Visible") = ctl.Visible - tbControl.Item("Tag") = ctl.Tag - tbControl.Item("MousePointer") = GetMousePointerString(ctl.MousePointer) - - If ctl.MouseIcon <> 0 Then - tbControl.Item("MouseIcon") = GetImageString(ctl.MouseIcon) - End If - - tbControl.Item("ToolTipText") = ctl.ControlTipText - If useVBAFont Then SetFontProperties tbControl, ctl - tbControl.Item("BackColor") = ctl.BackColor - 'unlike the other tB controls, CommandButton BackColor property does not take effect - 'unless Style property is set to vbButtonGraphical - If ctl.BackColor <> -2147483633 Then tbControl.Item("Style") = "vbButtonGraphical" - If ctl.BackStyle = fmBackStyleTransparent Then tbControl.Item("Opacity") = 0 - tbControl.Item("ForeColor") = ctl.ForeColor - tbControl.Item("TabIndex") = ctl.TabIndex - tbControl.Item("TabStop") = ctl.TabStop - tbControl.Item("Caption") = ctl.Caption - 'tbControl.Item("Cancel") = ctl.Cancel - 'tbControl.Item("HelpContextID") = ctl.HelpContextID - tbControl.Item("VisualStyles") = useVisualStyles - If use3DAppearance Then tbControl.Item("Appearance") = vbAppear3d Else tbControl.Item("Appearance") = vbAppearFlat - If ctl.Picture.type <> 0 Then - tbControl.Item("Picture") = GetImageString(ctl.Picture) - tbControl.Item("Style") = "vbButtonGraphical" - End If - End Sub - - Private Sub ProcessTextBox(ctl As Object, tbControl As Dictionary, ByVal ptsToPixels As Double, ByVal useVBAFont As Boolean, ByVal useVisualStyles As Boolean, ByVal use3DAppearance As Boolean) - tbControl.Item("Name") = ctl.Name - tbControl.Item("Height") = ctl.Height * ptsToPixels - tbControl.Item("Width") = ctl.Width * ptsToPixels - tbControl.Item("Left") = ctl.Left * ptsToPixels - - Select Case TypeName(ctl.Parent) - Case "Frame" - 'tB is from top left corner of frame, vba references from the inside - tbControl.Item("Top") = (ctl.Top + 5) * ptsToPixels - Case "Page" - tbControl.Item("Top") = (ctl.Top + 15) * ptsToPixels - Case Else - tbControl.Item("Top") = ctl.Top * ptsToPixels - End Select - - tbControl.Item("Enabled") = ctl.Enabled - tbControl.Item("Visible") = ctl.Visible - tbControl.Item("Tag") = ctl.Tag - tbControl.Item("MousePointer") = GetMousePointerString(ctl.MousePointer) - - If ctl.MouseIcon <> 0 Then - tbControl.Item("MouseIcon") = GetImageString(ctl.MouseIcon) - End If - - 'tbControl.Item("HelpContextID") = ctl.HelpContextID - tbControl.Item("ToolTipText") = ctl.ControlTipText - - If useVBAFont Then SetFontProperties tbControl, ctl - tbControl.Item("BackColor") = ctl.BackColor - tbControl.Item("ForeColor") = ctl.ForeColor - tbControl.Item("TabIndex") = ctl.TabIndex - tbControl.Item("TabStop") = ctl.TabStop - tbControl.Item("Text") = ctl.Text - tbControl.Item("MultiLine") = ctl.MultiLine - tbControl.Item("MaxLength") = ctl.MaxLength - tbControl.Item("PasswordChar") = ctl.PasswordChar - tbControl.Item("Locked") = ctl.Locked - tbControl.Item("HideSelection") = ctl.HideSelection - If ctl.BackStyle = fmBackStyleTransparent Then tbControl.Item("Opacity") = 0 - - Select Case ctl.ScrollBars - Case fmScrollBarsNone - tbControl.Item("ScrollBars") = "vbSBNone" - Case fmScrollBarsHorizontal - tbControl.Item("ScrollBars") = "vbHorizontal" - Case fmScrollBarsVertical - tbControl.Item("ScrollBars") = "vbVertical" - Case fmScrollBarsBoth - tbControl.Item("ScrollBars") = "vbBoth" - End Select - - Select Case ctl.TextAlign - Case fmTextAlignCenter - tbControl.Item("Alignment") = "vbCenter" - Case fmTextAlignLeft - tbControl.Item("Alignment") = "vbLeftJustify" - Case fmTextAlignRight - tbControl.Item("Alignment") = "vbRightJustify" - End Select - - If ctl.SpecialEffect = fmSpecialEffectFlat Then - tbControl.Item("BorderStyle") = IIf(ctl.BorderStyle = fmBorderStyleNone, "vbNoBorder", "vbFixedSingleBorder") - Else - tbControl.Item("BorderStyle") = "vbFixedSingleBorder" - End If - - tbControl.Item("VisualStyles") = useVisualStyles - If use3DAppearance Then tbControl.Item("Appearance") = vbAppear3d Else tbControl.Item("Appearance") = vbAppearFlat - End Sub - - Private Sub ProcessFrame(ctl As Object, tbControl As Dictionary, ByVal ptsToPixels As Double, ByVal useVBAFont As Boolean, ByVal useVisualStyles As Boolean, ByVal use3DAppearance As Boolean) - tbControl.Item("Name") = ctl.Name - tbControl.Item("Height") = ctl.Height * ptsToPixels - tbControl.Item("Width") = ctl.Width * ptsToPixels - tbControl.Item("Left") = ctl.Left * ptsToPixels - - Select Case TypeName(ctl.Parent) - Case "Frame" - 'tB is from top left corner of frame, vba references from the inside - tbControl.Item("Top") = (ctl.Top + 5) * ptsToPixels - Case "Page" - tbControl.Item("Top") = (ctl.Top + 15) * ptsToPixels - Case Else - tbControl.Item("Top") = ctl.Top * ptsToPixels - End Select - - tbControl.Item("Enabled") = ctl.Enabled - tbControl.Item("Visible") = ctl.Visible - tbControl.Item("Tag") = ctl.Tag - tbControl.Item("MousePointer") = GetMousePointerString(ctl.MousePointer) - - If ctl.MouseIcon <> 0 Then - tbControl.Item("MouseIcon") = GetImageString(ctl.MouseIcon) - End If - - 'tbControl.Item("HelpContextID") = ctl.HelpContextID - tbControl.Item("ToolTipText") = ctl.ControlTipText - If useVBAFont Then SetFontProperties tbControl, ctl - tbControl.Item("BackColor") = ctl.BackColor - tbControl.Item("ForeColor") = ctl.ForeColor - - 'If ctl.Caption = "" Then - ' tbControl.Item("BorderStyle") = IIf(ctl.BorderStyle = fmBorderStyleNone, "vbNoBorder", "vbFixedSingleBorder") - 'End If - - If ctl.SpecialEffect = fmSpecialEffectFlat Then - tbControl.Item("BorderStyle") = IIf(ctl.BorderStyle = fmBorderStyleNone, "vbNoBorder", "vbFixedSingleBorder") - Else - tbControl.Item("BorderStyle") = "vbFixedSingleBorder" - End If - - tbControl.Item("Caption") = ctl.Caption - tbControl.Item("VisualStyles") = useVisualStyles - If use3DAppearance Then tbControl.Item("Appearance") = vbAppear3d Else tbControl.Item("Appearance") = vbAppearFlat - End Sub - - Private Sub ProcessCheckBox(ctl As Object, tbControl As Dictionary, ByVal ptsToPixels As Double, ByVal useVBAFont As Boolean, ByVal useVisualStyles As Boolean, ByVal use3DAppearance As Boolean) - tbControl.Item("Name") = ctl.Name - tbControl.Item("Height") = ctl.Height * ptsToPixels - tbControl.Item("Width") = ctl.Width * ptsToPixels - tbControl.Item("Left") = ctl.Left * ptsToPixels - tbControl.Item("Top") = ctl.Top * ptsToPixels - - Select Case TypeName(ctl.Parent) - Case "Frame" - 'tB is from top left corner of frame, vba references from the inside - tbControl.Item("Top") = (ctl.Top + 5) * ptsToPixels - Case "Page" - tbControl.Item("Top") = (ctl.Top + 15) * ptsToPixels - Case Else - tbControl.Item("Top") = ctl.Top * ptsToPixels - End Select - - tbControl.Item("Enabled") = ctl.Enabled - tbControl.Item("Visible") = ctl.Visible - tbControl.Item("Tag") = ctl.Tag - tbControl.Item("MousePointer") = GetMousePointerString(ctl.MousePointer) - - If ctl.MouseIcon <> 0 Then - tbControl.Item("MouseIcon") = GetImageString(ctl.MouseIcon) - End If - - 'tbControl.Item("HelpContextID") = ctl.HelpContextID - tbControl.Item("ToolTipText") = ctl.ControlTipText - - If useVBAFont Then SetFontProperties tbControl, ctl - tbControl.Item("BackColor") = ctl.BackColor - tbControl.Item("ForeColor") = ctl.ForeColor - tbControl.Item("Caption") = ctl.Caption - tbControl.Item("Value") = IIf(ctl.Value, "vbChecked", "vbUnchecked") - tbControl.Item("TabIndex") = ctl.TabIndex - tbControl.Item("TabStop") = ctl.TabStop - If ctl.BackStyle = fmBackStyleTransparent Then tbControl.Item("Opacity") = 0 - - Select Case ctl.TextAlign - Case fmTextAlignCenter - 'tbControl.Item("Alignment") = "tbCenter" 'tb CheckBox does not allow tbCenter - Case fmTextAlignLeft - tbControl.Item("Alignment") = "tbLeftJustify" - Case fmTextAlignRight - tbControl.Item("Alignment") = "tbRightJustify" - End Select - tbControl.Item("VisualStyles") = useVisualStyles - If use3DAppearance Then tbControl.Item("Appearance") = vbAppear3d Else tbControl.Item("Appearance") = vbAppearFlat - If ctl.Picture.type <> 0 Then - tbControl.Item("Picture") = GetImageString(ctl.Picture) - tbControl.Item("Style") = "vbButtonGraphical" - End If - End Sub - - Private Sub ProcessComboBox(ctl As Object, tbControl As Dictionary, ByVal ptsToPixels As Double, ByVal useVBAFont As Boolean, ByVal useVisualStyles As Boolean, ByVal use3DAppearance As Boolean) - tbControl.Item("Name") = ctl.Name - tbControl.Item("Height") = ctl.Height * ptsToPixels - tbControl.Item("Width") = ctl.Width * ptsToPixels - tbControl.Item("Left") = ctl.Left * ptsToPixels - tbControl.Item("Top") = ctl.Top * ptsToPixels - - Select Case TypeName(ctl.Parent) - Case "Frame" - 'tB is from top left corner of frame, vba references from the inside - tbControl.Item("Top") = (ctl.Top + 5) * ptsToPixels - Case "Page" - tbControl.Item("Top") = (ctl.Top + 15) * ptsToPixels - Case Else - tbControl.Item("Top") = ctl.Top * ptsToPixels - End Select - - tbControl.Item("Enabled") = ctl.Enabled - tbControl.Item("Visible") = ctl.Visible - tbControl.Item("Tag") = ctl.Tag - tbControl.Item("MousePointer") = GetMousePointerString(ctl.MousePointer) - - If ctl.MouseIcon <> 0 Then - tbControl.Item("MouseIcon") = GetImageString(ctl.MouseIcon) - End If - - 'tbControl.Item("HelpContextID") = ctl.HelpContextID - tbControl.Item("ToolTipText") = ctl.ControlTipText - - If useVBAFont Then SetFontProperties tbControl, ctl - tbControl.Item("BackColor") = ctl.BackColor - tbControl.Item("ForeColor") = ctl.ForeColor - tbControl.Item("TabIndex") = ctl.TabIndex - tbControl.Item("TabStop") = ctl.TabStop - If ctl.BackStyle = fmBackStyleTransparent Then tbControl.Item("Opacity") = 0 - - If ctl.SpecialEffect = fmSpecialEffectFlat Then - tbControl.Item("BorderStyle") = IIf(ctl.BorderStyle = fmBorderStyleNone, "vbNoBorder", "vbFixedSingleBorder") - Else - tbControl.Item("BorderStyle") = "vbFixedSingleBorder" - End If - - 'tb is vbComboDropdown,vbComboSimple,vbComboDropdownList - Select Case ctl.Style - Case fmStyleDropDownList - tbControl.Item("Style") = "vbComboDropdownList" - Case fmStyleDropDownCombo - tbControl.Item("Style") = "vbComboDropdown" - End Select - - tbControl.Item("Text") = ctl.Text - tbControl.Item("VisualStyles") = useVisualStyles - If use3DAppearance Then tbControl.Item("Appearance") = vbAppear3d Else tbControl.Item("Appearance") = vbAppearFlat - End Sub - - Private Sub ProcessListBox(ctl As Object, tbControl As Dictionary, ByVal ptsToPixels As Double, ByVal useVBAFont As Boolean, ByVal useVisualStyles As Boolean, ByVal use3DAppearance As Boolean) - tbControl.Item("Name") = ctl.Name - tbControl.Item("Height") = ctl.Height * ptsToPixels - tbControl.Item("Width") = ctl.Width * ptsToPixels - tbControl.Item("Left") = ctl.Left * ptsToPixels - tbControl.Item("Top") = ctl.Top * ptsToPixels - - Select Case TypeName(ctl.Parent) - Case "Frame" - 'tB is from top left corner of frame, vba references from the inside - tbControl.Item("Top") = (ctl.Top + 5) * ptsToPixels - Case "Page" - tbControl.Item("Top") = (ctl.Top + 15) * ptsToPixels - Case Else - tbControl.Item("Top") = ctl.Top * ptsToPixels - End Select - - tbControl.Item("Enabled") = ctl.Enabled - tbControl.Item("Visible") = ctl.Visible - tbControl.Item("Tag") = ctl.Tag - tbControl.Item("MousePointer") = GetMousePointerString(ctl.MousePointer) - - If ctl.MouseIcon <> 0 Then - tbControl.Item("MouseIcon") = GetImageString(ctl.MouseIcon) - End If - - 'tbControl.Item("HelpContextID") = ctl.HelpContextID - tbControl.Item("ToolTipText") = ctl.ControlTipText - - If useVBAFont Then SetFontProperties tbControl, ctl - tbControl.Item("BackColor") = ctl.BackColor - tbControl.Item("ForeColor") = ctl.ForeColor - tbControl.Item("TabIndex") = ctl.TabIndex - tbControl.Item("TabStop") = ctl.TabStop - - Select Case ctl.MultiSelect - Case fmMultiSelectSingle - tbControl.Item("MultiSelect") = "vbMultiSelectNone" - Case fmMultiSelectMulti - tbControl.Item("MultiSelect") = "vbMultiSelectSimple" - Case fmMultiSelectExtended - tbControl.Item("MultiSelect") = "vbMultiSelectExtended" - End Select - - Select Case ctl.ListStyle - Case fmListStylePlain - tbControl.Item("Style") = "vbListBoxStandard" - Case fmListStyleOption - tbControl.Item("Style") = "vbListBoxCheckBox" - End Select - - If ctl.SpecialEffect = fmSpecialEffectFlat Then - tbControl.Item("BorderStyle") = IIf(ctl.BorderStyle = fmBorderStyleNone, "vbNoBorder", "vbFixedSingleBorder") - Else - tbControl.Item("BorderStyle") = "vbFixedSingleBorder" - End If - - tbControl.Item("IntegralHeight") = ctl.IntegralHeight - tbControl.Item("Columns") = ctl.ColumnCount - 1 '? - tbControl.Item("VisualStyles") = useVisualStyles - If use3DAppearance Then tbControl.Item("Appearance") = vbAppear3d Else tbControl.Item("Appearance") = vbAppearFlat - End Sub - - Private Sub ProcessOptionButton(ctl As Object, tbControl As Dictionary, ByVal ptsToPixels As Double, ByVal useVBAFont As Boolean, ByVal useVisualStyles As Boolean, ByVal use3DAppearance As Boolean) - tbControl.Item("Name") = ctl.Name - tbControl.Item("Height") = ctl.Height * ptsToPixels - tbControl.Item("Width") = ctl.Width * ptsToPixels - tbControl.Item("Left") = ctl.Left * ptsToPixels - tbControl.Item("Top") = ctl.Top * ptsToPixels - - Select Case TypeName(ctl.Parent) - Case "Frame" - 'tB is from outside top left corner of frame, vba references from the inside - tbControl.Item("Top") = (ctl.Top + 5) * ptsToPixels - Case "Page" - tbControl.Item("Top") = (ctl.Top + 15) * ptsToPixels - Case Else - tbControl.Item("Top") = ctl.Top * ptsToPixels - End Select - - tbControl.Item("Enabled") = ctl.Enabled - tbControl.Item("Visible") = ctl.Visible - tbControl.Item("Tag") = ctl.Tag - tbControl.Item("MousePointer") = GetMousePointerString(ctl.MousePointer) - - If ctl.MouseIcon <> 0 Then - tbControl.Item("MouseIcon") = GetImageString(ctl.MouseIcon) - End If - - 'tbControl.Item("HelpContextID") = ctl.HelpContextID - tbControl.Item("ToolTipText") = ctl.ControlTipText - - If useVBAFont Then SetFontProperties tbControl, ctl - tbControl.Item("BackColor") = ctl.BackColor - tbControl.Item("ForeColor") = ctl.ForeColor - tbControl.Item("TabStop") = ctl.TabStop - tbControl.Item("TabIndex") = ctl.TabIndex - tbControl.Item("Caption") = ctl.Caption - tbControl.Item("Value") = ctl.Value - If ctl.BackStyle = fmBackStyleTransparent Then tbControl.Item("Opacity") = 0 - - Select Case ctl.TextAlign - Case fmTextAlignCenter - tbControl.Item("Alignment") = "tbCenter" - Case fmTextAlignLeft - tbControl.Item("Alignment") = "tbLeftJustify" - Case fmTextAlignRight - tbControl.Item("Alignment") = "tbRightJustify" - End Select - - tbControl.Item("VisualStyles") = useVisualStyles - If use3DAppearance Then tbControl.Item("Appearance") = vbAppear3d Else tbControl.Item("Appearance") = vbAppearFlat - - If ctl.Picture.type <> 0 Then - tbControl.Item("Picture") = GetImageString(ctl.Picture) - tbControl.Item("Style") = "vbButtonGraphical" - End If - End Sub - - Private Sub ProcessImage(ctl As Object, tbControl As Dictionary, ByVal ptsToPixels As Double, ByVal use3DAppearance As Boolean) - tbControl.Item("Name") = ctl.Name - tbControl.Item("Height") = ctl.Height * ptsToPixels - tbControl.Item("Width") = ctl.Width * ptsToPixels - tbControl.Item("Left") = ctl.Left * ptsToPixels - tbControl.Item("Top") = ctl.Top * ptsToPixels - - tbControl.Item("BorderStyle") = IIf(ctl.BorderStyle = fmBorderStyleNone, "vbNoBorder", "vbFixedSingleBorder") - - Select Case TypeName(ctl.Parent) - Case "Frame" - 'tB is from top left corner of frame, vba references from the inside - tbControl.Item("Top") = (ctl.Top + 5) * ptsToPixels - Case "Page" - tbControl.Item("Top") = (ctl.Top + 15) * ptsToPixels - Case Else - tbControl.Item("Top") = ctl.Top * ptsToPixels - End Select - - tbControl.Item("Enabled") = ctl.Enabled - tbControl.Item("Visible") = ctl.Visible - tbControl.Item("Tag") = ctl.Tag - tbControl.Item("MousePointer") = GetMousePointerString(ctl.MousePointer) - - If ctl.MouseIcon <> 0 Then - tbControl.Item("MouseIcon") = GetImageString(ctl.MouseIcon) - End If - - tbControl.Item("ToolTipText") = ctl.ControlTipText - - tbControl.Item("BackColor") = ctl.BackColor - tbControl.Item("Name") = ctl.Name - tbControl.Item("Appearance") = IIf(ctl.SpecialEffect = 0, "vbAppearFlat", "vbAppear3D") 'all controls except for scrollbars - 'UserForm's Image has BackStyle, yet tB's does not (v544) - 'If ctl.BackStyle = fmBackStyleTransparent Then tbControl.Item("Opacity") = 0 - 'If use3DAppearance Then tbControl.Item("Appearance") = vbAppear3d Else tbControl.Item("Appearance") = vbAppearFlat - - If ctl.Picture IsNot Nothing Then - tbControl.Item("Picture") = GetImageString(ctl.Picture) - tbControl.Item("Stretch") = True - End If - End Sub - - Private Sub ProcessSpinButton(ctl As Object, tbControl As Dictionary, ByVal ptsToPixels As Double, ByVal useVisualStyles As Boolean) - tbControl.Item("Name") = ctl.Name - tbControl.Item("Height") = ctl.Height * ptsToPixels - tbControl.Item("Width") = ctl.Width * ptsToPixels - tbControl.Item("Left") = ctl.Left * ptsToPixels - tbControl.Item("Top") = ctl.Top * ptsToPixels - - Select Case TypeName(ctl.Parent) - Case "Frame" - 'tB is from top left corner of frame, vba references from the inside - tbControl.Item("Top") = (ctl.Top + 5) * ptsToPixels - Case "Page" - tbControl.Item("Top") = (ctl.Top + 15) * ptsToPixels - Case Else - tbControl.Item("Top") = ctl.Top * ptsToPixels - End Select - - tbControl.Item("Enabled") = ctl.Enabled - tbControl.Item("Visible") = ctl.Visible - tbControl.Item("Tag") = ctl.Tag - tbControl.Item("MousePointer") = GetMousePointerString(ctl.MousePointer) - - If ctl.MouseIcon <> 0 Then - tbControl.Item("MouseIcon") = GetImageString(ctl.MouseIcon) - End If - - 'tbControl.Item("HelpContextID") = ctl.HelpContextID - 'tbControl.Item("ToolTipText") = ctl.ControlTipText - - Set ctl = ctl - tbControl.Item("Min") = ctl.Min - tbControl.Item("Max") = ctl.Max - tbControl.Item("Increment") = ctl.SmallChange - tbControl.Item("Value") = ctl.Value - tbControl.Item("TabStop") = ctl.TabStop - tbControl.Item("TabIndex") = ctl.TabIndex - tbControl.Item("Name") = ctl.Name - tbControl.Item("Tag") = ctl.Tag - - Select Case ctl.Orientation - Case fmOrientationHorizontal - tbControl.Item("Alignment") = "ccOrientationHorizontal" - Case fmOrientationVertical - tbControl.Item("Alignment") = "ccOrientationVertical" - Case fmOrientationAuto - If ctl.Width > ctl.Height Then tbControl.Item("Orientation") = "ccOrientationHorizontal" Else tbControl.Item("Orientation") = "ccOrientationVertical" - End Select - tbControl.Item("VisualStyles") = useVisualStyles - End Sub - - Private Sub ProcessScrollBar(ctl As Object, tbControl As Dictionary, ByVal ptsToPixels As Double, ByVal useVisualStyles As Boolean) - tbControl.Item("Name") = ctl.Name - tbControl.Item("Height") = ctl.Height * ptsToPixels - tbControl.Item("Width") = ctl.Width * ptsToPixels - tbControl.Item("Left") = ctl.Left * ptsToPixels - tbControl.Item("Top") = ctl.Top * ptsToPixels - - Select Case TypeName(ctl.Parent) - Case "Frame" - 'tB is from top left corner of frame, vba references from the inside - tbControl.Item("Top") = (ctl.Top + 5) * ptsToPixels - Case "Page" - tbControl.Item("Top") = (ctl.Top + 15) * ptsToPixels - Case Else - tbControl.Item("Top") = ctl.Top * ptsToPixels - End Select - - tbControl.Item("Enabled") = ctl.Enabled - tbControl.Item("Visible") = ctl.Visible - tbControl.Item("Tag") = ctl.Tag - tbControl.Item("MousePointer") = GetMousePointerString(ctl.MousePointer) - - If ctl.MouseIcon <> 0 Then - tbControl.Item("MouseIcon") = GetImageString(ctl.MouseIcon) - End If - - 'tbControl.Item("HelpContextID") = ctl.HelpContextID - 'tbControl.Item("ToolTipText") = ctl.ControlTipText - - tbControl.Item("ForeColor") = ctl.ForeColor - tbControl.Item("Min") = ctl.Min - tbControl.Item("Max") = ctl.Max - tbControl.Item("Value") = ctl.Value - - 'If VisualStyles=False then ScrollBar button will blink - 'for 5 secs until it loses focus after user moves it - 'apparently a VB6 behavior not present in VBA - 'set TabStop=False to prevent it from blinking - tbControl.Item("TabStop") = ctl.TabStop - - tbControl.Item("TabIndex") = ctl.TabIndex - tbControl.Item("SmallChange") = ctl.SmallChange - tbControl.Item("LargeChange") = ctl.LargeChange - tbControl.Item("Name") = ctl.Name - 'tBControl.Item("BackColor") = ctl.BackColor - tbControl.Item("Tag") = ctl.Tag - tbControl.Item("VisualStyles") = useVisualStyles - End Sub - - Private Sub ProcessToggleButton(ctl As Object, tbControl As Dictionary, ByVal ptsToPixels As Double, ByVal useVBAFont As Boolean, ByVal useVisualStyles As Boolean, ByVal use3DAppearance As Boolean) - ProcessCheckBox ctl, tbControl, ptsToPixels, useVBAFont, useVisualStyles, use3DAppearance - tbControl.Item("Style") = "vbButtonGraphical" 'this is what makes a CheckBox into a ToggleButton - End Sub - - Private Sub ProcessUnsupported(ctl As Object, tbControl As Dictionary, ByVal ptsToPixels As Double) - tbControl.Item("Name") = ctl.Name - tbControl.Item("Height") = ctl.Height * ptsToPixels - tbControl.Item("Width") = ctl.Width * ptsToPixels - tbControl.Item("Left") = ctl.Left * ptsToPixels - tbControl.Item("Top") = ctl.Top * ptsToPixels - - Select Case TypeName(ctl.Parent) - Case "Frame" - 'tB is from top left corner of frame, vba references from the inside - tbControl.Item("Top") = (ctl.Top + 5) * ptsToPixels - Case "Page" - tbControl.Item("Top") = (ctl.Top + 15) * ptsToPixels - Case Else - tbControl.Item("Top") = ctl.Top * ptsToPixels - End Select - - tbControl.Item("Tag") = ctl.Tag - - If TypeName(ctl.Parent) = "Page" Then - 'tB is from top left corner of frame, vba references from the inside - tbControl.Item("Top") = (ctl.Top + 15) * ptsToPixels - End If - - tbControl.Item("FontSize") = 6 - - tbControl.Item("BackColor") = &HC0C0FF - tbControl.Item("Caption") = "Unsupported " & TypeName(ctl) - If tbControl.Exists("WordWrap") Then tbControl.Item("WordWrap") = True - End Sub - - Private Sub ProcessForm(userForm As VBComponent, tbControl As Dictionary, ByVal ptsToPixels As Double, ByVal useVBAFont As Boolean, ByVal Use3DAppearance As Boolean, ByVal guid As String, ByVal hideIconBox As Boolean) - Dim frm As Object - Set frm = userForm.Designer - tbControl.Item("Height") = (frm.InsideHeight) * ptsToPixels - tbControl.Item("Width") = (frm.InsideWidth) * ptsToPixels - - tbControl.Item("Left") = 0 - tbControl.Item("Top") = 0 - tbControl.Item("Enabled") = frm.Enabled - tbControl.Item("Appearance") = IIf(frm.SpecialEffect = 0, "vbAppearFlat", "vbAppear3D") - If useVBAFont Then SetFontProperties tbControl, frm - tbControl.Item("BackColor") = frm.BackColor - tbControl.Item("ForeColor") = frm.ForeColor - tbControl.Item("Name") = userForm.Name - - 'If frm.BorderStyle = fmBorderStyleSingle Then tbControl.Item("BorderStyle") = "vbFixedSingle" - tbControl.Item("BorderStyle") = "vbFixedSingle" - - 'there's a bug in VBA where frm.Caption returns vbNullString - 'see https://stackoverflow.com/questions/65957774/whats-wrong-with-userform-caption - 'tbControl.Item("Caption") = frm.Caption - tbControl.Item("Caption") = userForm.Properties("Caption") - - tbControl.Item("ScaleMode") = "vbTwips" - tbControl.Item("ScaleTop") = 0 - tbControl.Item("ScaleLeft") = 0 - tbControl.Item("ScaleHeight") = frm.InsideHeight * 20 - tbControl.Item("ScaleWidth") = frm.InsideWidth * 20 - - tbControl.Item("MousePointer") = GetMousePointerString(frm.MousePointer) - - If frm.MouseIcon <> 0 Then - tbControl.Item("MouseIcon") = GetImageString(frm.MouseIcon) - End If - - tbControl.Item("FormDesignerId") = "{" & guid & "}" - - 'UserForms don't have a min and max buttons - tbControl.Item("MaxButton") = False - tbControl.Item("MinButton") = False - If Use3DAppearance Then tbControl.Item("Appearance") = vbAppear3d Else tbControl.Item("Appearance") = vbAppearFlat - If frm.Picture IsNot Nothing Then tbControl.Item("Picture") = GetImageString(frm.Picture) - 'UserForms do not have an Icon box on the title bar... - If hideIconBox Then tbControl.Item("Icon") = GetTransparentIconString() - End Sub - - Private Function ReadControlJson(ByVal controlType As String) As String - ReadControlJson = StrConv(LoadResDataInternal(controlType & ".json", "CONTROLS"), VbStrConv.vbFromUTF8) - End Function - - Private Sub SaveControlImagesToFile(ctl As Object, ByVal folderPath As String, ByVal dialogName As String, ByRef imageCount As Long) - Dim fileExt As String - Dim ctlTypeName As String - Dim ctlPicType As Long - - ctlTypeName = TypeName(ctl) - Select Case ctlTypeName - Case "CheckBox", "CommandButton", "OptionButton", "ToggleButton", "Image" - If ctlTypeName = "Image" AndAlso ctl.Picture Is Nothing Then - ctlPicType = vbPicTypeNone - Else - ctlPicType = ctl.Picture.Type - End If - If ctlPicType <> vbPicTypeNone Then - 'has Picture and MouseIcon - fileExt = GetPictureFileExtension(ctlPicType) - SavePicture ctl.Picture, folderPath & "\" & dialogName & "_" & ctl.name & "_Picture" & fileExt - imageCount = imageCount + 1 - End If - Case "ComboBox", "Frame", "ScrollBar", "Label", "ListBox", "TextBox", "SpinButton" - 'has no picture - only MouseIcon - '*frame has Picture property in Userform but not in tB form yet - End Select - - If ctl.MouseIcon <> vbPicTypeNone Then - SavePicture ctl.MouseIcon, folderPath & "\" & dialogName & "_" & ctl.name & "_MouseIcon" & ".ico" - imageCount = imageCount + 1 - End If - End Sub - - Private Sub SaveFormImagesToFile(userForm As VBComponent, ByVal folderPath As String, ByRef imageCount As Long) - Dim frm As Object - Dim dialogName As String - Dim fileExt As String - Set frm = userForm.Designer - dialogName = userForm.Name - - If frm.Picture IsNot Nothing Then - fileExt = GetPictureFileExtension(frm.Picture.Type) - SavePicture frm.Picture, folderPath & "\" & dialogName & "_" & "Form_Picture" & fileExt - imageCount = imageCount + 1 - End If - - If frm.MouseIcon <> vbPicTypeNone Then - SavePicture frm.MouseIcon, folderPath & "\" & dialogName & "_" & "Form_MouseIcon" & ".ico" - imageCount = imageCount + 1 - End If - End Sub - - Private Function GetPictureFileExtension(ByVal picType As PictureTypeConstants) As String - Select Case picType - Case vbPicTypeBitmap - GetPictureFileExtension = ".bmp" - Case vbPicTypeIcon - GetPictureFileExtension = ".ico" - Case vbPicTypeMetafile - GetPictureFileExtension = ".wmf" - Case vbPicTypeEMetafile - GetPictureFileExtension = ".emf" - End Select - End Function - -End Module \ No newline at end of file diff --git a/Sources/ImageProcessing.twin b/Sources/ImageProcessing.twin deleted file mode 100644 index 52af9d5..0000000 --- a/Sources/ImageProcessing.twin +++ /dev/null @@ -1,93 +0,0 @@ -' ========================================================================== -' tBUserFormConverter v2.8 -' -' A VBIDE add-in (complied with twinBASIC) that converts VBA UserForms for use in twinBASIC. -' -' https://github.com/GCuser99/VBA-UserForm-to-twinBASIC -' -' Contact Info: -' -' https://github.com/GCUser99 -' ========================================================================== -' MIT License -' -' Copyright (c) 2023-2024, GCUser99 (https://github.com/GCuser99/VBA-UserForm-to-twinBASIC) -' -' Permission is hereby granted, free of charge, to any person obtaining a copy -' of this software and associated documentation files (the "Software"), to deal -' in the Software without restriction, including without limitation the rights -' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -' copies of the Software, and to permit persons to whom the Software is -' furnished to do so, subject to the following conditions: -' -' The above copyright notice and this permission notice shall be included in all -' copies or substantial portions of the Software. -' -' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -' SOFTWARE. -' ========================================================================== - -Module ImageProcessing - Option Explicit - - 'Note: The below declarations are not needed if reference set to Windows Development Library Package - '/* - Private DeclareWide PtrSafe Function CryptBinaryToString Lib "crypt32" Alias "CryptBinaryToStringW" (pbBinary As Any, ByVal cbBinary As Long, ByVal dwFlags As CRYPT_STRING_OPTIONS, ByVal pszString As String, pcchString As Long) As BOOL - - 'https://learn.microsoft.com/en-us/windows/win32/api/wincrypt/nf-wincrypt-cryptbinarytostringa - Public Enum CRYPT_STRING_OPTIONS - CRYPT_STRING_BASE64 = &H00000001 'Base64, without headers. - CRYPT_STRING_NOCRLF = &H40000000 'Do not append any new line characters to the encoded string. - End Enum - - Public Enum BOOL - CFALSE - CTRUE - End Enum - - 'this one is from VBRUN.Constants and so not needed - Public Enum PictureTypeConstants - vbPicTypeNone = 0 - vbPicTypeBitmap = 1 - vbPicTypeMetafile = 2 - vbPicTypeIcon = 3 - vbPicTypeEMetafile = 4 - End Enum - '*/ - - Public Function GetImageString(pic As stdole.IPictureDisp) As String - Dim bytes() As Byte - bytes = PictureToByteArray(pic) - GetImageString = ToBase64Array(bytes) - End Function - - Public Function GetTransparentIconString() As String - 'used to hide the icon box on the form title bar - Dim bytes() As Byte - bytes = LoadResData("Transparent_16.ico", "IMAGES") - GetTransparentIconString = ToBase64Array(bytes) - End Function - - Public Function GetImageFromResources(ByVal resourceId As Variant, ByVal resourceFolder As Variant) As StdPicture - Dim bytes() As Byte - bytes = LoadResData(resourceId, resourceFolder) - Return Global.LoadPicture(bytes) - End Function - - Private Function ToBase64Array(bytes() As Byte) As String - 'https://gist.github.com/wqweto/0002b7e6c4f92e69c8e8339ed2235b4c - Dim lSize As Long - If UBound(bytes) >= 0 Then - ToBase64Array = String$(2 * UBound(bytes) + 6, 0) - lSize = Len(ToBase64Array) + 1 - Call CryptBinaryToString(bytes(0), UBound(bytes) + 1, CRYPT_STRING_BASE64 Or CRYPT_STRING_NOCRLF, ToBase64Array, lSize) - ToBase64Array = Left$(ToBase64Array, lSize) - End If - End Function - -End Module \ No newline at end of file diff --git a/Sources/JsonConverter.bas b/Sources/JsonConverter.bas deleted file mode 100644 index b087cbb..0000000 --- a/Sources/JsonConverter.bas +++ /dev/null @@ -1,1128 +0,0 @@ -Attribute VB_Name = "JsonConverter" -'' -' VBA-JSON v2.3.1 -' (c) Tim Hall - https://github.com/VBA-tools/VBA-JSON -' -' JSON Converter for VBA -' -' Errors: -' 10001 - JSON parse error -' -' @class JsonConverter -' @author tim.hall.engr@gmail.com -' @license MIT (http://www.opensource.org/licenses/mit-license.php) -'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' -' -' Based originally on vba-json (with extensive changes) -' BSD license included below -' -' JSONLib, http://code.google.com/p/vba-json/ -' -' Copyright (c) 2013, Ryo Yokoyama -' All rights reserved. -' -' Redistribution and use in source and binary forms, with or without -' modification, are permitted provided that the following conditions are met: -' * Redistributions of source code must retain the above copyright -' notice, this list of conditions and the following disclaimer. -' * Redistributions in binary form must reproduce the above copyright -' notice, this list of conditions and the following disclaimer in the -' documentation and/or other materials provided with the distribution. -' * Neither the name of the nor the -' names of its contributors may be used to endorse or promote products -' derived from this software without specific prior written permission. -' -' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -' ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -' DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY -' DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -' (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -' LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND -' ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -' SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' -Option Explicit - -' === VBA-UTC Headers -#If Mac Then - -#If VBA7 Then - -' 64-bit Mac (2016) -Private Declare PtrSafe Function utc_popen Lib "/usr/lib/libc.dylib" Alias "popen" _ - (ByVal utc_Command As String, ByVal utc_Mode As String) As LongPtr -Private Declare PtrSafe Function utc_pclose Lib "/usr/lib/libc.dylib" Alias "pclose" _ - (ByVal utc_File As LongPtr) As LongPtr -Private Declare PtrSafe Function utc_fread Lib "/usr/lib/libc.dylib" Alias "fread" _ - (ByVal utc_Buffer As String, ByVal utc_Size As LongPtr, ByVal utc_Number As LongPtr, ByVal utc_File As LongPtr) As LongPtr -Private Declare PtrSafe Function utc_feof Lib "/usr/lib/libc.dylib" Alias "feof" _ - (ByVal utc_File As LongPtr) As LongPtr - -#Else - -' 32-bit Mac -Private Declare Function utc_popen Lib "libc.dylib" Alias "popen" _ - (ByVal utc_Command As String, ByVal utc_Mode As String) As Long -Private Declare Function utc_pclose Lib "libc.dylib" Alias "pclose" _ - (ByVal utc_File As Long) As Long -Private Declare Function utc_fread Lib "libc.dylib" Alias "fread" _ - (ByVal utc_Buffer As String, ByVal utc_Size As Long, ByVal utc_Number As Long, ByVal utc_File As Long) As Long -Private Declare Function utc_feof Lib "libc.dylib" Alias "feof" _ - (ByVal utc_File As Long) As Long - -#End If - -#ElseIf VBA7 Then - -' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724421.aspx -' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724949.aspx -' http://msdn.microsoft.com/en-us/library/windows/desktop/ms725485.aspx -Private Declare PtrSafe Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ - (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long -Private Declare PtrSafe Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ - (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long -Private Declare PtrSafe Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ - (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long - -#Else - -Private Declare Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ - (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long -Private Declare Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ - (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long -Private Declare Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ - (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long - -#End If - -#If Mac Then - -#If VBA7 Then -Private Type utc_ShellResult - utc_Output As String - utc_ExitCode As LongPtr -End Type - -#Else - -Private Type utc_ShellResult - utc_Output As String - utc_ExitCode As Long -End Type - -#End If - -#Else - -Private Type utc_SYSTEMTIME - utc_wYear As Integer - utc_wMonth As Integer - utc_wDayOfWeek As Integer - utc_wDay As Integer - utc_wHour As Integer - utc_wMinute As Integer - utc_wSecond As Integer - utc_wMilliseconds As Integer -End Type - -Private Type utc_TIME_ZONE_INFORMATION - utc_Bias As Long - utc_StandardName(0 To 31) As Integer - utc_StandardDate As utc_SYSTEMTIME - utc_StandardBias As Long - utc_DaylightName(0 To 31) As Integer - utc_DaylightDate As utc_SYSTEMTIME - utc_DaylightBias As Long -End Type - -#End If -' === End VBA-UTC - -Private Type json_Options - ' VBA only stores 15 significant digits, so any numbers larger than that are truncated - ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits - ' See: http://support.microsoft.com/kb/269370 - ' - ' By default, VBA-JSON will use String for numbers longer than 15 characters that contain only digits - ' to override set `JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True` - UseDoubleForLargeNumbers As Boolean - - ' The JSON standard requires object keys to be quoted (" or '), use this option to allow unquoted keys - AllowUnquotedKeys As Boolean - - ' The solidus (/) is not required to be escaped, use this option to escape them as \/ in ConvertToJson - EscapeSolidus As Boolean - - 'Added by GCUser99 - default is not to convert, as WebDriver server can handle Unicode characters - ConvertUnicodeToEscapedString As Boolean -End Type -Public JsonOptions As json_Options - -' ============================================= ' -' Public Methods -' ============================================= ' - -'' -' Convert JSON string to object (Dictionary/Collection) -' -' @method ParseJson -' @param {String} json_String -' @return {Object} (Dictionary or Collection) -' @throws 10001 - JSON parse error -'' -Public Function ParseJson(ByVal JsonString As String) As Object - Dim json_Index As Long - json_Index = 1 - - ' Remove vbCr, vbLf, and vbTab from json_String - JsonString = VBA.Replace(VBA.Replace(VBA.Replace(JsonString, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "") - - json_SkipSpaces JsonString, json_Index - Select Case VBA.Mid$(JsonString, json_Index, 1) - Case "{" - Set ParseJson = json_ParseObject(JsonString, json_Index) - Case "[" - Set ParseJson = json_ParseArray(JsonString, json_Index) - Case Else - ' Error: Invalid JSON string - Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(JsonString, json_Index, "Expecting '{' or '['") - End Select -End Function - -'' -' Convert object (Dictionary/Collection/Array) to JSON -' -' @method ConvertToJson -' @param {Variant} JsonValue (Dictionary, Collection, or Array) -' @param {Integer|String} Whitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string -' @return {String} -'' -Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String - Dim json_Buffer As String - Dim json_BufferPosition As Long - Dim json_BufferLength As Long - Dim json_Index As Long - Dim json_LBound As Long - Dim json_UBound As Long - Dim json_IsFirstItem As Boolean - Dim json_Index2D As Long - Dim json_LBound2D As Long - Dim json_UBound2D As Long - Dim json_IsFirstItem2D As Boolean - Dim json_Key As Variant - Dim json_Value As Variant - Dim json_DateStr As String - Dim json_Converted As String - Dim json_SkipItem As Boolean - Dim json_PrettyPrint As Boolean - Dim json_Indentation As String - Dim json_InnerIndentation As String - - json_LBound = -1 - json_UBound = -1 - json_IsFirstItem = True - json_LBound2D = -1 - json_UBound2D = -1 - json_IsFirstItem2D = True - json_PrettyPrint = Not IsMissing(Whitespace) - - Select Case VBA.VarType(JsonValue) - Case VBA.vbNull - ConvertToJson = "null" - Case VBA.vbDate - ' Date - json_DateStr = ConvertToIso(VBA.CDate(JsonValue)) - - ConvertToJson = """" & json_DateStr & """" - Case VBA.vbString - ' String (or large number encoded as string) - If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then - ConvertToJson = JsonValue - Else - ConvertToJson = """" & json_Encode(JsonValue) & """" - End If - Case VBA.vbBoolean - If JsonValue Then - ConvertToJson = "true" - Else - ConvertToJson = "false" - End If - Case VBA.vbArray To VBA.vbArray + VBA.vbByte - If json_PrettyPrint Then - If VBA.VarType(Whitespace) = VBA.vbString Then - json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) - json_InnerIndentation = VBA.String$(json_CurrentIndentation + 2, Whitespace) - Else - json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) - json_InnerIndentation = VBA.Space$((json_CurrentIndentation + 2) * Whitespace) - End If - End If - - ' Array - json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength - - On Error Resume Next - - json_LBound = LBound(JsonValue, 1) - json_UBound = UBound(JsonValue, 1) - json_LBound2D = LBound(JsonValue, 2) - json_UBound2D = UBound(JsonValue, 2) - - If json_LBound >= 0 And json_UBound >= 0 Then - For json_Index = json_LBound To json_UBound - If json_IsFirstItem Then - json_IsFirstItem = False - Else - ' Append comma to previous line - json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength - End If - - If json_LBound2D >= 0 And json_UBound2D >= 0 Then - ' 2D Array - If json_PrettyPrint Then - json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength - End If - json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength - - For json_Index2D = json_LBound2D To json_UBound2D - If json_IsFirstItem2D Then - json_IsFirstItem2D = False - Else - json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength - End If - - json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2) - - ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null - If json_Converted = "" Then - ' (nest to only check if converted = "") - If json_IsUndefined(JsonValue(json_Index, json_Index2D)) Then - json_Converted = "null" - End If - End If - - If json_PrettyPrint Then - json_Converted = vbNewLine & json_InnerIndentation & json_Converted - End If - - json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength - Next json_Index2D - - If json_PrettyPrint Then - json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength - End If - - json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength - json_IsFirstItem2D = True - Else - ' 1D Array - json_Converted = ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1) - - ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null - If json_Converted = "" Then - ' (nest to only check if converted = "") - If json_IsUndefined(JsonValue(json_Index)) Then - json_Converted = "null" - End If - End If - - If json_PrettyPrint Then - json_Converted = vbNewLine & json_Indentation & json_Converted - End If - - json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength - End If - Next json_Index - End If - - On Error GoTo 0 - - If json_PrettyPrint Then - json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength - - If VBA.VarType(Whitespace) = VBA.vbString Then - json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) - Else - json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) - End If - End If - - json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength - - ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) - - ' Dictionary or Collection - Case VBA.vbObject - If json_PrettyPrint Then - If VBA.VarType(Whitespace) = VBA.vbString Then - json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) - Else - json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) - End If - End If - - ' Dictionary - If VBA.TypeName(JsonValue) = "Dictionary" Then - json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength - For Each json_Key In JsonValue.Keys - ' For Objects, undefined (Empty/Nothing) is not added to object - json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1) - If json_Converted = "" Then - json_SkipItem = json_IsUndefined(JsonValue(json_Key)) - Else - json_SkipItem = False - End If - - If Not json_SkipItem Then - If json_IsFirstItem Then - json_IsFirstItem = False - Else - json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength - End If - - If json_PrettyPrint Then - json_Converted = vbNewLine & json_Indentation & """" & json_Key & """: " & json_Converted - Else - json_Converted = """" & json_Key & """:" & json_Converted - End If - - json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength - End If - Next json_Key - - If json_PrettyPrint Then - json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength - - If VBA.VarType(Whitespace) = VBA.vbString Then - json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) - Else - json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) - End If - End If - - json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength - - ' Collection - ElseIf VBA.TypeName(JsonValue) = "Collection" Then - json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength - For Each json_Value In JsonValue - If json_IsFirstItem Then - json_IsFirstItem = False - Else - json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength - End If - - json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1) - - ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null - If json_Converted = "" Then - ' (nest to only check if converted = "") - If json_IsUndefined(json_Value) Then - json_Converted = "null" - End If - End If - - If json_PrettyPrint Then - json_Converted = vbNewLine & json_Indentation & json_Converted - End If - - json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength - Next json_Value - - If json_PrettyPrint Then - json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength - - If VBA.VarType(Whitespace) = VBA.vbString Then - json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) - Else - json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) - End If - End If - - json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength - End If - - ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) - Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal - ' Number (use decimals for numbers) - ConvertToJson = VBA.Replace(JsonValue, ",", ".") - Case Else - ' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType - ' Use VBA's built-in to-string - On Error Resume Next - ConvertToJson = JsonValue - On Error GoTo 0 - End Select -End Function - -' ============================================= ' -' Private Functions -' ============================================= ' - -Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary - Dim json_Key As String - Dim json_NextChar As String - - Set json_ParseObject = New Dictionary - json_SkipSpaces json_String, json_Index - If VBA.Mid$(json_String, json_Index, 1) <> "{" Then - Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'") - Else - json_Index = json_Index + 1 - - Do - json_SkipSpaces json_String, json_Index - If VBA.Mid$(json_String, json_Index, 1) = "}" Then - json_Index = json_Index + 1 - Exit Function - ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then - json_Index = json_Index + 1 - json_SkipSpaces json_String, json_Index - End If - - json_Key = json_ParseKey(json_String, json_Index) - json_NextChar = json_Peek(json_String, json_Index) - If json_NextChar = "[" Or json_NextChar = "{" Then - Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) - Else - json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) - End If - Loop - End If -End Function - -Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection - Set json_ParseArray = New Collection - - json_SkipSpaces json_String, json_Index - If VBA.Mid$(json_String, json_Index, 1) <> "[" Then - Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '['") - Else - json_Index = json_Index + 1 - - Do - json_SkipSpaces json_String, json_Index - If VBA.Mid$(json_String, json_Index, 1) = "]" Then - json_Index = json_Index + 1 - Exit Function - ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then - json_Index = json_Index + 1 - json_SkipSpaces json_String, json_Index - End If - - json_ParseArray.Add json_ParseValue(json_String, json_Index) - Loop - End If -End Function - -Private Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant - json_SkipSpaces json_String, json_Index - Select Case VBA.Mid$(json_String, json_Index, 1) - Case "{" - Set json_ParseValue = json_ParseObject(json_String, json_Index) - Case "[" - Set json_ParseValue = json_ParseArray(json_String, json_Index) - Case """", "'" - json_ParseValue = json_ParseString(json_String, json_Index) - Case Else - If VBA.Mid$(json_String, json_Index, 4) = "true" Then - json_ParseValue = True - json_Index = json_Index + 4 - ElseIf VBA.Mid$(json_String, json_Index, 5) = "false" Then - json_ParseValue = False - json_Index = json_Index + 5 - ElseIf VBA.Mid$(json_String, json_Index, 4) = "null" Then - json_ParseValue = Null - json_Index = json_Index + 4 - ElseIf VBA.InStr("+-0123456789", VBA.Mid$(json_String, json_Index, 1)) Then - json_ParseValue = json_ParseNumber(json_String, json_Index) - Else - Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['") - End If - End Select -End Function - -Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String - Dim json_Quote As String - Dim json_Char As String - Dim json_Code As String - Dim json_Buffer As String - Dim json_BufferPosition As Long - Dim json_BufferLength As Long - - json_SkipSpaces json_String, json_Index - - ' Store opening quote to look for matching closing quote - json_Quote = VBA.Mid$(json_String, json_Index, 1) - json_Index = json_Index + 1 - - Do While json_Index > 0 And json_Index <= Len(json_String) - json_Char = VBA.Mid$(json_String, json_Index, 1) - - Select Case json_Char - Case "\" - ' Escaped string, \\, or \/ - json_Index = json_Index + 1 - json_Char = VBA.Mid$(json_String, json_Index, 1) - - Select Case json_Char - Case """", "\", "/", "'" - json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength - json_Index = json_Index + 1 - Case "b" - json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength - json_Index = json_Index + 1 - Case "f" - json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength - json_Index = json_Index + 1 - Case "n" - json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength - json_Index = json_Index + 1 - Case "r" - json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength - json_Index = json_Index + 1 - Case "t" - json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength - json_Index = json_Index + 1 - Case "u" - ' Unicode character escape (e.g. \u00a9 = Copyright) - json_Index = json_Index + 1 - json_Code = VBA.Mid$(json_String, json_Index, 4) - json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength - json_Index = json_Index + 4 - End Select - Case json_Quote - json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition) - json_Index = json_Index + 1 - Exit Function - Case Else - json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength - json_Index = json_Index + 1 - End Select - Loop -End Function - -Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant - Dim json_Char As String - Dim json_Value As String - Dim json_IsLargeNumber As Boolean - - json_SkipSpaces json_String, json_Index - - Do While json_Index > 0 And json_Index <= Len(json_String) - json_Char = VBA.Mid$(json_String, json_Index, 1) - - If VBA.InStr("+-0123456789.eE", json_Char) Then - ' Unlikely to have massive number, so use simple append rather than buffer here - json_Value = json_Value & json_Char - json_Index = json_Index + 1 - Else - ' Excel only stores 15 significant digits, so any numbers larger than that are truncated - ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits - ' See: http://support.microsoft.com/kb/269370 - ' - ' Fix: Parse -> String, Convert -> String longer than 15/16 characters containing only numbers and decimal points -> Number - ' (decimal doesn't factor into significant digit count, so if present check for 15 digits + decimal = 16) - json_IsLargeNumber = IIf(InStr(json_Value, "."), Len(json_Value) >= 17, Len(json_Value) >= 16) - If Not JsonOptions.UseDoubleForLargeNumbers And json_IsLargeNumber Then - json_ParseNumber = json_Value - Else - ' VBA.Val does not use regional settings, so guard for comma is not needed - json_ParseNumber = VBA.Val(json_Value) - End If - Exit Function - End If - Loop -End Function - -Private Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String - ' Parse key with single or double quotes - If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "'" Then - json_ParseKey = json_ParseString(json_String, json_Index) - ElseIf JsonOptions.AllowUnquotedKeys Then - Dim json_Char As String - Do While json_Index > 0 And json_Index <= Len(json_String) - json_Char = VBA.Mid$(json_String, json_Index, 1) - If (json_Char <> " ") And (json_Char <> ":") Then - json_ParseKey = json_ParseKey & json_Char - json_Index = json_Index + 1 - Else - Exit Do - End If - Loop - Else - Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '""' or '''") - End If - - ' Check for colon and skip if present or throw if not present - json_SkipSpaces json_String, json_Index - If VBA.Mid$(json_String, json_Index, 1) <> ":" Then - Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting ':'") - Else - json_Index = json_Index + 1 - End If -End Function - -Private Function json_IsUndefined(ByVal json_Value As Variant) As Boolean - ' Empty / Nothing -> undefined - Select Case VBA.VarType(json_Value) - Case VBA.vbEmpty - json_IsUndefined = True - Case VBA.vbObject - Select Case VBA.TypeName(json_Value) - Case "Empty", "Nothing" - json_IsUndefined = True - End Select - End Select -End Function - -Private Function json_Encode(ByVal json_Text As Variant) As String - ' Reference: http://www.ietf.org/rfc/rfc4627.txt - ' Escape: ", \, /, backspace, form feed, line feed, carriage return, tab - Dim json_Index As Long - Dim json_Char As String - Dim json_AscCode As Long - Dim json_Buffer As String - Dim json_BufferPosition As Long - Dim json_BufferLength As Long - - For json_Index = 1 To VBA.Len(json_Text) - json_Char = VBA.Mid$(json_Text, json_Index, 1) - json_AscCode = VBA.AscW(json_Char) - - ' When AscW returns a negative number, it returns the twos complement form of that number. - ' To convert the twos complement notation into normal binary notation, add 0xFFF to the return result. - ' https://support.microsoft.com/en-us/kb/272138 - If json_AscCode < 0 Then - json_AscCode = json_AscCode + 65536 - End If - - ' From spec, ", \, and control characters must be escaped (solidus is optional) - - Select Case json_AscCode - Case 34 - ' " -> 34 -> \" - json_Char = "\""" - Case 92 - ' \ -> 92 -> \\ - json_Char = "\\" - Case 47 - ' / -> 47 -> \/ (optional) - If JsonOptions.EscapeSolidus Then - json_Char = "\/" - End If - Case 8 - ' backspace -> 8 -> \b - json_Char = "\b" - Case 12 - ' form feed -> 12 -> \f - json_Char = "\f" - Case 10 - ' line feed -> 10 -> \n - json_Char = "\n" - Case 13 - ' carriage return -> 13 -> \r - json_Char = "\r" - Case 9 - ' tab -> 9 -> \t - json_Char = "\t" - Case 0 To 31, 127 To 65535 - If JsonOptions.ConvertUnicodeToEscapedString Then - ' Non-ascii characters -> convert to 4-digit hex - json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4) - End If - End Select - - json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength - Next json_Index - - json_Encode = json_BufferToString(json_Buffer, json_BufferPosition) -End Function - -Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String - ' "Peek" at the next number of characters without incrementing json_Index (ByVal instead of ByRef) - json_SkipSpaces json_String, json_Index - json_Peek = VBA.Mid$(json_String, json_Index, json_NumberOfCharacters) -End Function - -Private Sub json_SkipSpaces(json_String As String, ByRef json_Index As Long) - ' Increment index to skip over spaces - Do While json_Index > 0 And json_Index <= VBA.Len(json_String) And VBA.Mid$(json_String, json_Index, 1) = " " - json_Index = json_Index + 1 - Loop -End Sub - -Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean - ' Check if the given string is considered a "large number" - ' (See json_ParseNumber) - - Dim json_Length As Long - Dim json_CharIndex As Long - json_Length = VBA.Len(json_String) - - ' Length with be at least 16 characters and assume will be less than 100 characters - If json_Length >= 16 And json_Length <= 100 Then - Dim json_CharCode As String - - json_StringIsLargeNumber = True - - For json_CharIndex = 1 To json_Length - json_CharCode = VBA.Asc(VBA.Mid$(json_String, json_CharIndex, 1)) - Select Case json_CharCode - ' Look for .|0-9|E|e - Case 46, 48 To 57, 69, 101 - ' Continue through characters - Case Else - json_StringIsLargeNumber = False - Exit Function - End Select - Next json_CharIndex - End If -End Function - -Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index As Long, ErrorMessage As String) As Variant - ' Provide detailed parse error message, including details of where and what occurred - ' - ' Example: - ' Error parsing JSON: - ' {"abcde":True} - ' ^ - ' Expecting 'STRING', 'NUMBER', null, true, false, '{', or '[' - - Dim json_StartIndex As Long - Dim json_StopIndex As Long - - ' Include 10 characters before and after error (if possible) - json_StartIndex = json_Index - 10 - json_StopIndex = json_Index + 10 - If json_StartIndex <= 0 Then - json_StartIndex = 1 - End If - If json_StopIndex > VBA.Len(json_String) Then - json_StopIndex = VBA.Len(json_String) - End If - - json_ParseErrorMessage = "Error parsing JSON:" & VBA.vbNewLine & _ - VBA.Mid$(json_String, json_StartIndex, json_StopIndex - json_StartIndex + 1) & VBA.vbNewLine & _ - VBA.Space$(json_Index - json_StartIndex) & "^" & VBA.vbNewLine & _ - ErrorMessage -End Function - -Private Sub json_BufferAppend(ByRef json_Buffer As String, _ - ByRef json_Append As Variant, _ - ByRef json_BufferPosition As Long, _ - ByRef json_BufferLength As Long) - ' VBA can be slow to append strings due to allocating a new string for each append - ' Instead of using the traditional append, allocate a large empty string and then copy string at append position - ' - ' Example: - ' Buffer: "abc " - ' Append: "def" - ' Buffer Position: 3 - ' Buffer Length: 5 - ' - ' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer - ' Buffer: "abc " - ' Buffer Length: 10 - ' - ' Put "def" into buffer at position 3 (0-based) - ' Buffer: "abcdef " - ' - ' Approach based on cStringBuilder from vbAccelerator - ' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp - ' - ' and clsStringAppend from Philip Swannell - ' https://github.com/VBA-tools/VBA-JSON/pull/82 - - Dim json_AppendLength As Long - Dim json_LengthPlusPosition As Long - - json_AppendLength = VBA.Len(json_Append) - json_LengthPlusPosition = json_AppendLength + json_BufferPosition - - If json_LengthPlusPosition > json_BufferLength Then - ' Appending would overflow buffer, add chunk - ' (double buffer length or append length, whichever is bigger) - Dim json_AddedLength As Long - json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength) - - json_Buffer = json_Buffer & VBA.Space$(json_AddedLength) - json_BufferLength = json_BufferLength + json_AddedLength - End If - - ' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error: - ' Function call on left-hand side of assignment must return Variant or Object - Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append) - json_BufferPosition = json_BufferPosition + json_AppendLength -End Sub - -Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long) As String - If json_BufferPosition > 0 Then - json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition) - End If -End Function - -'' -' VBA-UTC v1.0.6 -' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter -' -' UTC/ISO 8601 Converter for VBA -' -' Errors: -' 10011 - UTC parsing error -' 10012 - UTC conversion error -' 10013 - ISO 8601 parsing error -' 10014 - ISO 8601 conversion error -' -' @module UtcConverter -' @author tim.hall.engr@gmail.com -' @license MIT (http://www.opensource.org/licenses/mit-license.php) -'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' - -' (Declarations moved to top) - -' ============================================= ' -' Public Methods -' ============================================= ' - -'' -' Parse UTC date to local date -' -' @method ParseUtc -' @param {Date} UtcDate -' @return {Date} Local date -' @throws 10011 - UTC parsing error -'' -Public Function ParseUtc(utc_UtcDate As Date) As Date - On Error GoTo utc_ErrorHandling - -#If Mac Then - ParseUtc = utc_ConvertDate(utc_UtcDate) -#Else - Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION - Dim utc_LocalDate As utc_SYSTEMTIME - - utc_GetTimeZoneInformation utc_TimeZoneInfo - utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate - - ParseUtc = utc_SystemTimeToDate(utc_LocalDate) -#End If - - Exit Function - -utc_ErrorHandling: - Err.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description -End Function - -'' -' Convert local date to UTC date -' -' @method ConvertToUrc -' @param {Date} utc_LocalDate -' @return {Date} UTC date -' @throws 10012 - UTC conversion error -'' -Public Function ConvertToUtc(utc_LocalDate As Date) As Date - On Error GoTo utc_ErrorHandling - -#If Mac Then - ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True) -#Else - Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION - Dim utc_UtcDate As utc_SYSTEMTIME - - utc_GetTimeZoneInformation utc_TimeZoneInfo - utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate - - ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate) -#End If - - Exit Function - -utc_ErrorHandling: - Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description -End Function - -'' -' Parse ISO 8601 date string to local date -' -' @method ParseIso -' @param {Date} utc_IsoString -' @return {Date} Local date -' @throws 10013 - ISO 8601 parsing error -'' -Public Function ParseIso(utc_IsoString As String) As Date - On Error GoTo utc_ErrorHandling - - Dim utc_Parts() As String - Dim utc_DateParts() As String - Dim utc_TimeParts() As String - Dim utc_OffsetIndex As Long - Dim utc_HasOffset As Boolean - Dim utc_NegativeOffset As Boolean - Dim utc_OffsetParts() As String - Dim utc_Offset As Date - - utc_Parts = VBA.Split(utc_IsoString, "T") - utc_DateParts = VBA.Split(utc_Parts(0), "-") - ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2))) - - If UBound(utc_Parts) > 0 Then - If VBA.InStr(utc_Parts(1), "Z") Then - utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":") - Else - utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+") - If utc_OffsetIndex = 0 Then - utc_NegativeOffset = True - utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-") - End If - - If utc_OffsetIndex > 0 Then - utc_HasOffset = True - utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":") - utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":") - - Select Case UBound(utc_OffsetParts) - Case 0 - utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0) - Case 1 - utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0) - Case 2 - ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues - utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2)))) - End Select - - If utc_NegativeOffset Then: utc_Offset = -utc_Offset - Else - utc_TimeParts = VBA.Split(utc_Parts(1), ":") - End If - End If - - Select Case UBound(utc_TimeParts) - Case 0 - ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0) - Case 1 - ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0) - Case 2 - ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues - ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2)))) - End Select - - ParseIso = ParseUtc(ParseIso) - - If utc_HasOffset Then - ParseIso = ParseIso - utc_Offset - End If - End If - - Exit Function - -utc_ErrorHandling: - Err.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & Err.Number & " - " & Err.Description -End Function - -'' -' Convert local date to ISO 8601 string -' -' @method ConvertToIso -' @param {Date} utc_LocalDate -' @return {Date} ISO 8601 string -' @throws 10014 - ISO 8601 conversion error -'' -Public Function ConvertToIso(utc_LocalDate As Date) As String - On Error GoTo utc_ErrorHandling - - ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z") - - Exit Function - -utc_ErrorHandling: - Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description -End Function - -' ============================================= ' -' Private Functions -' ============================================= ' - -#If Mac Then - -Private Function utc_ConvertDate(utc_Value As Date, Optional utc_ConvertToUtc As Boolean = False) As Date - Dim utc_ShellCommand As String - Dim utc_Result As utc_ShellResult - Dim utc_Parts() As String - Dim utc_DateParts() As String - Dim utc_TimeParts() As String - - If utc_ConvertToUtc Then - utc_ShellCommand = "date -ur `date -jf '%Y-%m-%d %H:%M:%S' " & _ - "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & "' " & _ - " +'%s'` +'%Y-%m-%d %H:%M:%S'" - Else - utc_ShellCommand = "date -jf '%Y-%m-%d %H:%M:%S %z' " & _ - "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & " +0000' " & _ - "+'%Y-%m-%d %H:%M:%S'" - End If - - utc_Result = utc_ExecuteInShell(utc_ShellCommand) - - If utc_Result.utc_Output = "" Then - Err.Raise 10015, "UtcConverter.utc_ConvertDate", "'date' command failed" - Else - utc_Parts = Split(utc_Result.utc_Output, " ") - utc_DateParts = Split(utc_Parts(0), "-") - utc_TimeParts = Split(utc_Parts(1), ":") - - utc_ConvertDate = DateSerial(utc_DateParts(0), utc_DateParts(1), utc_DateParts(2)) + _ - TimeSerial(utc_TimeParts(0), utc_TimeParts(1), utc_TimeParts(2)) - End If -End Function - -Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResult -#If VBA7 Then - Dim utc_File As LongPtr - Dim utc_Read As LongPtr -#Else - Dim utc_File As Long - Dim utc_Read As Long -#End If - - Dim utc_Chunk As String - - On Error GoTo utc_ErrorHandling - utc_File = utc_popen(utc_ShellCommand, "r") - - If utc_File = 0 Then: Exit Function - - Do While utc_feof(utc_File) = 0 - utc_Chunk = VBA.Space$(50) - utc_Read = CLng(utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File)) - If utc_Read > 0 Then - utc_Chunk = VBA.Left$(utc_Chunk, CLng(utc_Read)) - utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk - End If - Loop - -utc_ErrorHandling: - utc_ExecuteInShell.utc_ExitCode = CLng(utc_pclose(utc_File)) -End Function - -#Else - -Private Function utc_DateToSystemTime(utc_Value As Date) As utc_SYSTEMTIME - utc_DateToSystemTime.utc_wYear = VBA.Year(utc_Value) - utc_DateToSystemTime.utc_wMonth = VBA.Month(utc_Value) - utc_DateToSystemTime.utc_wDay = VBA.Day(utc_Value) - utc_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value) - utc_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value) - utc_DateToSystemTime.utc_wSecond = VBA.Second(utc_Value) - utc_DateToSystemTime.utc_wMilliseconds = 0 -End Function - -Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date - utc_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _ - TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond) -End Function - -#End If diff --git a/Sources/ReadMe b/Sources/ReadMe deleted file mode 100644 index 0776482..0000000 --- a/Sources/ReadMe +++ /dev/null @@ -1,15 +0,0 @@ -Application: tBUserFormConverter -Author: GCUser99 -Description: A VBIDE add-in (complied with twinBASIC) that converts VBA UserForms for use in twinBASIC. -Contact Info: GCUser999@gmail.com -Requirements: 64-bit Windows, and either 32- or 64-bit Office 2010 or greater - -Credits: - -Wayne Phillips' twinBASIC Sample 4: MyVBEAddin -Tim Hall's JsonConverter (https://github.com/VBA-tools/VBA-JSON/blob/master/JsonConverter.bas) -Krool's VBCCR (https://github.com/Kr00l/VBCCR) -R. Beltran's ArrayList (https://github.com/Theadd/ArrayList) - -For questions, comments, and issue reports please go to: -https://github.com/GCuser99/VBA-UserForm-to-twinBASIC diff --git a/Sources/dllRegistration.twin b/Sources/dllRegistration.twin deleted file mode 100644 index d9797ab..0000000 --- a/Sources/dllRegistration.twin +++ /dev/null @@ -1,49 +0,0 @@ -Module dllRegistration - 'Do not modify call signatures of functions in this module, as twinBASIC - 'replaces the default reg functions with these... - - 'following are important registry entries - 'Computer\HKEY_CURRENT_USER\Software\Microsoft\VBA\VBE\6.0\Addins\tbUserFormConverter.myAddIn - 'Computer\HKEY_CURRENT_USER\Software\Microsoft\VBA\VBE\6.0\Addins64\tbUserFormConverter.myAddIn - 'Computer\HKEY_CURRENT_USER\Software\VB and VBA Program Settings\tbUserFormConverter\ - - #If Win64 Then - Const AddinsFolder As String = "Addins64" - #Else - Const AddinsFolder As String = "Addins" - #End If - - Const AddinProjectName As String = VBA.Compilation.CurrentProjectName - Const AddinDescription As String = "UserForm to twinBASIC Form Converter" - Const AddinClassName As String = "myAddIn" - Const AddinQualifiedClassName As String = AddinProjectName & "." & AddinClassName - Const RootRegistryFolder As String = "HKCU\SOFTWARE\Microsoft\VBA\VBE\6.0\" & AddinsFolder & "\" & AddinQualifiedClassName & "\" - - Public Function DllRegisterServer() As Boolean - On Error GoTo RegError - Dim wscript As Object = CreateObject("wscript.shell") - wscript.RegWrite RootRegistryFolder & "FriendlyName", AddinProjectName, "REG_SZ" - wscript.RegWrite RootRegistryFolder & "Description", AddinDescription, "REG_SZ" - wscript.RegWrite RootRegistryFolder & "LoadBehavior", 3, "REG_DWORD" - Return True - RegError: - MsgBox "DllRegisterServer -- An error occured trying to write to the system registry:" & vbCrLf & _ - Err.Description & " (" & Hex(Err.Number) & ")" - Return False - End Function - - Public Function DllUnregisterServer() As Boolean - On Error GoTo RegError - Dim wscript As Object = CreateObject("wscript.shell") - wscript.RegDelete RootRegistryFolder & "FriendlyName" - wscript.RegDelete RootRegistryFolder & "Description" - wscript.RegDelete RootRegistryFolder & "LoadBehavior" - wscript.RegDelete RootRegistryFolder - Return True - RegError: - MsgBox "DllUnregisterServer -- An error occured trying to delete from the system registry:" & vbCrLf & _ - Err.Description & " (" & Hex(Err.Number) & ")" - Return False - End Function - -End Module \ No newline at end of file diff --git a/Sources/myAddIn.twin b/Sources/myAddIn.twin deleted file mode 100644 index 786841b..0000000 --- a/Sources/myAddIn.twin +++ /dev/null @@ -1,125 +0,0 @@ -' NOTE: make sure you create a DLL of the correct bitness to match your version of VBA -' (e.g. if you're using the 64-bit version of VBA, make sure you change the active build to 'win64' - -[ClassId("29095D85-F3EE-4D3D-922F-A3B990A9C776")] -[InterfaceId("EDB4AF2E-5890-4BB8-939A-8FF86C493B3A")] -[EventInterfaceId("866F2BF1-6AEB-4BC2-A6DB-7EECF2CFEE66")] -Class myAddIn - - Implements IDTExtensibility2 - - Private vbe As VBIDE.VBE - Private addin As VBIDE.AddIn - Private WithEvents menuItem1Events As VBIDE.CommandBarEvents - Private WithEvents menuItem2Events As VBIDE.CommandBarEvents - Private WithEvents menuItem3Events As VBIDE.CommandBarEvents - Private isConnected As Boolean - - Sub OnConnection(ByVal Application As Object, _ - ByVal ConnectMode As ext_ConnectMode, _ - ByVal AddInInst As Object, _ - ByRef custom As Variant()) _ - Implements IDTExtensibility2.OnConnection - - Set vbe = Application - Set addin = AddInInst - isConnected = True - CreateVBEMenu() - End Sub - - Sub OnDisconnection(ByVal RemoveMode As ext_DisconnectMode, _ - ByRef custom As Variant()) _ - Implements IDTExtensibility2.OnDisconnection - ShutdownAddin() - End Sub - - Sub OnBeginShutdown(ByRef custom As Variant()) _ - Implements IDTExtensibility2.OnBeginShutdown - ShutdownAddin() ' the earlier we release everything back to VBIDE, the better - End Sub - - Sub OnAddInsUpdate(ByRef custom As Variant()) _ - Implements IDTExtensibility2.OnAddInsUpdate - End Sub - - Sub OnStartupComplete(ByRef custom As Variant()) _ - Implements IDTExtensibility2.OnStartupComplete - ' When opening the addin manually (with Load on Startup off), this won't be triggered - End Sub - - Private Sub ShutdownAddin() - If isConnected = False Then Exit Sub - RemoveVBEMenu - Set addin = Nothing - Set vbe = Nothing - Set menuItem1Events = Nothing - Set menuItem2Events = Nothing - Set menuItem3Events = Nothing - isConnected = False - End Sub - - Public Property Get GetVBE() As VBIDE.VBE - Return vbe - End Property - - Private Sub CreateVBEMenu() - Dim menu As CommandBarPopup - Dim menuItem1 As CommandBarButton - Dim menuItem2 As CommandBarButton - Dim menuItem3 As CommandBarButton - - Set menu = vbe.CommandBars("Menu Bar").Controls.Add(Type:=msoControlPopup) - With menu - menu.Caption = "twin&BASIC Tools" - menu.Tag = "twinBASICTools" - Set menuItem1 = .Controls.Add(Type:=msoControlButton) - With menuItem1 - .Caption = "&Convert UserForms" - .Picture = GetImageFromResources("ConvertForms_16.bmp", "IMAGES") - Set menuItem1Events = vbe.Events.CommandBarEvents(menuItem1) - End With - Set menuItem2 = .Controls.Add(Type:=msoControlButton) - With menuItem2 - .Caption = "&Extract Image Resources" - .Picture = GetImageFromResources("ExtractResources_16.bmp", "IMAGES") - Set menuItem2Events = vbe.Events.CommandBarEvents(menuItem2) - End With - Set menuItem3 = .Controls.Add(Type:=msoControlButton) - With menuItem3 - .Caption = "&About" - .Picture = GetImageFromResources("About_16.bmp", "IMAGES") - Set menuItem3Events = vbe.Events.CommandBarEvents(menuItem3) - End With - End With - End Sub - - Private Sub RemoveVBEMenu() - 'also can clean up menu manually in vbide during debugging by rmb click on menu - 'Customize->Menu Bar->Reset - 'vbe.CommandBars("Menu Bar").Reset 'this will clean up all - vbe.CommandBars("Menu Bar").Controls("twinBASIC Tools").Delete - End Sub - - Private Sub menuItem1Events_Click(ByVal CommandBarControl As Object, _ - ByRef Handled As Boolean, ByRef CancelDefault As Boolean) Handles menuItem1Events.Click - ExportUserForm Me.GetVBE().ActiveVBProject - Handled = True - CancelDefault = False - End Sub - - Private Sub menuItem2Events_Click(ByVal CommandBarControl As Object, _ - ByRef Handled As Boolean, ByRef CancelDefault As Boolean) Handles menuItem2Events.Click - ExtractImageResources Me.GetVBE().ActiveVBProject - Handled = True - CancelDefault = False - End Sub - - Private Sub menuItem3Events_Click(ByVal CommandBarControl As Object, _ - ByRef Handled As Boolean, ByRef CancelDefault As Boolean) Handles menuItem3Events.Click - About.Show(vbModal) - Set About = Nothing - Handled = True - CancelDefault = False - End Sub - -End Class \ No newline at end of file