how to use alpha png for buttons，Transparent toolbar Control by vb6

April 9, 2021, 4:30 am

≫ Next: (VB6) Add-In - Move selected controls

≪ Previous: VB6 Png Control,Simple transparent button control For VB6

$

0

0

it's use ImageList1.MaskColor ,how to use alpha png for buttons ?or use api without imagelist control ?

[VB6] ListView / TreeView Extended and Custom Checkboxes-VBForums
https://www.vbforums.com/showthread....tom-Checkboxes

Code:

---


Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwnewlong As Long) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByRef lColorRef As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32.dll" (ByVal hBitmap As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long

Private Const GCL_HBRBACKGROUND As Long = -10

Private Function GDI_TranslateColor(OleClr As OLE_COLOR, Optional hPal As Integer = 0) As Long
    ' used to return the correct color value of OleClr as a long
    If OleTranslateColor(OleClr, hPal, GDI_TranslateColor) Then
        GDI_TranslateColor = &HFFFF&
    End If
End Function

Function GDI_CreateSoildBrush(bColor As OLE_COLOR) As Long
    'Create a Brush form a picture handle
    GDI_CreateSoildBrush = CreateSolidBrush(GDI_TranslateColor(bColor))
End Function

Public Sub SetToolbarBG(hwnd As Long, hBmp As Long)
    'Set the toolbars background image
    DeleteObject SetClassLong(hwnd, GCL_HBRBACKGROUND, CreatePatternBrush(hBmp))
    InvalidateRect 0&, 0&, False
End Sub

Public Sub SetToolbarBK(hwnd As Long, hColor As OLE_COLOR)
    ' Set a toolbars Backcolor
    DeleteObject SetClassLong(hwnd, GCL_HBRBACKGROUND, GDI_CreateSoildBrush(hColor))
    InvalidateRect 0&, 0&, False
End Sub

Private Sub cmdBk_Click()
    Call SetToolbarBK(Toolbar1.hwnd, vbYellow)
End Sub

Private Sub Command1_Click()
    SetToolbarBG Toolbar1.hwnd, Image1.Picture
End Sub

---

---

(VB6) Add-In - Move selected controls

April 9, 2021, 6:25 pm

≫ Next: More Misc Programs

≪ Previous: how to use alpha png for buttons，Transparent toolbar Control by vb6

$

0

0

Move several controls certain left and/or top at the same time.

Not sure if other add-ins do this (probably), but one feature that the VB6 IDE lacks is the ability to move all the selected controls at the same time certain left and/or top.



Sometimes it is necessary to add one or more controls to a form in the middle of other controls and you need to make room for them, so you need to shift an entire block of controls in some vertical (or horizontal, but usually vertical) space, and the IDE does not provide the ability to move them the exact offset.
You have to move them around with the mouse, but whether you have the IDE set to snap to the grid or not, the controls never end up in the right place. In the end, you have to set the position of each one by hand, and that's very cumbersome.
This add-in provides a solution for that problem.

Download from GitHub.

Attached Images

 

More Misc Programs

April 10, 2021, 6:49 am

≫ Next: XML Class to read & write

≪ Previous: (VB6) Add-In - Move selected controls

$

0

0

Here are 8 more misc programs from my unfinished folder. They are : Create Dummy Files , DrawOnForm with floodfill, Filename generator, Morse Code, Names List Maker, On/off usercontrol, random Strings, State abbrev.
Maybe there's something here someone can use.

XML Class to read & write

April 10, 2021, 9:33 am

≫ Next: Abbreviate Text

≪ Previous: More Misc Programs

$

0

0

Hi.
I am wondering if anyone has a drop in class that is easy to read & write nested xml files. Ive seen and got a few that read very basic xml files.
but i am not good enough to make it read & write nested tags.

ie
<config>
<Screen>
<Size>10</Size>
<somethingelse>blah blah</somethingelse>
<Screen>
<Next setting>test</Next setting>
<Anotherone>xxxxxxx</Anotherone>
</config>

tks

Abbreviate Text

April 11, 2021, 7:33 am

≫ Next: VB6 SQL-queryable Resources, based on ZipContainer-Files

≪ Previous: XML Class to read & write

$

0

0

This has very little use but I enjoyed the programming. Can be used to create control labels. See what you think about it.

Attached Images

 

Attached Files

• Abbrev.zip (3.9 KB)

VB6 SQL-queryable Resources, based on ZipContainer-Files

April 11, 2021, 8:35 am

≫ Next: Delete this post

≪ Previous: Abbreviate Text

$

0

0

This Demo has a dependency to RC6 (but would work with RC5 as well).

The framework-dependency was included, to be able to conveniently "Select" resource-data via SQL -
(from the ZipFile - InMemory... possible via the SQLite-ZipExtension which maps a Zip-archive to a virtual table).

The Project contains a modMain.bas Startup-module, which ensures:
- an AppDB (currently InMemory, but can be easily changed to a FileDB to persist also other AppData)
- in IDE-mode, the .\Res\-Subfolder is the leading data-source (a Res.zip will be re-created on each App-Startup in the IDE)
- in compiled mode, the App will instead fill the AppDBs "Res"-table directly from Res.zip
.. (so the \Res\-Subfolder does not have to be deployed)

So, whilst your Project is still in development, you simply enhance or update new content behind your \Res\-Subfolder.
The auto-refreshing of the Res.zip in your ProjectFolder (at each test-run in the IDE) eases a few worries,
whether the Zip-content matches with the content in your \Res\-Subfolder or not.


Here the output of the SQL-based resource-readouts on the Test-Form:


And here the zipped Demo-Code:
ZipResourceHandling.zip

Have fun,

Olaf

Attached Files

• ZipResourceHandling.zip (69.0 KB)

Delete this post

March 28, 2021, 2:52 pm

≫ Next: Name Generator

≪ Previous: VB6 SQL-queryable Resources, based on ZipContainer-Files

$

0

0

sorry :/

Name Generator

April 17, 2021, 6:31 pm

≫ Next: VB6 Office ribbon Activex Control,ribbon Ocx

≪ Previous: Delete this post

$

0

0

Create male names, female names, with or without middle initial and can add Mr. and Mrs. Code is simple and straight forward. Names list can be saved .I'd load a snapshot but not uploading it for some reason.

Attached Images

 

Attached Files

• Namescreator.zip (13.2 KB)

---

VB6 Office ribbon Activex Control,ribbon Ocx

April 25, 2021, 12:00 pm

≫ Next: Access the VBIDE library without add-ins

≪ Previous: Name Generator

$

0

0

Code:

---

    .AddTab "tab2", "Tab 2", True
    .AddCat "cat2", "tab2", "Group 1", False, ""
    .AddButton "but8", "cat2", "Search1", "save", False, "", False
   
 
    .AddCat "cat3", "tab2", "Group 2", False, ""
    .AddButton "but9", "cat3", "Search2", "save", False, "", False
'----------------------
    .AddTab "tab3", "Tab 3", True
    .AddCat "cat4", "tab3", "Group 3", False, ""
    .AddButton "but10", "cat4", "Search3", "save", False, "", False
   
 
    .AddCat "cat5", "tab3", "Group 4", False, ""
    .AddButton "but11", "cat5", "Search4", "save", False, "", False

---

Attached Images

 

Attached Files

• SpecialRibbon.zip (603.5 KB)

Access the VBIDE library without add-ins

March 29, 2021, 2:59 am

≫ Next: vb6 Fast ReadLine,QuickSplit(Like streamReader.ReadLine)

≪ Previous: VB6 Office ribbon Activex Control,ribbon Ocx

$

0

0

I recently had to document the methods of a vast class module. Means I wanted the names of all public functions listed in the module itself in a special procedure to give the opportunity to call them by name (CallByName used; could also be DispCall).
I could use a VB6 documenter for this, but asked myself if there is any way to access the VB6 Extensibility Library from inside the IDE apart from using an add-in, which seems to be the only way to get the instance's VBE Application object - other than in VBA Office where you can access VBIDE at any time. Investigated all over the net but could not find any solution. So here is mine.

It's so small that I can post the only important code routine here:

Code:

---

Private ThisVBE As VBIDE.VBE

Function GetVBIDE() As VBIDE.VBE
    Dim hwndMain As Long
    Dim sTitle As String
    Dim ret As Long
    Dim hProp As Long
    Dim ObjW As Object
   
    On Error GoTo ErrHandler
   
    If ThisVBE Is Nothing Then
        hwndMain = FindWindow("wndclass_desked_gsk", vbNullString)
        If hwndMain <> 0 Then
            sTitle = String(255, 0)
            ret = GetWindowText(hwndMain, sTitle, 255)
            If ret > 0 Then
                sTitle = Left(sTitle, ret)
                If InStr(1, sTitle, "Microsoft Visual Basic") > 0 Then
                    hProp = GetProp(hwndMain, "VBAutomation")
                    If hProp <> 0 Then
                        CopyMemory ObjW, hProp, 4&    '= VBIDE.Window
                        Set ThisVBE = ObjW.VBE
                        CopyMemory ObjW, 0&, 4&
                    End If
                End If
            End If
        End If
    End If
    Set GetVBIDE = ThisVBE
    Exit Function
   
ErrHandler:
    MsgBox Err.Description, vbCritical, "GetVBIDE()"
    Resume Next
End Function

---

Explanation:

• With the help of some API functions receive the window of VB's IDE (class wndclass_desked_gsk; top level window)
• Check if it's the right one ('Microsoft Visual Basic' in caption)
• All IDE windows expose a windows property (long value) called "VBAutomation". I found out this to be the object pointer of the related VBIDE.Window
• Get the pointer with GetProp
• Turn the pointer into an object (CopyMemory)
• Get the root VBE from property Window.VBE

Attached is a little project to demonstrate the usage. Hope it works in your environment.
If you want to implement this in your own project just copy the one routine and the API declarations into some module.

Attached Files

• GetVBAProps.zip (3.8 KB)

vb6 Fast ReadLine,QuickSplit(Like streamReader.ReadLine)

April 27, 2021, 7:03 pm

≫ Next: (VB6) Turn multiline text into String constant

≪ Previous: Access the VBIDE library without add-ins

$

0

0

quick split is 132% faster than line input

If you use pointers, you don't need to have MidB$ for each line of string, will it be faster?

If the file keeps increasing data, only the newly added content is read each time, and certain bytes can be skipped to speed up the reading speed. You can also add data to the software and read another software, using memory mapping technology, the speed will be faster, no need to save on the hard disk

Code:

---

Dim File1 As String
Dim FileSizeA As Long
Dim DataArr() As String

Private Sub Command1_Click()
QuickSplit_File2 File1, vbCrLf, DataArr(), , FileSizeA
End Sub



Private Sub Command2_Click()
Dim DataSize As Long
Dim StartPos As Long
StartPos = FileSizeA
'Get NewStr,Get the newly added content of the notepad file to the string array

QuickSplit_File2 File1, vbCrLf, DataArr(), StartPos, FileSizeA, DataSize
End Sub

---

Code:

---

Private Declare Function SafeArrayRedim Lib "oleaut32" (ByVal saPtr As Long, saBound As Long) As Long
Public Sub QuickSplit_File(File1 As String, Delimiter As String, ResultSplit() As String)
'比QuickInput_File快132%
Dim Str As String
Dim Remaining As Long, F As Long, Block() As Byte
F = FreeFile(0)
Open File1 For Binary Access Read As #F
Remaining = LOF(F)
ReDim Block(Remaining - 1)
Get #F, , Block
Close #F
Str = StrConv(Block, vbUnicode)

    Dim lngA As Long, lngCount As Long, lngDelLen As Long, lngExpLen As Long, lngResults() As Long
    ' some dummy variables that we happen to need
    Dim Compare As VbCompareMethod, SafeArrayBound(1) As Long
    ' length information
    lngExpLen = LenB(Str)
    lngDelLen = LenB(Delimiter)
    ' validate lengths and limit (limit must be larger than 0 or it must be unlimited)
    If lngExpLen > 0 And lngDelLen > 0 Then
        ' now look up for the first position
        lngA = InStrB(1, Str, Delimiter, Compare)
        ' InStrB is very fast, but it may give "between characters" results
        Do Until (lngA And 1) Or (lngA = 0)
            ' this is why we look for odd positions (1, 3, 5, 7 etc. are a valid position)
            lngA = InStrB(lngA + 1, Str, Delimiter, Compare)
        Loop
'------------------
            ' unlimited, reserve space for maximum possible amount of returned items
            ReDim lngResults(0 To (lngExpLen \ lngDelLen))
            ' index positions until none is found
            Do While lngA > 0
                ' remember this position
                lngResults(lngCount) = lngA
                ' look for the next one
                lngA = InStrB(lngA + lngDelLen, Str, Delimiter, Compare)
                Do Until (lngA And 1) Or (lngA = 0)
                    lngA = InStrB(lngA + 1, Str, Delimiter, Compare)
                Loop
                ' increase found counter
                lngCount = lngCount + 1
            Loop
'-----------------
        ' set results to actual findings
        ReDim Preserve ResultSplit(0 To lngCount)
        ' see if we found any results
        If lngCount = 0 Then
            ' nope, just set the only item to be the whole string
            ResultSplit(0) = Str
        Else
            ' get the first item
            ResultSplit(0) = LeftB$(Str, lngResults(0) - 1)
            ' get the other items except the last one
            For lngCount = 0 To lngCount - 2
                ResultSplit(lngCount + 1) = MidB$(Str, lngResults(lngCount) + lngDelLen, lngResults(lngCount + 1) - lngResults(lngCount) - lngDelLen)
            Next lngCount
            ' get the last item
            ResultSplit(lngCount + 1) = RightB$(Str, lngExpLen - lngResults(lngCount) - lngDelLen + 1)
        End If
    Else
        ' clean any possible data that exists in the passed string array (like if it is multidimensional)
        If Not Not ResultSplit Then Erase ResultSplit
        ' mysterious IDE error fix
        Debug.Assert App.hInstance
        ' reset to one element, one dimension
        ReDim ResultSplit(0 To 0)
        ' custom redimension: remove the items (this duplicates the VB6 Split behavior)
        SafeArrayRedim Not Not ResultSplit, SafeArrayBound(0)
    End If
End Sub

'TestObject 平均用时
'QuickSplit_Best 354.25
'QuickSplit 364.23
'QuickSplit2 365.31
'split() 3914.98
Public Sub QuickInput_File(File1 As String, Delimiter As String, ResultSplit() As String)
'最后的空行会忽略
Dim F As Long, UB As Long, I As Long
UB = 10001
    F = FreeFile(0)
    Open File1 For Input As #F
    ReDim ResultSplit(10000)
    'ReDim ResultSplit(114536)
    Do Until EOF(F)
        If I > UB Then UB = UB + 10000: ReDim Preserve ResultSplit(UB)
        Line Input #F, ResultSplit(I)
        I = I + 1
    Loop
    Close #F
    If I > 0 Then ReDim Preserve ResultSplit(I - 1)
End Sub

---

Code:

---

class Program
{
    static void Main(string[] args)
    {
        //定义文件路径
        string path = @"D:\\code\\test.txt";
        //创建 StreamReader 类的实例
        StreamReader streamReader = new StreamReader(path);
        //判断文件中是否有字符
        while (streamReader.Peek() != -1)
        {
            //读取文件中的一行字符
            string str = streamReader.ReadLine();
            Console.WriteLine(str);
        }
        streamReader.Close();
    }
}

---

(VB6) Turn multiline text into String constant

April 28, 2021, 4:16 am

≫ Next: [VB6, Vista+] Core Audio - Peak Meter

≪ Previous: vb6 Fast ReadLine,QuickSplit(Like streamReader.ReadLine)

$

0

0

This is an auxiliary code that takes a text from the clipboard and generates code for a constant declaration, then copies it back to the clipboard converted.

Code:

---

Option Explicit

Private Function GetStringConstantCode(nText As String, nConstantName As String) As String
    Dim s() As String
    Dim c As Long
    Dim s2() As String
    Dim iNumberOfConstants As Long
    Dim iCurrentContantNumber As Long
    Dim n As Long
    Dim c2 As Long
    Dim iConstantsStr() As String
   
    s = Split(Replace(nText, """", """"""), vbCrLf)
    iNumberOfConstants = -Int((-UBound(s) + 1) / 24)
   
    iConstantsStr = Split("")
   
    iCurrentContantNumber = 1
    For c = 0 To UBound(s)
        If (c + 1) Mod 24 = 1 Then
            If c > 0 Then
                iCurrentContantNumber = iCurrentContantNumber + 1
                ReDim Preserve iConstantsStr(UBound(iConstantsStr) + 1)
                iConstantsStr(UBound(iConstantsStr)) = Join(s2, vbCrLf)
            End If
            If (UBound(s) - c) < 23 Then
                n = (UBound(s) - c)
            Else
                n = 23
            End If
            ReDim s2(n)
            c2 = 0
            s2(c2) = "Private Const " & nConstantName & IIf((iNumberOfConstants > 1) And (iCurrentContantNumber < iNumberOfConstants), CStr(iCurrentContantNumber), "") & " As String = " & IIf(iNumberOfConstants > 1 And (iCurrentContantNumber > 1), nConstantName & CStr(iCurrentContantNumber - 1) & " & ", "") & IIf(s(c) <> "", """" & s(c) & """ & ", "") & "vbCrLf & _"
        ElseIf (c2 + 1) = UBound(s2) Then
            c2 = c2 + 1
            s2(c2) = "    """ & s(c) & """ & vbCrLf"
        Else
            c2 = c2 + 1
            s2(c2) = "    """ & s(c) & """ & vbCrLf &" & " _"
        End If
    Next
    ReDim Preserve iConstantsStr(UBound(iConstantsStr) + 1)
    iConstantsStr(UBound(iConstantsStr)) = Join(s2, vbCrLf)
    If Right(iConstantsStr(UBound(iConstantsStr)), 12) = "& vbCrLf & _" Then
        iConstantsStr(UBound(iConstantsStr)) = Left$(iConstantsStr(UBound(iConstantsStr)), Len(iConstantsStr(UBound(iConstantsStr))) - 12)
    End If
   
    GetStringConstantCode = Join(iConstantsStr, vbCrLf)
End Function

Private Sub Command1_Click()
    Dim iConstantName As String
    Dim iText As String
   
    iConstantName = InputBox("Please enter the Name of the constant.", "Constant name", "cConstName")
    If iConstantName = "" Then Exit Sub
   
    iText = Clipboard.GetText
    Clipboard.Clear
    Clipboard.SetText GetStringConstantCode(iText, iConstantName)
End Sub

---

It does not take into account the VB6 line limitation and it uses one line of code for each line of text.

It could be useful for someone.

Attached Files

• Make text constant.zip (1.7 KB)

[VB6, Vista+] Core Audio - Peak Meter

April 28, 2021, 5:05 pm

≫ Next: Bingo with 2 Playing Cards

≪ Previous: (VB6) Turn multiline text into String constant

$

0

0

Core Audio - Peak Meter

This demo is in a response to a question by Peterd51, asking if there was a way to detect if audio was playing. CoreAudio provides an easy way to watch peaks for a peak meter, so obviously if that's 0 no audio is playing, and non-zero if audio is playing.

Here we display a Audio detected/No audio label for the yes/no answer, then also a peak meter using a ProgressBar, and a list of the raw values the program is receiving. This is basically a VB version of Microsoft's Peak Meter Example.

The code is pretty simple,

Code:

---

Option Explicit
Private pDevice As IMMDevice
Private pEnum As MMDeviceEnumerator
Private pMeterInfo As IAudioMeterInformation
Private nCount As Long
Private Sub Command1_Click()
Timer1.Interval = CLng(Text1.Text)
If (pDevice Is Nothing) Then
    Set pEnum = New MMDeviceEnumerator
    pEnum.GetDefaultAudioEndpoint eRender, eConsole, pDevice
    If (pDevice Is Nothing) = False Then
        pDevice.Activate IID_IAudioMeterInformation, CLSCTX_INPROC_SERVER Or CLSCTX_INPROC_HANDLER Or CLSCTX_LOCAL_SERVER Or CLSCTX_REMOTE_SERVER, 0&, pMeterInfo
        If (pMeterInfo Is Nothing) = False Then
            Timer1.Enabled = True
        Else
            Debug.Print "Failed to activate meter."
        End If
    Else
        Debug.Print "Failed to get default endpoint."
    End If
Else
    Timer1.Enabled = True
End If
End Sub

Private Sub Timer1_Timer()
Dim snValue As Single
If (pMeterInfo Is Nothing) = False Then
    pMeterInfo.GetPeakValue snValue
    List1.AddItem CStr(snValue * 100), 0
    ProgressBar1.Value = snValue * 100
    If snValue = 0 Then
        Label4.Caption = "No audio."
        nCount = nCount + 1
        If nCount > 5 Then
            'definitely not playing
        End If
    Else
        nCount = 0
        Label4.Caption = "Audio detected"
    End If
End If
End Sub

Private Sub Command2_Click()
Timer1.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set pMeterInfo = Nothing
Set pDevice = Nothing
Set pEnum = Nothing
End Sub

---

Requirements
-Core Audio is only available on Windows Vista and newer.
-oleexp.tlb v4.7 or higher
-oleexp addon modules mIID.bas and mCoreAudio.bas (included in the oleexp download)

Core Audio in VB6
If you're not already familiar with using Core Audio in VB6, you can check out my earlier projects:
[VB6, Vista+] Core Audio Basics
[VB6, Vista+] Core Audio - Change the system default audio device
[VB6, Vista+] Core Audio - Monitor for disabled/active, default, and property changes

Attached Images

 

Attached Files

• CoreAudioWatchPeaks.zip (2.2 KB)

Bingo with 2 Playing Cards

April 29, 2021, 5:45 am

≫ Next: vb6 Fast ReadFile, ReadLine,QuickSplit(Like streamReader.ReadLine)

≪ Previous: [VB6, Vista+] Core Audio - Peak Meter

$

0

0

My version of programming a Bingo game. Its not fancy but I think its working. Suggestions are welcome. If someone knows how to make it print out the cards that would be great.

Attached Images

 

Attached Files

• Bingo.zip (137.4 KB)

vb6 Fast ReadFile, ReadLine,QuickSplit(Like streamReader.ReadLine)

April 27, 2021, 7:03 pm

≫ Next: vb6 Get Control Hwnd,Webbrowser Hwnd,Get Activex Control Hwnd

≪ Previous: Bingo with 2 Playing Cards

$

0

0

Read Filex Text by: (UTF8 IS FAST than StrConv)
StrConv(bytes,vbUnicode): 452 ms
Utf8text FileRead：286MS
read unicode text :s=block() as byte 170.6ms
read unicode text by Pointer: 117ms

Code:

---


    New_c.Timing True

    F = FreeFile(0) '822
    Open FILE_TO_SPLIT For Binary Access Read As #F
    FileLenA = LOF(F)
    ReDim block(FileLenA - 1)
    Get #F, , block
    Close #F
    Str = StrConv(block, vbUnicode)
    Print "StrConv(bytes,vbUnicode) GET FILE TEXT：" & New_c.Timing

'===================
    New_c.Timing True

    F = FreeFile(0) '822
    Open "Utf8text.txt" For Binary Access Read As #F
    FileLenA = LOF(F)
    ReDim block(FileLenA - 4)
    Get #F, 4, block
    Close #F
    Str = Utf8PtrToUnicode(VarPtr(block(0)))
    Print "Utf8text FileRead：" & New_c.Timing
    ReDim block(0)
    'MsgBox Str2 = Str
    Str = ""
'==================
 New_c.Timing True
  Dim fnum As Integer '
    fnum = FreeFile
    Open "UnicodeText1.txt" For Binary As #fnum
    ReDim block(LOF(fnum) - 3) As Byte
    Get #1, 3, block
    Str = block
   
    Print "unicode GET TEXT：" & New_c.Timing

---

Code:

---

'read unicode text by Pointer: 117ms
fnum = FreeFile
Open "UnicodeText2.txt" For Binary As #fnum
Dim StrLen1 As Long
StrLen1 = LOF(fnum) - 4
ReDim block(LOF(fnum) - 1) As Byte
'前面4个字节无效（第一个字符留空），作为字符长度
Get #1, , block()
'Str = block

'Str = String(StrLen1 / 2, 0)
Str = StringHelpers.SysAllocStringLen(ByVal 0&, StrLen1 / 2) '
'以前测试结果可以提速 47.65%

'Str = String(StrLen1, vbNullChar)
Dim lTmp As Long, lTmp2 As Long
'CopyMemory lTmp, ByVal VarPtr(Str), 4
Call AuxVBvm.GetMem4(ByVal VarPtr(Str), lTmp)
'CopyMemory block(0), StrLen1, 4
Call AuxVBvm.PutMem4(VarPtr(block(0)), StrLen1)
'CopyMemory ByVal VarPtr(Str), VarPtr(block(4)), 4
Call AuxVBvm.PutMem4(ByVal VarPtr(Str), VarPtr(block(4)))

Print "Unicode文件字节指针到字符串：" & New_c.Timing & "," & Len(Str)

'MsgBox "读unicode得到文件内容：" & Str
CopyMemory ByVal VarPtr(Str), lTmp, 4
Erase block()
Close #fnum

---

'====================
if save string to text with unicode format,so no need StrConv(Block, vbUnicode)
Read unicode Txt file is fast than StrConv(block, vbUnicode) 126%
The space occupied by the hard disk is doubled, and the operating speed is also doubled. The speed of NVE and M2 solid-state hard disks can be increased even more. Programs to run fast, hard disk reads and writes fast, CPU is powerful, and memory is high speed, all of which can add points

Code:

---

Dim S As String
Dim Bt() As Byte
Bt = OpenBinFile2(App.Path & "\UNICODE.txt", 2)
S = Bt

Function OpenBinFile2(filename As String, Optional SeekSize As Long, Optional ErrInfo As String) As Byte()
  '[mycode_id:1903],edittime:2011/7/11 13:27:34
On Error Resume Next
Dim hFile As Integer
hFile = FreeFile
Open filename For Binary As #hFile
If SeekSize > 0 Then
    Seek #hFile, SeekSize + 1
    ReDim OpenBinFile2(LOF(hFile) - 1 - SeekSize)
 
Else
    ReDim OpenBinFile2(LOF(hFile) - 1)
End If
Get #hFile, , OpenBinFile2
Close #hFile
End Function

---

The SPLIT function of vb6 takes 23 seconds （23000ms）
Fast SPLIT algorithm 660 ms
Analog pointer method takes 206 milliseconds


vb6 openfile+Split =458+29048 (=29.5 sec) 29500

:wave:DownLoad Sample test:Split_EnglishTest.zip


By using the pointer binding method, the speed is increased by 200 times.

quick split is 132% faster than line input

Line Input from Txt File ：3405.335 ms(str lines=3417225)
Loading time from pointer file to string array: 128.8862 ms
【25 times faster= 2500%】

If you use pointers, you don't need to have MidB$ for each line of string, will it be faster?
【Treat a super long string as a binary data address, and then bind it to a virtual string array, so that there is no need to copy the string multiple times to achieve a speed-up method. The larger the amount of data, the faster the speed.
Change the 4 bytes of the line break to the length of this line, and then bind the address of each line to the array pointer】
If the file keeps increasing data, only the newly added content is read each time, and certain bytes can be skipped to speed up the reading speed. You can also add data to the software and read another software, using memory mapping technology, the speed will be faster, no need to save on the hard disk

STUDY on StreamReader in VB6?-VBForums
https://www.vbforums.com/showthread....mReader-in-VB6

Code:

---

Dim File1 As String
Dim FileSizeA As Long
Dim DataArr() As String

Private Sub Command1_Click()
QuickSplit_File2 File1, vbCrLf, DataArr(), , FileSizeA
End Sub



Private Sub Command2_Click()
Dim DataSize As Long
Dim StartPos As Long
StartPos = FileSizeA
'Get NewStr,Get the newly added content of the notepad file to the string array

QuickSplit_File2 File1, vbCrLf, DataArr(), StartPos, FileSizeA, DataSize
End Sub

---

Code:

---

Private Declare Function SafeArrayRedim Lib "oleaut32" (ByVal saPtr As Long, saBound As Long) As Long
Public Sub QuickSplit_File(File1 As String, Delimiter As String, ResultSplit() As String)
'比QuickInput_File快132%
Dim Str As String
Dim Remaining As Long, F As Long, Block() As Byte
F = FreeFile(0)
Open File1 For Binary Access Read As #F
Remaining = LOF(F)
ReDim Block(Remaining - 1)
Get #F, , Block
Close #F
Str = StrConv(Block, vbUnicode)

    Dim lngA As Long, lngCount As Long, lngDelLen As Long, lngExpLen As Long, lngResults() As Long
    ' some dummy variables that we happen to need
    Dim Compare As VbCompareMethod, SafeArrayBound(1) As Long
    ' length information
    lngExpLen = LenB(Str)
    lngDelLen = LenB(Delimiter)
    ' validate lengths and limit (limit must be larger than 0 or it must be unlimited)
    If lngExpLen > 0 And lngDelLen > 0 Then
        ' now look up for the first position
        lngA = InStrB(1, Str, Delimiter, Compare)
        ' InStrB is very fast, but it may give "between characters" results
        Do Until (lngA And 1) Or (lngA = 0)
            ' this is why we look for odd positions (1, 3, 5, 7 etc. are a valid position)
            lngA = InStrB(lngA + 1, Str, Delimiter, Compare)
        Loop
'------------------
            ' unlimited, reserve space for maximum possible amount of returned items
            ReDim lngResults(0 To (lngExpLen \ lngDelLen))
            ' index positions until none is found
            Do While lngA > 0
                ' remember this position
                lngResults(lngCount) = lngA
                ' look for the next one
                lngA = InStrB(lngA + lngDelLen, Str, Delimiter, Compare)
                Do Until (lngA And 1) Or (lngA = 0)
                    lngA = InStrB(lngA + 1, Str, Delimiter, Compare)
                Loop
                ' increase found counter
                lngCount = lngCount + 1
            Loop
'-----------------
        ' set results to actual findings
        ReDim Preserve ResultSplit(0 To lngCount)
        ' see if we found any results
        If lngCount = 0 Then
            ' nope, just set the only item to be the whole string
            ResultSplit(0) = Str
        Else
            ' get the first item
            ResultSplit(0) = LeftB$(Str, lngResults(0) - 1)
            ' get the other items except the last one
            For lngCount = 0 To lngCount - 2
                ResultSplit(lngCount + 1) = MidB$(Str, lngResults(lngCount) + lngDelLen, lngResults(lngCount + 1) - lngResults(lngCount) - lngDelLen)
            Next lngCount
            ' get the last item
            ResultSplit(lngCount + 1) = RightB$(Str, lngExpLen - lngResults(lngCount) - lngDelLen + 1)
        End If
    Else
        ' clean any possible data that exists in the passed string array (like if it is multidimensional)
        If Not Not ResultSplit Then Erase ResultSplit
        ' mysterious IDE error fix
        Debug.Assert App.hInstance
        ' reset to one element, one dimension
        ReDim ResultSplit(0 To 0)
        ' custom redimension: remove the items (this duplicates the VB6 Split behavior)
        SafeArrayRedim Not Not ResultSplit, SafeArrayBound(0)
    End If
End Sub

'TestObject 平均用时
'QuickSplit_Best 354.25
'QuickSplit 364.23
'QuickSplit2 365.31
'split() 3914.98
Public Sub QuickInput_File(File1 As String, Delimiter As String, ResultSplit() As String)
'最后的空行会忽略
Dim F As Long, UB As Long, I As Long
UB = 10001
    F = FreeFile(0)
    Open File1 For Input As #F
    ReDim ResultSplit(10000)
    'ReDim ResultSplit(114536)
    Do Until EOF(F)
        If I > UB Then UB = UB + 10000: ReDim Preserve ResultSplit(UB)
        Line Input #F, ResultSplit(I)
        I = I + 1
    Loop
    Close #F
    If I > 0 Then ReDim Preserve ResultSplit(I - 1)
End Sub

---

Code:

---

class Program
{
    static void Main(string[] args)
    {
        //定义文件路径
        string path = @"D:\\code\\test.txt";
        //创建 StreamReader 类的实例
        StreamReader streamReader = new StreamReader(path);
        //判断文件中是否有字符
        while (streamReader.Peek() != -1)
        {
            //读取文件中的一行字符
            string str = streamReader.ReadLine();
            Console.WriteLine(str);
        }
        streamReader.Close();
    }
}

---

Attached Images

 

Attached Files

• Split_EnglishTest.zip (10.4 KB)

---

vb6 Get Control Hwnd,Webbrowser Hwnd,Get Activex Control Hwnd

May 2, 2021, 10:14 pm

≫ Next: Very Nice,Transparent user control by vb6

≪ Previous: vb6 Fast ReadFile, ReadLine,QuickSplit(Like streamReader.ReadLine)

$

0

0

This is a great invention, I wonder if you have a better way？
It took a few hours to complete. It’s not easy. If you are interested, try some suggestions.


if usercontrol with windowless=true,also can get hwnd,it's the form hwnd.
commandbutton,label,can't use this way to get hwnd.
can use vb6 Method

How to Get Control Hwnd like Webbrowser,all Activex Control

Code:

---

Private Declare Function IUnknown_GetWindow Lib "shlwapi.dll" (ByVal punk As IUnknown, ByRef phwnd As Long) As Long
Private Declare Function GetAncestor Lib "user32.dll" (ByVal hwnd As Long, ByVal gaFlags As Long) As Long
Private Const GA_ROOT As Long = 2
 

Function GetOcxHwnd(ocx As IUnknown, Optional WindowLess As Boolean) As Long
On Error Resume Next
WindowLess = False
'无窗口的自定义控件(WindowLess=true)，取到的句柄就是窗体
'Usercontrol.WindowLess=true,IUnknown_GetWindow Get Hwnd is Form hwnd
    Dim Obj As Object, Hwnd1 As Long
    Set Obj = ocx
    On Error Resume Next
    Hwnd1 = Obj.hwnd 'vb6 normal method get hwnd
    If Hwnd1 = 0 Then
        IUnknown_GetWindow Obj.object, Hwnd1
        If Hwnd1 <> 0 Then
            Dim Hwnd2 As Long
            Hwnd2 = GetAncestor(Hwnd1, GA_ROOT)
           
            ''Get Form Hwnd // like GetAncestor(hwnd=0,GA_ROOT)
           
'            Dim Parent As Object, LastParent As Object
'            Set Parent = Obj.Container
'            While Not Parent Is Nothing
'                'MsgBox Parent.Hwnd
'                Set LastParent = Parent
'                Set Parent = Nothing
'                Set Parent = LastParent.Container
'            Wend
'            Hwnd2 = LastParent.hwnd

            If Hwnd2 = Hwnd1 Then
                WindowLess = True
                Debug.Print "It's Usercontrol WindowLess=true"
                Hwnd1 = 0
            End If
        End If
    End If
    GetOcxHwnd = Hwnd1
End Function


Function GetOcxHwnd2(ocx As IUnknown) As Long
    Dim HwndA As Long
    Dim Obj As Object
    Set Obj = ocx
    IUnknown_GetWindow Obj.object, GetOcxHwnd2
End Function

    MsgBox GetOcxHwnd(DataGrid1)
    MsgBox GetOcxHwnd(Webbrowser1)
MsgBox GetOcxHwnd(UserControl11)

---

Very Nice,Transparent user control by vb6

May 4, 2021, 12:55 am

≫ Next: How to get the effective area of the picture by vb6?

≪ Previous: vb6 Get Control Hwnd,Webbrowser Hwnd,Get Activex Control Hwnd

$

0

0

Transparent user control (copy the control in the background of the parent window to achieve a transparent effect)
Two background pictures (001.jpg, 002.jpg), one larger and the other smaller. Please download it yourself and put it in the project directory
The biggest difficulty is that it supports DPI scaling. You can also specify only the background image of the copy window (parent object) without copying the control elements abo

In recent months, I have been researching various transparency technologies, turning existing text boxes into transparency, or adding background images. Self-developed transparent button control, PNG image control, etc. Some computers have DPI zoomed by 150%-200%. By intercepting the picture of the control's parent object (including other controls), it turns out that the size is wrong, so I wrote a DPI perception program, and the screenshot needs to be copied in equal proportions. This problem troubled me for 3 months and finally solved it. You can write it in the module, and you can use it in any form. PICTUREBOX becomes transparent, and usercontrol can also be transparent.

Code:

---

'code in form1.frm

Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function ReleaseCapture Lib "User32" () As Long
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2

'1, Add 001.jpg to Project Path
'2, Add Picturebox1 Control
'3, Copy This Code ,Run

 Private Sub Form_Load()
    Me.Picture = LoadPicture("001.jpg")
    Picture1.AutoRedraw = True
    Me.Caption = "drag the picture frame-transparent effect"
End Sub
Private Sub Form_Activate()
If Me.Tag = "" Then
    Me.Tag = "a"
    TransparentControl Picture1
End If
End Sub



Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
    Call ReleaseCapture
    Call SendMessage(Picture1.Hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
    TransparentControl Picture1
End If
End Sub

---

Code:

---

Option Explicit
'This Code Save To  TransparentBas.bas
'100 Lines vb6 Code For TransparentControl(Picture1) 'Picturebox1
'============================
Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Declare Function GetDesktopWindow Lib "User32" () As Long
Private Declare Function CreateDC& Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) 'DEVMODE
Private Declare Function GetWindowDC Lib "User32" (ByVal Hwnd As Long) As Long
Private Declare Function BringWindowToTop Lib "User32" (ByVal Hwnd As Long) As Long
Private Declare Function GetParent Lib "User32" (ByVal Hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "User32" (ByVal Hwnd As Long, lpRect As RECT) As Long
Private Declare Function ClientToScreen Lib "User32" (ByVal Hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetClientRect Lib "User32" (ByVal Hwnd As Long, lpRect As RECT) As Long
Private Declare Function ReleaseDC Lib "User32" (ByVal Hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function ShowWindow Lib "User32" (ByVal Hwnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" ( _
ByVal hDestDC As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal nSrcWidth As Long, _
ByVal nSrcHeight As Long, _
ByVal dwRop As Long) As Long

Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Const SW_HIDE = 0

Declare Function GetDC Lib "User32" (ByVal Hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Const DESKTOPHORZRES As Long = 118
Private Const HORZRES As Long = 8
Private Const LOGPIXELSX = 88

Public DpiRate As Single '本程序显示缩放倍数
Function GetDpiRate() As Single
    Dim Hdc0 As Long, Pixelx As Long, PixelY As Long, MonitorW As Long, MonitorH As Long
    If DpiRate = 0 Then
        Hdc0 = GetDC(0)
        MonitorW = GetDeviceCaps(Hdc0, DESKTOPHORZRES)
        Pixelx = GetDeviceCaps(Hdc0, HORZRES) '//水平像素总数
        DpiRate = MonitorW / Pixelx
        If DpiRate = 0 Then DpiRate = 1
        GetDpiRate = DpiRate
    End If
End Function

Sub TransparentControl(Control1 As Control)
    TransparentHwndHdc Control1.Hwnd, Control1.hDC
End Sub
Sub TransparentHwndHdc(MyHwnd As Long, MyHdc As Long, Optional ByVal ParentHwnd As Long)
Dim ParentDc As Long, CopyFromScreen As Boolean
If DpiRate = 0 Then GetDpiRate

ShowWindow MyHwnd, SW_HIDE
DoEvents
If ParentHwnd = -1 Then 'cut img from Screen
    CopyFromScreen = True
    ParentHwnd = GetDesktopWindow
    ParentDc = CreateDC("DISPLAY", 0, 0, 0)
Else
    If ParentHwnd = 0 Then ParentHwnd = GetParent(MyHwnd)
    ParentDc = GetWindowDC(ParentHwnd)
End If

Dim AreaWidth As Long, AreaHeight As Long, WinRect1 As RECT, ClientWh2 As RECT, ClientXY2 As POINTAPI
GetWindowRect ParentHwnd, WinRect1
GetClientRect MyHwnd, ClientWh2
ClientToScreen MyHwnd, ClientXY2
AreaWidth = ClientWh2.Right
AreaHeight = ClientWh2.Bottom

BringWindowToTop ParentHwnd

If CopyFromScreen Then
    StretchBlt MyHdc, 0, 0, AreaWidth, AreaHeight, ParentDc, _
        DpiRate * (ClientXY2.X - WinRect1.Left), _
        DpiRate * (ClientXY2.Y - WinRect1.Top) _
        , AreaWidth * DpiRate, AreaHeight * DpiRate, vbSrcCopy
Else
    BitBlt MyHdc, 0, 0, AreaWidth, AreaHeight, ParentDc, ClientXY2.X - WinRect1.Left, ClientXY2.Y - WinRect1.Top, vbSrcCopy '原来
End If

ReleaseDC ParentHwnd, ParentDc
ShowWindow MyHwnd, 5
End Sub

---

Attached Images

 

Attached Files

• Nice_TransparentOcx.zip (4.9 KB)

How to get the effective area of the picture by vb6?

May 5, 2021, 3:45 pm

≫ Next: (VB6) Component Documenter

≪ Previous: Very Nice,Transparent user control by vb6

$

0

0

A PNG image with a transparent channel, for example, where does the left start with pixels and the top start with pixels? Add a border to the active area of the image.

(VB6) Component Documenter

May 6, 2021, 4:54 am

≫ Next: XiaoYao Json Class by ScriptControl 【very interesting】

≪ Previous: How to get the effective area of the picture by vb6?

$

0

0

This is a tool to help document ActiveX components.



You can import the information from the OCX or DLL file, and if you added the description of each member in the IDE, that will be added automatically as a "short description".

With that you could already generate something useful, but the purpose is to document it better by adding a "long description", specially for the properties and methods that might not be intuitive.

Anyway, when generating the final files from the 'Report' menu, it will pick the long description if available or otherwise the short one also if available.

If no descriptions are available at all, the report generated could still have some value, but only to see the structure of Controls/Classes/Properties/Methods/Events and the parameters of each member, but will have no explanation.

The long description allows some markup to reference other members (members are properties, methods and events) or the reference other Controls or Classes, also to reference Enums (not individual constants).

The markup works like this:
[c[ControlName]] refers to a control
[o[ClassName]] refers to a class, also called 'object'
[p[PropertyName]] refers to a property
[m[MethodName]] refers to a method (function or sub)
[e[EventName]] refers to an event
[[EnumName]] refers to an enum

There are some buttons that help to do that automatically.

<b>some text</b> is for bold text.

You can also put html links if you want, by placing the html code for them.

It can output HTML, RTF, PDF (through a PDF printer driver) and plain text.

The HTML pages can be one, one per object (control/class) and one per member (property/method/events). This is set in the menu Reports/Options.
You can also set some custom header/footer/style for the HTML files.

Download from GitHub.

Attached Images

 

XiaoYao Json Class by ScriptControl 【very interesting】

May 7, 2021, 7:00 am

≫ Next: Load Json data to Treeview by ScriptControl Activex With vb6

≪ Previous: (VB6) Component Documenter

$

0

0

There are still many problems with this module, which are limited to research and use, and commercial errors may occur.
For example, adding sub-arrays, subordinates, etc., is really not easy to implement

json2.js(2017-6-12),from https://github.com/douglascrockford/...aster/json2.js

Code:

---

Sub XiaoJsonTest()
Dim Json As XiaoJson
Set Json = New XiaoJson


Dim Htm As String
Htm = "{""a"":""AAABBB"",""b"":""abc"",""arr1"":[{""c"":""aa"",""d"":""bb""},{""e"":""dd""}]}"
Json.SetJsonObjectStr Htm
'================
MsgBox Json.GetValue("a")
Json.SetValue "a", "CCC" & vbCrLf & "22"
MsgBox Json.GetValue("a")
'=============
Dim S As String
S = Json.GetJsonObjectStrFormat
Clipboard.Clear
Clipboard.SetText S
MsgBox S
Json.SetValue "a", 666
MsgBox Json.GetJsonObjectStr("arr1")
MsgBox Json.GetJsonObjectStrFormat("arr1")
MsgBox Json.GetValue("a")

MsgBox Json.GetValue("a") & ",typename=" & TypeName(Json.GetValue("a"))
Dim SingleV As Currency
SingleV = 3.14
Json.SetValue "a", SingleV

MsgBox Json.GetValue("a") & ",typename=" & TypeName(Json.GetValue("a"))

MsgBox Json.GetJsonObjectStr
End Sub

---

Code:

---

  'code in class (XiaoJson.cls)
 'add Reference= msscript.ocx#Microsoft Script Control 1.0
 'Dim JsLib As New ScriptControl
Option Explicit

Dim JsLib As Object 'Method 2
Private Sub Class_Initialize()
    CreateNew
End Sub
Sub CreateNew() 'if code in bas file,run CreateNew First
If Not JsLib Is Nothing Then Set JsLib = Nothing
'Set JsLib = New ScriptControl
Set JsLib = CreateObject("ScriptControl")  'Method 2
JsLib.Language = "Javascript"
Dim JsCode As String
Dim Htm As String

''JsCode = "var JSON=function(){var m={'\b':'\\b','\t':'\\t','\n':'\\n','\f':'\\f','\r':'\\r','""':'\\""','\\':'\\\\'},s={'boolean':function(x){return String(x)},number:function(x){return isFinite(x)?String(x):'null'},string:function(x){if(/[""\\\x00-\x1f]/.test(x)){x=x.replace(/([\x00-\x1f\\""])/g,function(a,b){var c=m[b];if(c){return c}c=b.charCodeAt();return'\\u00'+Math.floor(c/16).toString(16)+(c%16).toString(16)})}return'""'+x+'""'},object:function(x){if(x){var a=[],b,f,i,l,v;if(x instanceof Array){a[0]='[';l=x.length;for(i=0;i<l;i+=1){v=x[i];f=s[typeof v];if(f){v=f(v);if(typeof v=='string'){if(b){a[a.length]=','}a[a.length]=v;b=true}}}a[a.length]=']'}else if(x instanceof Object){a[0]='{';for(i in x){v=x[i];f=s[typeof v];if(f){v=f(v);if(typeof v=='string'){if(b){a[a.length]=','}a.push(s.string(i),':',v);b=true}}}a[a.length]='}'}else{return}return a.join('')}return'null'}};return{"
''JsCode = JsCode & "copyright: '(c)2005 JSON.org',license:'http://www.crockford.com/JSON/license.html',stringify:function(v){var f=s[typeof v];if(f){v=f(v);if(typeof v=='string'){return v}}return null},parse:function(text){try{return!(/[^,:{}\[\]0-9.\-+Eaeflnr-u \n\r\t]/.test(text.replace(/""(\\.|[^""\\])*""/g,'')))&&eval('('+text+')')}catch(e){return false}}}}();"

JsCode = "if(typeof JSON!==""object""){JSON={}}(function(){""use strict"";var g=/^[\],:{}\s]*$/;var h=/\\(?:[""\\\/bfnrt]|u[0-9a-fA-F]{4})/g;var l=/""[^""\\\n\r]*""|true|false|null|-?\d+(?:\.\d*)?(?:[eE][+\-]?\d+)?/g;var m=/(?:^|:|,)(?:\s*\[)+/g;var o=/[\\""\u0000-\u001f\u007f-\u009f\u00ad\u0600-\u0604\u070f\u17b4\u17b5\u200c-\u200f\u2028-\u202f\u2060-\u206f\ufeff\ufff0-\uffff]/g;var p=/[\u0000\u00ad\u0600-\u0604\u070f\u17b4\u17b5\u200c-\u200f\u2028-\u202f\u2060-\u206f\ufeff\ufff0-\uffff]/g;function f(n){return(n<10)?""0""+n:n}function this_value(){return this.valueOf()}if(typeof Date.prototype.toJSON!==""function""){Date.prototype.toJSON=function(){return isFinite(this.valueOf())?(this.getUTCFullYear()+""-""+f(this.getUTCMonth()+1)+""-""+f(this.getUTCDate())+""T""+f(this.getUTCHours())+"":""+f(this.getUTCMinutes())+"":""+f(this.getUTCSeconds())+""Z""):null};Boolean.prototype.toJSON"
JsCode = JsCode & "=this_value;Number.prototype.toJSON=this_value;String.prototype.toJSON=this_value}var q;var r;var s;var t;function quote(b){o.lastIndex=0;return o.test(b)?""\""""+b.replace(o,function(a){var c=s[a];return typeof c===""string""?c:""\\u""+(""0000""+a.charCodeAt(0).toString(16)).slice(-4)})+""\"""":""\""""+b+""\""""}function str(a,b){var i;var k;var v;var c;var d=q;var e;var f=b[a];if(f&&typeof f===""object""&&typeof f.toJSON===""function""){f=f.toJSON(a)}if(typeof t===""function""){f=t.call(b,a,f)}switch(typeof f){case""string"":return quote(f);case""number"":return(isFinite(f))?String(f):""null"";case""boolean"":case""null"":return String(f);case""object"":if(!f){return""null""}q+=r;e=[];if(Object.prototype.toString.apply(f)===""[object Array]""){c=f.length;for(i=0;i<c;i+=1){e[i]=str(i,f)||""null""}v=e.length===0?""[]"":q?(""[\n""+q+e.join("",\n""+q)+""\n""+d+""]""):""[""+e.join("","")+""]"";q=d;return v}if(t&&typeof t===""object"")"
JsCode = JsCode & "{c=t.length;for(i=0;i<c;i+=1){if(typeof t[i]===""string""){k=t[i];v=str(k,f);if(v){e.push(quote(k)+((q)?"": "":"":"")+v)}}}}else{for(k in f){if(Object.prototype.hasOwnProperty.call(f,k)){v=str(k,f);if(v){e.push(quote(k)+((q)?"": "":"":"")+v)}}}}v=e.length===0?""{}"":q?""{\n""+q+e.join("",\n""+q)+""\n""+d+""}"":""{""+e.join("","")+""}"";q=d;return v}}if(typeof JSON.stringify!==""function""){s={""\b"":""\\b"",""\t"":""\\t"",""\n"":""\\n"",""\f"":""\\f"",""\r"":""\\r"",""\"""":""\\\"""",""\\"":""\\\\""};JSON.stringify=function(a,b,c){var i;q="""";r="""";if(typeof c===""number""){for(i=0;i<c;i+=1){r+="" ""}}else if(typeof c===""string""){r=c}t=b;if(b&&typeof b!==""function""&&(typeof b!==""object""||typeof b.length!==""number"")){throw new Error(""JSON.stringify"");}return str("""",{"""":a})}}if(typeof JSON.parse!==""function""){JSON.parse=function(d,e){var j;function walk(a,b){var k;var v;var c=a[b];if(c&&typeof c===""object""){for(k in c)"
JsCode = JsCode & "{if(Object.prototype.hasOwnProperty.call(c,k)){v=walk(c,k);if(v!==undefined){c[k]=v}else{delete c[k]}}}}return e.call(a,b,c)}d=String(d);p.lastIndex=0;if(p.test(d)){d=d.replace(p,function(a){return(""\\u""+(""0000""+a.charCodeAt(0).toString(16)).slice(-4))})}if(g.test(d.replace(h,""@"").replace(l,""]"").replace(m,""""))){j=eval(""(""+d+"")"");return(typeof e===""function"")?walk({"""":j},""""):j}throw new SyntaxError(""JSON.parse"");}}}());"

'==============
JsCode = JsCode & "var JsonObj={};function Js_SetJsonValue(Key,Str){JsonObj[Key]=Str;}" & vbCrLf

JsLib.AddCode JsCode
End Sub

Function SetValue(JsonKey As String, NewVal, Optional IsString As Boolean, Optional ErrInfo As String) As Boolean
    On Error GoTo DoErr
    ErrInfo = ""
    Call JsLib.Run("Js_SetJsonValue", JsonKey, IIf(IsString, "'" & NewVal & "'", NewVal))
    SetValue = True
    Exit Function
DoErr:    ErrInfo = "ErrNumber:" & Err.Number & ",Description:" & Err.Description
End Function

Function GetValue(JsonKey As String, Optional ErrInfo As String)
    On Error GoTo DoErr
    ErrInfo = ""
    GetValue = JsLib.Eval("JsonObj." & JsonKey)
    Exit Function
DoErr:
    ErrInfo = "ErrNumber:" & Err.Number & ",Description:" & Err.Description
End Function


Function SetNumber(JsonKey As String, NewVal, Optional ErrInfo As String) As Boolean
 SetNumber = SetValue(JsonKey, NewVal, False, ErrInfo)
End Function
Function SetJsonObjectStr(JsonCode As String, Optional ErrInfo As String) As Boolean
    On Error GoTo DoErr
    ErrInfo = ""
    JsLib.Eval ("var JsonObj=" & JsonCode)
    SetJsonObjectStr = True
    Exit Function
DoErr:    ErrInfo = "ErrNumber:" & Err.Number & ",Description:" & Err.Description
End Function
Function GetJsonObjectStr(Optional JsonKey As String, Optional AddDot As Boolean = True, Optional ErrInfo As String) As String
    On Error GoTo DoErr
    ErrInfo = ""
    GetJsonObjectStr = JsLib.Eval("JSON.stringify(JsonObj" & IIf(JsonKey <> "", IIf(AddDot, ".", "") & JsonKey, "") & ")")
    Exit Function
DoErr:    ErrInfo = "ErrNumber:" & Err.Number & ",Description:" & Err.Description
End Function

Function GetJsonObjectStrFormat(Optional JsonKey As String, Optional AddDot As Boolean = True, Optional ErrInfo As String) As String
    On Error GoTo DoErr
    ErrInfo = ""
    GetJsonObjectStrFormat = JsLib.Eval("JSON.stringify(JsonObj" & IIf(JsonKey <> "", IIf(AddDot, ".", "") & JsonKey, "") & ", null, '\t')")
    GetJsonObjectStrFormat = Replace(GetJsonObjectStrFormat, vbLf, vbCrLf)
    Exit Function
DoErr:    ErrInfo = "ErrNumber:" & Err.Number & ",Description:" & Err.Description
End Function

---