Round Colorful Forms

March 14, 2018, 3:14 am

≫ Next: IEEE Doubles: NaN, Infinity, etc.

≪ Previous: VB6 - Personal Chat

$

0

0

Ok in its raw form this is really quite useless but it contains several interesting parts that can be put to greater use

With this code you can create a round, color changing form that can be moved freely.

Thank you SamOscarBrown for your circle code and Microsoft for helping me get the form movable

you will need a form with a text box and a timer. I named the form frmRound

seeing it work really blew my mind!

PHP Code:

---

Private Declare Function SendMessage Lib "User32" _
                         Alias "SendMessageA" (ByVal hWnd As Long, _
                                               ByVal wMsg As Long, _
                                               ByVal wParam As Long, _
                                               lParam As Any) As Long
Private Declare Sub ReleaseCapture Lib "User32" ()

      Const WM_NCLBUTTONDOWN = &HA1
      Const HTCAPTION = 2

    Option Explicit
    Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function SetWindowRgn Lib "User32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
   

    
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
                                 X As Single, Y As Single)
         Dim lngReturnValue As Long

         If Button = 1 Then
            Call ReleaseCapture
            lngReturnValue = SendMessage(frmRound.hWnd, WM_NCLBUTTONDOWN, _
                                         HTCAPTION, 0&)
         End If
      End Sub

    Private Sub Form_DblClick()
       Unload Me
    End Sub
    Private Sub Form_Load()
        Dim lngRegion As Long
        Dim lngReturn As Long
        Dim lngFormWidth As Long
        Dim lngFormHeight As Long
        Me.Width = Me.Height
        
        lngFormWidth = Me.Width / Screen.TwipsPerPixelX
        lngFormHeight = Me.Height / Screen.TwipsPerPixelY
        lngRegion = CreateEllipticRgn(0, 0, lngFormWidth, lngFormHeight)
        lngReturn = SetWindowRgn(Me.hWnd, lngRegion, True)
Label1.Left = (Me.Width / 2) - (Label1.Width / 2)
Label1.Top = (Me.Height / 2) - (Label1.Height / 2)
    End Sub
    Private Sub Label1_Click()
       Unload frmRound
    End Sub
    Private Sub Timer1_Timer()
  Static iColor As Integer
  Select Case iColor
  Case 0: Me.BackColor = RGB(255, 0, 0)   ' Red
  Case 1: Me.BackColor = RGB(255, 165, 0) ' Orange
  Case 2: Me.BackColor = RGB(255, 255, 0) ' Yellow
  Case 3: Me.BackColor = RGB(0, 128, 0)   ' Green
  Case 4: Me.BackColor = RGB(0, 0, 255)   ' Blue
  Case 5: Me.BackColor = RGB(128, 0, 128) ' Purple
  End Select
  iColor = iColor + 1
  If iColor > 5 Then iColor = 0
End Sub 


---

---

IEEE Doubles: NaN, Infinity, etc.

March 14, 2018, 8:20 am

≫ Next: [vb6] Enhancing VB's StdPicture Object to Support GDI+

≪ Previous: Round Colorful Forms

$

0

0

When doing math that may have problems, I've traditionally resorted to Variants and returned a Null or Empty when things didn't go correctly. However, that's never felt totally clean. Lately, I've been relying on the NaN of an IEEE Double (and forgoing any use of Variants).

Basically, to summarize, I can think of five different "states" an IEEE Double may be in:

• Zero
• A typical floating point number.
• A sub-normal floating point number.
• A NaN
• Infinity

And, there's also the sign-bit. However, the way IEEE Doubles are specified, the sign-bit is independent of all five of those "states". In other words, we can have -NaN or +NaN, -Inf, or +Inf. We can even have -0 or +0.

Also, just to quickly define them, the sub-normal numbers are numbers very close to zero. With the typical 11-bit exponent, this exponent can range from approximately 10⁺³⁰⁸ to 10^-308. However, with a bit of trickery (i.e., using the mantissa as more exponent, and sacrificing mantissa precision), we can push on the negative exponent side, making it go to approximately 10^-324. These sub-normal numbers are always very close to zero. I don't do anything special with these sub-normal numbers herein, but I just wanted to be complete.

Also, I list "Zero" separately from "A typical floating point number". This is because Zero is not handled (i.e., binary coded) the same way as other numbers. Zero just has all the bits off (with the possible exception of the sign bit).

Now, NaN is a special value that means "not-a-number". It's what you get when you try to divide 0#/0# (with error trapping turned on so you don't crash). There are also other ways to get it.

Infinity (or just Inf) is another one of these special values. You can get it by dividing any non-zero number by zero, such as 1#/0# (again, with error trapping).

There's a good Wikipedia page about these IEEE Doubles (which is just a Double type in VB6).

It's mostly these NaN and Inf values about which I post this entry. I've begun using them (instead of Variant) to handle special situations, and I thought I'd share. Also, the way I did things, there's no need for error trapping, which should keep things very fast.

Here's the code (possibly best in a BAS module):

Code:

---


Option Explicit
'
Public Declare Function GetMem2 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
Public Declare Function GetMem4 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
Public Declare Function GetMem8 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
'

Public Function NaN() As Double
    ' Math (add, subtract, multiply, divide) can be done on these, but nothing changes.
    ' They can NOT be used in "if NaN = NaN Then", or an overflow will result.  Use IsNaN().
    ' Also, most math-with-functions (Sin(), Round(), etc) causes overflow error.
    '
    GetMem2 &HFFF8, ByVal PtrAdd(VarPtr(NaN), 6&)
End Function

Public Function Inf() As Double
    GetMem2 &HFFF0, ByVal PtrAdd(VarPtr(Inf), 6&)
End Function

Public Function IsNaN(d As Double) As Boolean
    IsNaN = IsNanOrInf(d) And Not IsInf(d)
End Function

Public Function IsInf(d As Double) As Boolean
    Const ii As Integer = &H7FF0    ' High 4 bits of byte #7 (F0), Low 7 bits of byte #8 (7F). If all on, it's NaN (or Inf if all other non-sign bits are zero).
    Static i(1 To 4) As Integer
    GetMem8 d, i(1)
    IsInf = (i(4) And ii) = ii And i(1) = &H0 And i(2) = &H0 And i(3) = &H0 And (i(4) And &HF) = &H0
End Function

Public Function IsNeg(d As Double) As Boolean
    ' This works even on NaN and Inf.
    Static i(1 To 4) As Integer
    GetMem8 d, i(1)
    IsNeg = i(4) < 0    ' The sign bit will be the same sign bit for i(4).
End Function

Public Function IsNanOrInf(d As Double) As Boolean
    Const ii As Integer = &H7FF0    ' High 4 bits of byte #7 (F0), Low 7 bits of byte #8 (7F). If all on, it's NaN (or Inf if all other non-sign bits are zero).
    Static i(1 To 4) As Integer
    GetMem8 d, i(1)
    IsNanOrInf = (i(4) And ii) = ii
End Function

Public Function PtrAdd(ByVal Pointer As Long, ByVal Offset As Long) As Long
    ' For adding (or subtracting) a small number from a pointer.
    ' Use PtrAddEx for adding (or subtracting) large numbers from a pointer.
    Const SIGN_BIT As Long = &H80000000
    PtrAdd = (Pointer Xor SIGN_BIT) + Offset Xor SIGN_BIT
End Function


---

Just as an example of one place you may use these ... let's say you want to average a set of numbers. However, there may be cases where there are no numbers to average. What do you return? It's a problem, but returning a NaN can solve it so long as we remember to test for NaN before using it.

The following isn't complete code, but it's an example of where I'm using it. The caller then uses the IsNaN() function:

Code:

---


Private Function ParamSideAvg(iRow As Long, sSideLetter As String) As Double
    ' Returns NaN if nothing to average.
    Dim n As Double
    Dim iCnt As Long
    Dim iCol As Long
    '
    Select Case sSideLetter
    Case "L": iCol = ColNumberFromLetter("H")  ' This is the MEAN column.  Subtractions are made to get cycle data.
    Case "R": iCol = ColNumberFromLetter("N")  ' This is the MEAN column.  Subtractions are made to get cycle data.
    Case Else:  Exit Function
    End Select
    '
    If Len(Trim$(wsh.Cells(iRow, iCol - 3))) > 0 Then n = n + val(wsh.Cells(iRow, iCol - 3)): iCnt = iCnt + 1
    If Len(Trim$(wsh.Cells(iRow, iCol - 2))) > 0 Then n = n + val(wsh.Cells(iRow, iCol - 2)): iCnt = iCnt + 1
    If Len(Trim$(wsh.Cells(iRow, iCol - 1))) > 0 Then n = n + val(wsh.Cells(iRow, iCol - 1)): iCnt = iCnt + 1
    If iCnt > 0 Then
        ParamSideAvg = n / iCnt
    Else
        ParamSideAvg = NaN
    End If
End Function



---

Also, I suppose I could have also done all this for IEEE Singles, but I don't currently have the need.

Enjoy,
Elroy

[vb6] Enhancing VB's StdPicture Object to Support GDI+

March 19, 2018, 10:05 am

≫ Next: VB6 - Elliptical Curve Diffie Hellman (ECDH) Demo

≪ Previous: IEEE Doubles: NaN, Infinity, etc.

$

0

0

This is my second version of the logic first introduced here. That version will no longer be supported.

This version offers so much more:
1. GDI+ can be used for improved scaling for all image formats
2. Better (far more complex) thunk used for managing stdPictures
3. Callbacks can be requested so you can respond to the entire rendering process
4. Can attach GDI+ image attributes (grayscaling/blending) to managed images
5. Can modify GDI+ graphics object during callbacks, i.e., rotation (sample in attached zip)
6. Can cache original image format and retrieve for saving to file
7. Can return embedded image DPI value
8. Written to address backward and future version compatibility
9. Only affects those stdPicture objects that are managed

As with the previous version of this class, many image formats are supported:
- BMP. Those with valid alpha channels can be rendered with transparency. VB-unsupported formats are supported and include: those with v4/v5 bitmap headers and those with JPG/PNG compression
- JPG. CMYK color-space supported via GDI+. Camera-orientation correction supported
- ICO. Alphablended and PNG-encoded icons are supported
- CUR. Same as icons and also color cursors can be returned while in IDE, unlike VB
- WMF/EMF. Not directly managed, no need. Non-placeable WMFs are supported
- PNG. Supported via GDI+, APNG is not
- TIF. Supported via GDI+, multi-page navigation supported
- GIF. Rendering of individual frames (animated GIF) supported via GDI+
- For any other format, if you can convert it to bitmap (alpha channel or not), then supported

The enclosed class offers several methods for managing stdPictures, among those:
- LoadPictureEx creates a new stdPicture object by file, array or handle and supports unicode file names
- LoadResPictureEx is a slightly extended version of VB's LoadResPicture function
- ManageStdPicture manages/un-manages existing stdPicture objects
- CopyStdPicture can copy/create/convert icons and bitmaps with/without alpha channels
- PaintPictureEx is a substitute for VB's PaintPicture based on the stdPicture.Render method
- SetCallBacks enables receiving one or more of the 4 available callbacks
- SetImageAttributesHandle associates user-provided GDI+ attributes with a managed image
- PictureTypeEx can return the actual image format, i.e., PNG, JPG, TIF, etc
- SetFrameGIF/GetGifAnimationInfo applies for animated GIFs when managed
- SetPageTIF applies for muliti-page TIFs when managed
- GetFramePageCount will return count for managed GIF/TIF
- several other methods are available for optional settings

--------------------------------------------------------------------------
The attachments below are the sample project (all in one zip is over 500k & forum rejected it). The 1st three below must be unzipped in same folder. The stdPicEx2 class is a stand-alone class. The rest of the files are to show-off some of its capabilities. The 4th one below is documentation that you may be interested in. It also includes the thunk raw source before I compiled it with NASM.

Project not guaranteed to be compatible with systems lower than XP, but XP/Win2K and above should be supported.

The sample project includes GIF animation, PNG/TIF support, alphablended icon support, JPG camera-orientation correction and more. Just FYI: If the StdPicEx2 class is ever included as its own attachment below, it will be an updated version that may not be in the sample project.

Latest changes...
Found minor bug when owner-drawn style attempted to be unmanaged. Fixed and updated the testProject.zip.

Attached Files

• testProject.zip (416.7 KB)
• project_Res.zip (133.7 KB)
• sample_tiff.zip (418.3 KB)
• documentation.zip (52.6 KB)

VB6 - Elliptical Curve Diffie Hellman (ECDH) Demo

March 19, 2018, 11:21 am

≫ Next: Remember Form's Position for Next Execution, Multi-Monitor

≪ Previous: [vb6] Enhancing VB's StdPicture Object to Support GDI+

$

0

0

The heart of this demo is the "GetECCKey" function. It is a dual purpose function, requiring 4 supplied variables (pAlg, KeyLen, bPublicECCKey, & bPrivateECCKey). "pAlg" is a pointer to the wide string descriptor of the algorithm used ("SHA256"). "KeyLen" is self explanatary (256), and "bPublicECCKey" & "bPrivateECCKey" are the Public\Private key pair. If the key fields are empty, the function generates and returns a new key pair. If the Private key, and the Public key from the other end are supplied, then the function returns the Agreed Secret.

So how do we know if it is returning the correct information? For this, we look to RFC 5903. It supplies 2 key pairs and the Agreed Secret they should return.
--------------------------------------------------------------------------
We suppose that the initiator's Diffie-Hellman private key is:
i: C88F01F5 10D9AC3F 70A292DA A2316DE5 44E9AAB8 AFE84049 C62A9C57 862D1433
Then the public key is given by g^i=(gix,giy) where:
gix: DAD0B653 94221CF9 B051E1FE CA5787D0 98DFE637 FC90B9EF 945D0C37 72581180
giy: 5271A046 1CDB8252 D61F1C45 6FA3E59A B1F45B33 ACCF5F58 389E0577 B8990BB3
The KEi payload is as follows.
00000048 00130000 DAD0B653 94221CF9 B051E1FE CA5787D0 98DFE637 FC90B9EF
945D0C37 72581180 5271A046 1CDB8252 D61F1C45 6FA3E59A B1F45B33 ACCF5F58
389E0577 B8990BB3
--------------------------------------------------------------------------
But that doesn't exactly describe how Microsoft wants the information. CNG requires the Private key to include the Public key, and the "Magic" description in the first 8 bytes is different.

Code:

---

Public Key A
45 43 4B 31 20 00 00 00 (ECK1 )
DA D0 B6 53 94 22 1C F9 B0 51 E1 FE CA 57 87 D0
98 DF E6 37 FC 90 B9 EF 94 5D 0C 37 72 58 11 80
52 71 A0 46 1C DB 82 52 D6 1F 1C 45 6F A3 E5 9A
B1 F4 5B 33 AC CF 5F 58 38 9E 05 77 B8 99 0B B3
Private Key A
45 43 4B 32 20 00 00 00 (ECK2 )
DA D0 B6 53 94 22 1C F9 B0 51 E1 FE CA 57 87 D0
98 DF E6 37 FC 90 B9 EF 94 5D 0C 37 72 58 11 80
52 71 A0 46 1C DB 82 52 D6 1F 1C 45 6F A3 E5 9A
B1 F4 5B 33 AC CF 5F 58 38 9E 05 77 B8 99 0B B3
C8 8F 01 F5 10 D9 AC 3F 70 A2 92 DA A2 31 6D E5
44 E9 AA B8 AF E8 40 49 C6 2A 9C 57 86 2D 14 33

---

--------------------------------------------------------------------------
We suppose that the response Diffie-Hellman private key is:
r: C6EF9C5D 78AE012A 011164AC B397CE20 88685D8F 06BF9BE0 B283AB46 476BEE53
Then the public key is given by g^r=(grx,gry) where:
grx: D12DFB52 89C8D4F8 1208B702 70398C34 2296970A 0BCCB74C 736FC755 4494BF63
gry: 56FBF3CA 366CC23E 8157854C 13C58D6A AC23F046 ADA30F83 53E74F33 039872AB
The KEr payload is as follows.
00000048 00130000 D12DFB52 89C8D4F8 1208B702 70398C34 2296970A 0BCCB74C
736FC755 4494BF63 56FBF3CA 366CC23E 8157854C 13C58D6A AC23F046 ADA30F83
53E74F33 039872AB
The Diffie-Hellman common value (girx,giry) is:
girx: D6840F6B 42F6EDAF D13116E0 E1256520 2FEF8E9E CE7DCE03 812464D0 4B9442DE
giry: 522BDE0A F0D8585B 8DEF9C18 3B5AE38F 50235206 A8674ECB 5D98EDB2 0EB153A2
The Diffie-Hellman shared secret value is girx.
--------------------------------------------------------------------------

Code:

---

Public Key B
45 43 4B 31 20 00 00 00 (ECK1 )
D1 2D FB 52 89 C8 D4 F8 12 08 B7 02 70 39 8C 34
22 96 97 0A 0B CC B7 4C 73 6F C7 55 44 94 BF 63
56 FB F3 CA 36 6C C2 3E 81 57 85 4C 13 C5 8D 6A
AC 23 F0 46 AD A3 0F 83 53 E7 4F 33 03 98 72 AB
Private Key B
45 43 4B 32 20 00 00 00 (ECK2 )
D1 2D FB 52 89 C8 D4 F8 12 08 B7 02 70 39 8C 34
22 96 97 0A 0B CC B7 4C 73 6F C7 55 44 94 BF 63
56 FB F3 CA 36 6C C2 3E 81 57 85 4C 13 C5 8D 6A
AC 23 F0 46 AD A3 0F 83 53 E7 4F 33 03 98 72 AB
C6 EF 9C 5D 78 AE 01 2A 01 11 64 AC B3 97 CE 20
88 68 5D 8F 06 BF 9B E0 B2 83 AB 46 47 6B EE 53

---

When Private Key A and Public Key B are supplied to "GetECCKey", it returns:

Code:

---

D6 84 0F 6B 42 F6 ED AF D1 31 16 E0 E1 25 65 20
2F EF 8E 9E CE 7D CE 03 81 24 64 D0 4B 94 42 DE

---

And when Private Key B and Public Key A are supplied to "GetECCKey", it also returns:

Code:

---

D6 84 0F 6B 42 F6 ED AF D1 31 16 E0 E1 25 65 20
2F EF 8E 9E CE 7D CE 03 81 24 64 D0 4B 94 42 DE

---

But the program returns a different key:
Key

Code:

---

05 19 DC 09 B3 6E FA D1 D0 0A EF 1D 5B 53 B1 00
20 2E B9 10 B5 DE 0D ED E7 5F 19 0A 35 7A 36 7D

---

Therein lies one of the major problems with CNG. The only way to recover the Agreed Secret is as a hashed value, and Microsoft does not supply a NULL hash. If we click the Hash button, it uses an SHA256 hash on the value supplied by RFC 5903.
Hashed Secret

Code:

---

05 19 DC 09 B3 6E FA D1 D0 0A EF 1D 5B 53 B1 00
20 2E B9 10 B5 DE 0D ED E7 5F 19 0A 35 7A 36 7D

---

J.A. Coutts

Attached Images

 

Attached Files

• ECDH.zip (109.3 KB)

Remember Form's Position for Next Execution, Multi-Monitor

March 22, 2018, 3:53 pm

≫ Next: VB6 - Remember App window Position and Size

≪ Previous: VB6 - Elliptical Curve Diffie Hellman (ECDH) Demo

$

0

0

Here's something I just cobbled together for a project I'm working on, and this occasionally comes up in these forums.

It's a couple of procedures (with support procedures) for saving the last position of a form, and putting it back there the next time it's shown. Now, this is easy so long as we only have one monitor. However, things get a bit tricky when we're on a multi-monitor system, and especially if that system may often have different monitor configurations (such as my laptop I haul around with me all over the place).

These procedures should be robust to changes in configurations. Furthermore, they make sure the form will always be fully shown on some monitor the next time it's shown.

The registry is used to store last position, so it'll be machine/user specific.

It's very easy to use. Here's an example in a form:

Code:

---


Option Explicit

Private Sub Form_Load()
    FetchAndSetFormPos Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    SaveFormPos Me
End Sub



---

And here's code for it that you can throw into a BAS module:

Code:

---


Option Explicit
'
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Type RECT
    Left  As Long
    Top  As Long
    Right As Long ' This is +1 (right - left = width)
    Bottom As Long ' This is +1 (bottom - top = height)
End Type
Private Type MONITORINFO
    cbSize As Long
    rcMonitor As RECT
    rcWork As RECT
    dwFlags As Long
End Type
'
Private Declare Function EnumDisplayMonitors Lib "user32" (ByVal hdc As Long, lprcClip As Any, ByVal lpfnEnum As Long, dwData As Long) As Long
Private Declare Function MonitorFromWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal dwFlags As Long) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" (ByVal hMonitor As Long, ByRef lpmi As MONITORINFO) As Long
'

Public Sub FetchAndSetFormPos(frm As Form, Optional TopPixelsAdd As Long, Optional LeftPixelsAdd As Long)
    ' Initial (default) position is in center, biased toward top.
    ' The TopPixelsAdd and LeftPixelsAdd can be used to move from the center (top biased) default position.  They can be negative.
    '
    Dim iMon As Long
    Dim iTop As Long
    Dim iLeft As Long
    Dim hMonitor As Long
    Dim iFrmHeight As Long
    Dim iFrmWidth As Long
    Dim iMonHeight As Long
    Dim iMonWidth As Long
    '
    iFrmHeight = WindowHeightPx(frm.hWnd)
    iFrmWidth = WindowWidthPx(frm.hWnd)
    '
    iMon = GetSetting(App.Title, "Settings", frm.Name & "Mon", 1&)
    If iMon < 1& Then iMon = 1&
    If iMon > MonitorCount Then iMon = 1&
    hMonitor = MonitorHandle(iMon)
    iMonHeight = MonitorHeightPx(hMonitor)
    iMonWidth = MonitorWidthPx(hMonitor)
    '
    iTop = GetSetting(App.Title, "Settings", frm.Name & "Top", (iMonHeight - iFrmHeight) \ 3 + TopPixelsAdd)
    iLeft = GetSetting(App.Title, "Settings", frm.Name & "Left", (iMonWidth - iFrmWidth) \ 2 + LeftPixelsAdd)
    If iTop + iFrmHeight > iMonHeight Then iTop = iMonHeight - iFrmHeight
    If iLeft + iFrmWidth > iMonWidth Then iLeft = iMonWidth - iFrmWidth
    If iTop < 0 Then iTop = 0
    If iLeft < 0 Then iLeft = 0
    '
    PositionWindowOnMonitor frm.hWnd, hMonitor, iLeft, iTop
End Sub

Public Sub SaveFormPos(frm As Form)
    SaveSetting App.Title, "Settings", frm.Name & "Top", WindowTopPx(frm.hWnd)
    SaveSetting App.Title, "Settings", frm.Name & "Left", WindowLeftPx(frm.hWnd)
    SaveSetting App.Title, "Settings", frm.Name & "Mon", MonitorNumForHwnd(frm.hWnd)
End Sub

Public Function MonitorCount() As Long
    EnumDisplayMonitors 0&, ByVal 0&, AddressOf MonitorCountEnum, MonitorCount
End Function

Private Function MonitorCountEnum(ByVal hMonitor As Long, ByVal hdcMonitor As Long, uRect As RECT, dwData As Long) As Long
    dwData = dwData + 1
    MonitorCountEnum = 1 ' Count them all.
End Function

Public Function MonitorNumForHwnd(hWnd As Long) As Long
    MonitorNumForHwnd = MonitorNum(MonitorHandleForHwnd(hWnd))
End Function

Public Function MonitorHandleForHwnd(hWnd As Long) As Long
    Const MONITOR_DEFAULTTONULL = &H0
    MonitorHandleForHwnd = MonitorFromWindow(hWnd, MONITOR_DEFAULTTONULL)
End Function

Public Function MonitorNum(hMonitor As Long) As Long
    ' This one returns the monitor number from the monitor's handle.
    ' ZERO is returned if not found.
    ' Monitors are ONE based when counted, no holes.
    ' These numbers do NOT necessarily match numbers in control panel.
    Dim dwData As Long
    dwData = -hMonitor  ' Send it in negative to indicate first iteration.
    EnumDisplayMonitors 0&, ByVal 0&, AddressOf MonitorNumEnum, dwData
    If Abs(dwData) <> hMonitor Then MonitorNum = dwData                          ' The number is returned in dwData if found.
End Function

Private Function MonitorNumEnum(ByVal hMonitor As Long, ByVal hdcMonitor As Long, uRect As RECT, dwData As Long) As Long
    Static iCount As Long
    If dwData < 0 Then
        iCount = 1
        dwData = -dwData
    Else
        iCount = iCount + 1
    End If
    If dwData = hMonitor Then
        dwData = iCount
        MonitorNumEnum = 0 ' Found it.
    Else
        MonitorNumEnum = 1 ' Keep looking.
    End If
End Function

Public Sub PositionWindowOnMonitor(hWnd As Long, hMonitor As Long, ByVal lLeftPixel As Long, ByVal lTopPixel As Long)
    ' This can be used to position windows on other programs so long as you have the hWnd.
    Dim lHeight As Long
    Dim lWidth As Long
    '
    lHeight = WindowHeightPx(hWnd)
    lWidth = WindowWidthPx(hWnd)
    '
    lLeftPixel = lLeftPixel + MonitorLeftPx(hMonitor)
    lTopPixel = lTopPixel + MonitorTopPx(hMonitor)
    '
    MoveWindow hWnd, lLeftPixel, lTopPixel, lWidth, lHeight, 1&
End Sub

Public Function WindowHeightPx(hWnd As Long) As Long
    Dim r As RECT
    GetWindowRect hWnd, r
    WindowHeightPx = r.Bottom - r.Top
End Function

Public Function WindowWidthPx(hWnd As Long) As Long
    Dim r As RECT
    GetWindowRect hWnd, r
    WindowWidthPx = r.Right - r.Left
End Function

Public Function WindowTopPx(hWnd As Long) As Long
    ' This adjusts for the monitor the window is on.
    Dim r As RECT
    GetWindowRect hWnd, r
    WindowTopPx = r.Top - MonitorTopPx(MonitorHandleForHwnd(hWnd))
End Function

Public Function WindowLeftPx(hWnd As Long) As Long
    ' This adjusts for the monitor the window is on.
    Dim r As RECT
    GetWindowRect hWnd, r
    WindowLeftPx = r.Left - MonitorLeftPx(MonitorHandleForHwnd(hWnd))
End Function

Public Function MonitorLeftPx(hMonitor As Long) As Long
    ' If you just have the number, do: MonitorLeftPx(MonitorHandle(MonitorNum))
    Dim uMonInfo As MONITORINFO
    uMonInfo.cbSize = LenB(uMonInfo)
    If GetMonitorInfo(hMonitor, uMonInfo) = 0 Then Exit Function
    MonitorLeftPx = uMonInfo.rcMonitor.Left
End Function

Public Function MonitorTopPx(hMonitor As Long) As Long
    ' If you just have the number, do: MonitorTopPx(MonitorHandle(MonitorNum))
    Dim uMonInfo As MONITORINFO
    uMonInfo.cbSize = LenB(uMonInfo)
    If GetMonitorInfo(hMonitor, uMonInfo) = 0 Then Exit Function
    MonitorTopPx = uMonInfo.rcMonitor.Top
End Function

Public Function MonitorHandle(ByVal MonitorNum As Long) As Long
    ' Monitors are ONE based when counted, no holes.
    ' These numbers do NOT necessarily match numbers in control panel.
    Dim dwData As Long
    dwData = -MonitorNum  ' Send it in negative.
    EnumDisplayMonitors 0&, ByVal 0&, AddressOf MonitorHandleEnum, dwData
    If dwData > 0 Then MonitorHandle = dwData                          ' The handle is returned in dwData if found.
End Function

Private Function MonitorHandleEnum(ByVal hMonitor As Long, ByVal hdcMonitor As Long, uRect As RECT, dwData As Long) As Long
    dwData = dwData + 1 ' They come in negative to stay out of the way of handles.
    If dwData = 0 Then ' We're at the one we want.
        dwData = hMonitor
        MonitorHandleEnum = 0
    Else
        MonitorHandleEnum = 1
    End If
End Function

Public Function MonitorWidthPx(hMonitor As Long) As Long
    ' If you just have the number, do: MonitorWidthPx(MonitorWidthPx(MonitorNum))
    Dim uMonInfo As MONITORINFO
    uMonInfo.cbSize = LenB(uMonInfo)
    If GetMonitorInfo(hMonitor, uMonInfo) = 0 Then Exit Function
    MonitorWidthPx = uMonInfo.rcMonitor.Right - uMonInfo.rcMonitor.Left
End Function

Public Function MonitorHeightPx(hMonitor As Long) As Long
    ' If you just have the number, do: MonitorHeightPx(MonitorWidthPx(MonitorNum))
    Dim uMonInfo As MONITORINFO
    uMonInfo.cbSize = LenB(uMonInfo)
    If GetMonitorInfo(hMonitor, uMonInfo) = 0 Then Exit Function
    MonitorHeightPx = uMonInfo.rcMonitor.Bottom - uMonInfo.rcMonitor.Top
End Function



---

All will work fine in the IDE. However, the last form position won't be saved if you use the IDE's stop button. I didn't want to use sub-classing, so I don't have any way to track form movement, other than querying it when the form closes.

Enjoy,
Elroy

EDIT1: Also, it should work just fine for as many forms as you'd like to use it for in a project.

VB6 - Remember App window Position and Size

March 24, 2018, 2:27 pm

≫ Next: [VB6] Neural Network

≪ Previous: Remember Form's Position for Next Execution, Multi-Monitor

$

0

0

Attached is a demo of saving and restoring an application position and size. Rather than hijacking Elroy's thread, I decided to create a new one. This code is further simplified from the code that I supplied there, in that it eliminates the need for the SysInfo control and doesn't account for the Taskbar. It also demonstrates how the onboard controls are adjusted when the form size is adjusted. This is a fairly simple demonstration, and more complex forms will take quite a bit more work. The "EXIT" button is there simply to allow the form to be unloaded when the right side is off the screen. The "InitFlg" in the "Resize" event simply prevents the controls from being adjusted on the intial activation.

The InkEdit control used as "Text1" should allow for the use of Unicode characters.

J.A. Coutts

Attached Images

 

Attached Files

• Demofrm.zip (2.7 KB)

[VB6] Neural Network

March 29, 2018, 10:11 am

≫ Next: PNG (specifically 32-bit RGBA type PNG) Editing Tool

≪ Previous: VB6 - Remember App window Position and Size

$

0

0

Since a neural network is missing in the codebank
here is my version:

It's very simple.

It initializes with "CREATE"

Code:

---

  NN.CREATE Array (2, 2, 1), 0.25, 4

---

-Where Array indicates the NN topology
Array (N of Inputs, Hidden layer neurons, ..., Hidden layer neurons, N of outputs)
-The second term is the Learning Rate.
-The third is the initial range of connections. (this value, together with the Learning Rate is very important and can drastically change the learning outcomes)

To get the output just call RUN with an array of inputs as arguments,
Return the Outputs Array

For learning (which is supervided) just call TRAIN.
The arguments are an array of Inputs and an array of expected Outputs
The learning process is done by backpropagation, the code is taken (and modified) by an article by Paras Chopra.

Neurons Index "Zero" [0] of each Layer is used for Bias. It is always 1 (The Biases are the weights of connections from 0-indexs neurons to next layer neurons) [Still not sure this way is correct tough]

Inputs and outputs range is from -1 to 1
the Activation function used is TANH.

Probably I'll put it on Github.

Enjoy

And, as always, if anyone has ideas to improve it, it's welcome

Attached Files

• NNstd.zip (12.8 KB)

PNG (specifically 32-bit RGBA type PNG) Editing Tool

March 30, 2018, 10:12 am

≫ Next: [vb6] GDI+ Image Attributes Intro & Usage

≪ Previous: [VB6] Neural Network

$

0

0

Hi All,

This was a request and I thought it would be fun. It turned out to be quite the learning experience.

Basically, I've developed a tool for editing the Gamma, Brightness, or Contrast of a 32-bit RGBA type PNG image. Sorry, but it's specifically limited to that type of an image file.

Here's a screen-shot of the main form:


Basically, when you open a PNG file, it loads it (via GDI+), displays it on a form, splits it into four channels (Red, Green, Blue, & Alpha), displays each of these on separate forms, and then displays one last form that shows modifications to the image. Here's a reduced screen-shot of how it looks:



A couple of caveats: I do use SaveSettings to save a few things to the registry. I know that some people are concerned about this. Therefore, if you're running in the IDE, upon normal exit, I ask if you'd like to delete all of these settings.

Also, to try and keep things speedy, I startup the GDI+ upon opening the app, and don't shut it down until you're exiting. I didn't have any problems with the IDE stop button, but I'm not totally clear on whether or not an IDE stop is totally safe here. I'm hoping that the worst case is a memory leak (that's cleared up when you exit the IDE).

The entire project is in the attachment to this post. A PNG file has also been supplied for you to play with (same one shown).

Now, I'd also like to take this opportunity to outline how I did things. Basically (because I want to handle PNG files with an active Alpha channel), I used the GDI+ to load the image. And then I immediately use the GDI+ to show this original image. Next, I get the image's RgbQuad() data, and then split that into its separate channels, creating separate arrays for Red, Green, Blue, & Alpha. And then I use the regular GDI32's SetDIBits to show these channels on the separate forms. And then, I take the four RgbQuad() channel arrays, re-combine them, and then show them on a Modifications form (using GDI+ and the still open hBitmap to do this).

Just as an FYI, the individual RgbQuad() channel arrays have no Alpha in them (it's always zero). The original image's Alpha channel is copied into the Red, Green, & Blue channels of the Alpha's RgbQuad() array, effectively creating a gray-scale image to show the Alpha channel.

I also "save in memory" all kinds of information (thinking that this would keep things speedy). Therefore, this thing is not memory efficient. Here's a list of what I maintain in memory:

1. I keep the original file open (hBitmat) with the GDI+.
2. I keep the original RgbQuad().
3. I keep each channel's original RgbQuad() (four of them).
4. I keep each channel's modified RgbQuad() (four of them).
5. I keep a modified RgbQuad() of the full modified image.

Some of the things I learned during all of this:

• When leaving a PNG file open (active hBitmap) with GDI+, somehow, GDI+ keeps its hooks into that file until you execute a GdipDisposeImage (or something similar).

• These PNG files can have a DPI scaling factor embedded in them that makes using GdipDrawImage a bit dubious. If you want to "think" in pixels, this will get fouled up. To "think" in pixels, you must use GdipDrawImageRectI.

• The GDI+ seems to prefer scanning images from top-down, whereas the GDI32 prefers seeing them as bottom-up. That just caused me to jump through a few hoops to tell the GDI+ that I want them bottom-up so that I'm not constantly flipping them.

• As I got into it, it dawned on me that the order in which Gamma, Brightness, & Contrast are applied might matter. The approach I took was to always go back to the original image when making changes (and hence saving all those RgbQuad() arrays). Always going back to the original allows me to return to that original while editing, if I so desire. Rather than get overly complicated, I just decided on a Gamma(first), Brightness(second), & Contrast(last) approach to applying things.

• I also learned that Contrast can be complicated. There are several theories/ideas on how this should be done. I'm not entirely happy with my approach, but it works. I save the mean value (as a Single) of each of the channels upon load. And then, pixels are either stretched away from (or pushed toward) this mean to achieve contrast changes. Other approaches would be to go toward or away from 128 (middle value). Yet another approach would be to calculate the mean each time (thereby accounting for brightness and gamma changes) but this could have speed consequences.

• I also learned that, with larger images, my approach can bog down. At first, I was showing all changes "in real time" on each click of a control. However, it quickly became apparent that this wasn't going to work. Therefore, I implemented a timer that fires every 200ms. If a bIsModDirty flag is true and if the mouse button isn't down, it calculates and shows the changes. This allows the interface to work much more smoothly, although you don't see changes until you release the mouse button.

And, here's a list of things I may want to consider for the future:

• Possibly exploring (learning more about) how to use the GDI+ to do my Gamma, Brightness, Contrast changes. I feel certain it's capable of this, and it may make the entire project more memory efficient, and possibly more speedy as well.

• Possibly learn how to read a TGA (Targa) file as well. This was actually part of the original request, but I had to start somewhere. If I do this, I'd probably want my SaveAs... to be able to convert between the two.

• Think more about the order in which the effects are applied (especially since I'm always going back to the original). I might let that be user-specified, just to see what difference it makes.

• Possibly consider additional effects (soften, sharpen, etc.).

I've done my level-headed best to keep this code as organized as possible. However, I do use somewhat deeply nested UDTs to keep track of everything. However, for a somewhat seasoned VB6 programmer, that shouldn't be a huge deal.

If you're interested in studying this code for purposes of how to manipulate images, the place to start is the code in frmMain. And then, you'll want to get into the modPng code, and then the modGdip code. I've tried to make the modGdip code as generic as possible (i.e., not really tied to the specifics of this project). The code in modPng is rather specific to this project. You'll see all the stuff that's maintained in memory in the ThePng UDT variable that's in the modPng file. There's also a touch of GDI32 stuff in the modPng file.

Version 1.03 (original release)

Enjoy,
Elroy

p.s. Please stay focused and please don't be upset if I don't respond to all of these, but critiques and suggestions for improvement are welcomed and encouraged.

Attached Images

  

Attached Files

• PngEditor.zip (181.8 KB)

---

[vb6] GDI+ Image Attributes Intro & Usage

April 1, 2018, 2:41 pm

≫ Next: VB6 - Sort Routine

≪ Previous: PNG (specifically 32-bit RGBA type PNG) Editing Tool

$

0

0

Thought it would be worthwhile sharing some information regarding GDI+ and its Image Attributes object. Specifically, we are going to discuss the color matrix. This is a 5x5 matrix/grid, variable type: Single.

GDI+ uses this matrix to change image color values, on-the-fly. This prevents you from having to manipulate and change individual color values by hand. Since the matrix is basically a batch, of sorts, of formulas applied to each pixel value, there is little that cannot be done and limited only by imagination or creativity.

The project included below is provided to get your feet wet. There exists on many sites sample matrices you can use to achieve many different color transformations. Wouldn't be a bad idea to start collecting these and storing away for future use. This project, though truly a demo, offers a method to save and load your personal collections of matrices (assuming they were saved while using the demo).

The project is also designed to punch in any matrix values you want and see the results with a click of a button. Like what you see after your changes? Save the matrix or copy the matrix to the clipboard and paste into your project.

I've included a sample PNG in the file, but the project allows you to select images from your computer. I'm sure some of you will ask questions, but let's not discuss modifying the demo project... let's talk about GDI+ image attributes.

This is a good link to read a bit more about GDI+ color matrices. The link starts at page 7 at that site, be sure to browse some of the other pages too.

Here is another site that has sample matrices while also discussing the color matrix. You'll also see where I got the sepia matrix from, hint hint. In the demo project below, I am also defining brightness differently than most. But that shouldn't matter. Use whatever matrix you wish for your particular needs.

Screenshot below is a more complex matrix. Most matrices are just 3-5 non-zero entries.



Note for non-US locales, use US decimals. The project expects that format in the textboxes.

Until I fix this and repost, in Form_Unload, move the line "GdiplusShutdown m_Token" to just before the "End If" line. Can't shut down GDI+ then attempt to dispose of a GDI+ object, now can we?

Attached Images

 

Attached Files

• GDIpAttrs.zip (113.8 KB)

VB6 - Sort Routine

April 4, 2018, 9:29 am

≫ Next: PNG/TGA (specifically 32-bpp type files) Editing Tool

≪ Previous: [vb6] GDI+ Image Attributes Intro & Usage

$

0

0

Shown here is a sort routine that utilizes the built in Command Line sort function. Outside of this routine, a file is loaded into a Textbox and the file name is saved in "m_Filename". The user is first asked where in each line the sort is to start. I use this routine to sort log files, which often begin with a time stamp. The file is appended chronologically, so it is already sorted by time. For example:

00:03:14 Request from 74.125.80.70 for TXT-record for _adsp._domainkey.yellowhead.com.
00:03:15 Sending reply to 74.125.80.70 about TXT-record for _adsp._domainkey.yellowhead.com.:
00:03:16 -> Header: Name does not exist!

I am only interested in the "Request" part of it, so I would start at position 25. I can then easily delete the unwanted portions.

The sorted file is temporarily stored in the users "Temp" directory. You will probably find lots of junk in that directory, as many programs are not very good at cleaning up after themselves. We will attempt not to be one of those, and "Kill" off the file after we are done with it.

The heart of the routine is the "Shell" function. In that I use the seldom used "Environ" function to recover the "COMSPEC" string from the Environment. Environment variables will vary with the individual computer, and can be viewed from the Command Prompt with the "Set" command. To this I add "/c" to concatenate, the "type" command, the file name to sort, the pipe option (|), the "sort" command, and the name of the file to direct the output to. I also add a "vbHide" option, since we are not interested in displaying the results in a Command Prompt window.

We then enter a loop waiting for the directory to be updated. To prevent getting stuck in an endless loop, a counter is implemented. Since file I/O is a buffered operation, an additional 100 ms delay is added to allow for the write operation to complete. The "Loadfile" routine loads the newly sorted file back into the Textbox. We use another 100 ms delay to allow that operation to complete before we delete the temporary file. We then restore the App.Path and the original file name.

Code:

---

Private Sub mnuSort_Click()
    Dim sTmp As String
    Dim lCntr As Long
    Dim SortStart As Long
    Dim SortCmd As String
    If Len(m_Filename) = 0 Then
        MsgBox "Text must be saved as a file before it can be sorted!", vbExclamation
        Exit Sub
    End If
    SortStart = InputBox("Enter character count to start at - ", "Start", 0)
    If SortStart = 0 Then
        SortCmd = "|sort>tmpsort.txt" 'Default starts at beginning of line
    Else
        SortCmd = "|sort /+" & CStr(SortStart) & ">tmpsort.txt"
    End If
    ChDir TmpPath 'Sorted file is output to temp path
    sTmp = m_Filename 'Save current file location
    Debug.Print Timer
    Call Shell(Environ("COMSPEC") & " /c type " & m_Filename & SortCmd, vbHide)
    m_Filename = "tmpsort.txt" 'Change filename to sorted file
    Do Until Dir(m_Filename) = m_Filename 'Wait for directory to be updated
        DoEvents
        Sleep 10
        lCntr = lCntr + 1
        If lCntr > 100 Then GoTo SortErr
    Loop
    Debug.Print lCntr
    Sleep 100 'Wait an additional 100 ms for file write to complete
    Debug.Print Timer
    LoadFile 'Load sorted file to Textbox
    Sleep 100 'Wait an additional 100 ms for sorted file to load
    Kill m_Filename
    Debug.Print Timer
    m_Filename = sTmp 'Restore original filename
    ChDir App.Path 'Restore Application path
    m_Flg1 = True 'Set change flag
    Exit Sub
SortErr:
    MsgBox "Sort Timed out!"
End Sub

Private Const MAX_PATH = 260
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Function GetTmpPath() As String
    Dim sFolder As String ' Name of the folder
    Dim lRet As Long ' Return Value
    sFolder = String(MAX_PATH, 0)
    lRet = GetTempPath(MAX_PATH, sFolder)
    If lRet <> 0 Then
        GetTmpPath = Left(sFolder, InStr(sFolder, Chr(0)) - 1)
    Else
        GetTmpPath = vbNullString
    End If
End Function

---

I have found this routine to be a lot faster than any algorithm I could put together in VB6, especially for large text files. For the most part it is an in-memory sort, but for very large files it will temporarily store the first run to the disk before attempting the second run. An example of how to use this routine will be forthcoming in the near future.

J.A. Coutts

PNG/TGA (specifically 32-bpp type files) Editing Tool

March 30, 2018, 10:12 am

≫ Next: Standard API Color Picker

≪ Previous: VB6 - Sort Routine

$

0

0

Note, this project uses mscomctl.ocx version 2.2. If you have an older version, the project may not load correctly for you. To fix this problem, you will need to update your mscomctl.ocx. Here's a link to a post by LaVolpe that explains the issue more fully, and provides links for the updates. Also, mscomct2.ocx version 2.0 is used for the status bar. If you have an older version of that, you may need to update it as well (or remove the status bar, which wouldn't be difficult).

Version 1.03 (original release, attached to this OP)
Version 1.04 released in post #16
Version 1.05 released in post #17
Version 1.06 released in post #18

Hi All,

This was a request and I thought it would be fun. It turned out to be quite the learning experience.

Basically, I've developed a tool for editing the Gamma, Brightness, or Contrast of a 32-bit RGBA type PNG or TGA image. Sorry, but it's specifically limited to that type of an image file.

Here's a screen-shot of the main form:


Basically, when you open a PNG file, it loads it (via GDI+), displays it on a form, splits it into four channels (Red, Green, Blue, & Alpha), displays each of these on separate forms, and then displays one last form that shows modifications to the image. Here's a reduced screen-shot of how it looks:



A couple of caveats: I do use SaveSettings to save a few things to the registry. I know that some people are concerned about this. Therefore, if you're running in the IDE, upon normal exit, I ask if you'd like to delete all of these settings.

Also, to try and keep things speedy, I startup the GDI+ upon opening the app, and don't shut it down until you're exiting. I didn't have any problems with the IDE stop button, but I'm not totally clear on whether or not an IDE stop is totally safe here. I'm hoping that the worst case is a memory leak (that's cleared up when you exit the IDE).

The entire project is in the attachment to this post. A PNG file has also been supplied for you to play with (same one shown).

Now, I'd also like to take this opportunity to outline how I did things. Basically (because I want to handle PNG files with an active Alpha channel), I used the GDI+ to load the image. And then I immediately use the GDI+ to show this original image. Next, I get the image's RgbQuad() data, and then split that into its separate channels, creating separate arrays for Red, Green, Blue, & Alpha. And then I use the regular GDI32's SetDIBits to show these channels on the separate forms. And then, I take the four RgbQuad() channel arrays, re-combine them, and then show them on a Modifications form (using GDI+ and the still open hBitmap to do this).

Just as an FYI, the individual RgbQuad() channel arrays have no Alpha in them (it's always zero). The original image's Alpha channel is copied into the Red, Green, & Blue channels of the Alpha's RgbQuad() array, effectively creating a gray-scale image to show the Alpha channel.

I also "save in memory" all kinds of information (thinking that this would keep things speedy). Therefore, this thing is not memory efficient. Here's a list of what I maintain in memory:

1. I keep the original file open (hBitmat) with the GDI+.
2. I keep the original RgbQuad().
3. I keep each channel's original RgbQuad() (four of them).
4. I keep each channel's modified RgbQuad() (four of them).
5. I keep a modified RgbQuad() of the full modified image.

Some of the things I learned during all of this:

• When leaving a PNG file open (active hBitmap) with GDI+, somehow, GDI+ keeps its hooks into that file until you execute a GdipDisposeImage (or something similar).

• These PNG files can have a DPI scaling factor embedded in them that makes using GdipDrawImage a bit dubious. If you want to "think" in pixels, this will get fouled up. To "think" in pixels, you must use GdipDrawImageRectI.

• The GDI+ seems to prefer scanning images from top-down, whereas the GDI32 prefers seeing them as bottom-up. That just caused me to jump through a few hoops to tell the GDI+ that I want them bottom-up so that I'm not constantly flipping them.

• As I got into it, it dawned on me that the order in which Gamma, Brightness, & Contrast are applied might matter. The approach I took was to always go back to the original image when making changes (and hence saving all those RgbQuad() arrays). Always going back to the original allows me to return to that original while editing, if I so desire. Rather than get overly complicated, I just decided on a Gamma(first), Brightness(second), & Contrast(last) approach to applying things.

• I also learned that Contrast can be complicated. There are several theories/ideas on how this should be done. I'm not entirely happy with my approach, but it works. I save the mean value (as a Single) of each of the channels upon load. And then, pixels are either stretched away from (or pushed toward) this mean to achieve contrast changes. Other approaches would be to go toward or away from 128 (middle value). Yet another approach would be to calculate the mean each time (thereby accounting for brightness and gamma changes) but this could have speed consequences.

• I also learned that, with larger images, my approach can bog down. At first, I was showing all changes "in real time" on each click of a control. However, it quickly became apparent that this wasn't going to work. Therefore, I implemented a timer that fires every 200ms. If a bIsModDirty flag is true and if the mouse button isn't down, it calculates and shows the changes. This allows the interface to work much more smoothly, although you don't see changes until you release the mouse button.

And, here's a list of things I may want to consider for the future:

• Possibly exploring (learning more about) how to use the GDI+ to do my Gamma, Brightness, Contrast changes. I feel certain it's capable of this, and it may make the entire project more memory efficient, and possibly more speedy as well.

• Possibly learn how to read a TGA (Targa) file as well. This was actually part of the original request, but I had to start somewhere. If I do this, I'd probably want my SaveAs... to be able to convert between the two.

• Think more about the order in which the effects are applied (especially since I'm always going back to the original). I might let that be user-specified, just to see what difference it makes.

• Possibly consider additional effects (soften, sharpen, etc.).

I've done my level-headed best to keep this code as organized as possible. However, I do use somewhat deeply nested UDTs to keep track of everything. However, for a somewhat seasoned VB6 programmer, that shouldn't be a huge deal.

If you're interested in studying this code for purposes of how to manipulate images, the place to start is the code in frmMain. And then, you'll want to get into the modPng code, and then the modGdip code. I've tried to make the modGdip code as generic as possible (i.e., not really tied to the specifics of this project). The code in modPng is rather specific to this project. You'll see all the stuff that's maintained in memory in the ThePng UDT variable that's in the modPng file. There's also a touch of GDI32 stuff in the modPng file.

Enjoy,
Elroy

p.s. Please stay focused and please don't be upset if I don't respond to all of these, but critiques and suggestions for improvement are welcomed and encouraged.

Attached Images

  

Attached Files

• PngEditor.zip (181.8 KB)

Standard API Color Picker

April 6, 2018, 4:43 pm

≫ Next: [VB6] BatchRtb 2

≪ Previous: PNG/TGA (specifically 32-bpp type files) Editing Tool

$

0

0

It's strange that this doesn't have more of a presence on these forums than it does, but hey ho.

Attached is the my ChooseColorAPI wrapper that I've just polished up. Here are its features:

• It just always opens allowing you to select custom colors.
• You can save the user-specified custom colors if you so choose (your application specific).
• It has the ability of allowing you to specify your own dialog title.
• You can double-click on the colors and they will auto-select and be returned to you.

Beyond that, it's pretty much the standard ChooseColorAPI function.

More could be done with this thing, but this is precisely what I needed, and I thought I'd share.

Here's code for a standard BAS module (everything needed, just focus on the ShowColorDialog procedure):

Code:

---


Option Explicit
'
' These are used to get information about how the dialog went.
Public ColorDialogSuccessful As Boolean
Public ColorDialogColor As Long
'
Private Type ChooseColorType
    lStructSize        As Long
    hWndOwner          As Long
    hInstance          As Long
    rgbResult          As Long
    lpCustColors      As Long
    flags              As Long
    lCustData          As Long
    lpfnHook          As Long
    lpTemplateName    As String
End Type
Private Enum ChooseColorFlagsEnum
    CC_RGBINIT = &H1                  ' Make the color specified by rgbResult be the initially selected color.
    CC_FULLOPEN = &H2                ' Automatically display the Define Custom Colors half of the dialog box.
    CC_PREVENTFULLOPEN = &H4          ' Disable the button that displays the Define Custom Colors half of the dialog box.
    CC_SHOWHELP = &H8                ' Display the Help button.
    CC_ENABLEHOOK = &H10              ' Use the hook function specified by lpfnHook to process the Choose Color box's messages.
    CC_ENABLETEMPLATE = &H20          ' Use the dialog box template identified by hInstance and lpTemplateName.
    CC_ENABLETEMPLATEHANDLE = &H40    ' Use the preloaded dialog box template identified by hInstance, ignoring lpTemplateName.
    CC_SOLIDCOLOR = &H80              ' Only allow the user to select solid colors. If the user attempts to select a non-solid color, convert it to the closest solid color.
    CC_ANYCOLOR = &H100              ' Allow the user to select any color.
End Enum
#If False Then ' Intellisense fix.
    Public CC_RGBINIT, CC_FULLOPEN, CC_PREVENTFULLOPEN, CC_SHOWHELP, CC_ENABLEHOOK, CC_ENABLETEMPLATE, CC_ENABLETEMPLATEHANDLE, CC_SOLIDCOLOR, CC_ANYCOLOR
#End If
Private Type KeyboardInput        '
    dwType As Long                ' Set to INPUT_KEYBOARD.
    wVK As Integer                ' shift, ctrl, menukey, or the key itself.
    wScan As Integer              ' Not being used.
    dwFlags As Long              '            HARDWAREINPUT hi;
    dwTime As Long                ' Not being used.
    dwExtraInfo As Long          ' Not being used.
    dwPadding As Currency        ' Not being used.
End Type
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Const WM_LBUTTONDBLCLK As Long = 515&
Private Const WM_SHOWWINDOW    As Long = 24&
Private Const WM_SETTEXT      As Long = &HC&
Private Const INPUT_KEYBOARD  As Long = 1&
Private Const KEYEVENTF_KEYUP  As Long = 2&
Private Const KEYEVENTF_KEYDOWN As Long = 0&
'
Private muEvents(1) As KeyboardInput    ' Just used to emulate "Enter" key.
Private pt32 As POINTAPI
Private msColorTitle As String
'
Private Declare Function ChooseColorAPI Lib "comdlg32" Alias "ChooseColorA" (pChoosecolor As ChooseColorType) As Long
Private Declare Function SendInput Lib "user32" (ByVal nInputs As Long, pInputs As Any, ByVal cbSize As Long) As Long
Private Declare Function SetFocusTo Lib "user32" Alias "SetFocus" (Optional ByVal hWnd As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ChildWindowFromPointEx Lib "user32" (ByVal hWnd As Long, ByVal xPoint As Long, ByVal yPoint As Long, ByVal uFlags As Long) As Long
Private Declare Function SendMessageWLong Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'

Public Function ShowColorDialog(hWndOwner As Long, Optional NewColor As Long, Optional Title As String = "Select Color", Optional CustomColorsHex As String) As Boolean
    ' You can optionally use ColorDialogSuccessful & ColorDialogColor or the return of ShowColorDialog and NewColor.  They will be the same.
    '
    ' CustomColorHex is a comma separated hex string of 16 custom colors.  It's best to just let the user specify these, starting out with all black.
    ' If this CustomColorHex string doesn't separate into precisely 16 values, it's ignored, resulting with all black custom colors.
    ' The string is returned, and it's up to you to save it if you wish to save your user-specified custom colors.
    ' These will be specific to this program, because this is your CustomColorsHex string.
    '
    Dim uChooseColor As ChooseColorType
    Dim CustomColors(15) As Long
    Dim sArray() As String
    Dim i As Long
    '
    msColorTitle = Title
    '
    ' Setup custom colors.
    sArray = Split(CustomColorsHex, ",")
    If UBound(sArray) = 15 Then
        For i = 0 To 15
            CustomColors(i) = Val("&h" & sArray(i))
        Next i
    End If
    '
    uChooseColor.hWndOwner = hWndOwner
    uChooseColor.lpCustColors = VarPtr(CustomColors(0))
    uChooseColor.flags = CC_ENABLEHOOK Or CC_FULLOPEN
    uChooseColor.hInstance = App.hInstance
    uChooseColor.lStructSize = LenB(uChooseColor)
    uChooseColor.lpfnHook = ProcedureAddress(AddressOf ColorHookProc)
    '
    ColorDialogSuccessful = False
    If ChooseColorAPI(uChooseColor) = 0 Then
        Exit Function
    End If
    If uChooseColor.rgbResult > &HFFFFFF Then Exit Function
    '
    ColorDialogColor = uChooseColor.rgbResult
    NewColor = uChooseColor.rgbResult
    ColorDialogSuccessful = True
    ShowColorDialog = True
    '
    ' Return custom colors.
    ReDim sArray(15)
    For i = 0 To 15
        sArray(i) = Hex$(CustomColors(i))
    Next i
    CustomColorsHex = Join(sArray, ",")
End Function

Private Function ColorHookProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If uMsg = WM_SHOWWINDOW Then
        SetWindowText hWnd, msColorTitle
        ColorHookProc = 1&
    End If
    '
    If uMsg = WM_LBUTTONDBLCLK Then
        '
        ' If we're on a hWnd with text, we probably should ignore the double-click.
        GetCursorPos pt32
        ScreenToClient hWnd, pt32
        '
        If WindowText(ChildWindowFromPointEx(hWnd, pt32.X, pt32.Y, 0&)) = vbNullString Then
            ' For some reason, this SetFocus is necessary for the dialog to receive keyboard input under certain circumstances.
            SetFocusTo hWnd
            ' Build EnterKeyDown & EnterKeyDown events.
            muEvents(0).wVK = vbKeyReturn: muEvents(0).dwFlags = KEYEVENTF_KEYDOWN: muEvents(0).dwType = INPUT_KEYBOARD
            muEvents(1).wVK = vbKeyReturn: muEvents(1).dwFlags = KEYEVENTF_KEYUP:  muEvents(1).dwType = INPUT_KEYBOARD
            ' Put it on buffer.
            SendInput 2&, muEvents(0), Len(muEvents(0))
            ColorHookProc = 1&
        End If
    End If
End Function

Private Function ProcedureAddress(AddressOf_TheProc As Long)
    ProcedureAddress = AddressOf_TheProc
End Function

Private Function WindowText(hWnd As Long) As String
    WindowText = Space$(GetWindowTextLength(hWnd) + 1)
    WindowText = Left$(WindowText, GetWindowText(hWnd, WindowText, Len(WindowText)))
End Function

Public Sub SetWindowText(hWnd As Long, sText As String)
    SendMessageWLong hWnd, WM_SETTEXT, 0&, StrPtr(sText)
End Sub



---

And, if you wish to just test/play, here's a bit of code for a Form1:

Code:

---


Option Explicit
'
Dim msOurCustomColors As String
'

Private Sub Form_Click()
    ShowColorDialog Me.hWnd, , "Pick a color for background", msOurCustomColors
    If ColorDialogSuccessful Then Me.BackColor = ColorDialogColor
End Sub


---

Enjoy,
Elroy

[VB6] BatchRtb 2

April 8, 2018, 9:13 am

≫ Next: VB6 - Multiline Textbox Printer

≪ Previous: Standard API Color Picker

$

0

0

Since I am almost 100% retired now and doing a lot less VB6 programming I have been looking for things in my toolkit that might be worth sharing with the remaining VB6 community.

I have done a big rewrite of my BatchRtb Class. Here is the main ReadMe:

Code:

---

========
BatchRtb Version 2.0
========

BatchRtb is a VB6 class for working with RTF data in batch programs.

Instead of a RichTextBox control it creates an invisible RichEdit
control and exposes its Text Object Model (TOM) ITextDocument
interface.  A few additional methods and properties are provided for
opening, saving, and clearing RTF data.

Open and save operations accept:

    o A file name.
    o A Byte array.
    o An IStream object.
    o A ShStream object (another provided class also used internally).
    o An ADODB.Stream object.

These should all contain raw RTF data.


Notes:

    Edanmo's olelib.tlb is required for compiling, but is of course
    not needed at run time and does not need to be deployed.  A recent
    copy has been included.

    If necessary you could even create and compile an ActiveX DLL
    Project exposing the BatchRtb class and perhaps the ShStream class.
    Then this can be used from VBScript in WSH scripts, IIS ASP
    scripts, etc. (anywhere a 32-bit ActiveX DLL can be used).

    Several demo/test Projects using BatchRtb are included.


Some uses:

    o Command line programs.  Local, via PsExec.exe, etc.
    o Batch unattended scheduled tasks.
    o Services.
    o Or anywhere that you don't have a Form or UserControl you can
      site a RichTextBox or InkEdit control on.

---

This isn't for everyone. Few people are doing Service development, ASP scripting, etc. Most don't even have a clue how to use a CLI (cmd.exe) window, let alone schedule a non-interactive batch task using Task Scheduler any more.

But this code may contain techniques you could employ in your own programs.


BatchRtb 2.0 has been tested on Windows 10 Fall Creator's Update but not on anything else yet. It should work on anything from Windows Vista on up. I'm not sure it could be made to work on Win9x but I think it could be reworked to run on NT 4.0 on up by rewriting the ShStream class - as long as a recent version of ADO (2.5 or later) is installed. The ADO requirement could also be stripped out if necessary.

I haven't done exhaustive testing so bugs may remain in this release. But the attachment contains a number of test case Projects that exercise most of its operations.

Attached Files

• BatchRtb 2.zip (265.8 KB)

VB6 - Multiline Textbox Printer

April 8, 2018, 12:51 pm

≫ Next: VB6 - Text Editor

≪ Previous: [VB6] BatchRtb 2

$

0

0

I had previously used a RichTextBox and the SelPrint routine, but I discovered that routine would not work with an InkEdit Control. With the help of jpbro, we put together a routine for the InkEdit Control (located in the parent forum). But that routine does not work with a Textbox, and I could not find anything online to fit the bill. So I came up with the routine attached.

This routine has experienced very little testing because my development computer does not currently have access to an actual printer. Bug reports would be appreciated.

J.A. Coutts

Attached Files

• TxtPrint.zip (3.3 KB)

VB6 - Text Editor

April 9, 2018, 3:22 pm

≫ Next: [VB6] UcFormResizerLimiter

≪ Previous: VB6 - Multiline Textbox Printer

$

0

0

I found a need for addtional functions that NotePad did not provide, so I came up with my own Text Editor. It has most of the functions of NotePad with a couple of extra ones.

Code:

---

File                Edit                Format                Search
-New                -Undo                -Word Wrap        -Find
-Open                -Cut                -Sort                -Find Next
-Save                -Copy                -Font
-Save as        -Paste
-Print                -Delete
-Exit                -Replace
                -Select All

---

The noticeable extra is the Sort function, which is covered in a previous post. The other extra is the ability to replace character ranges per line in addition to search and replace specific text. This is accomplished by replacing the double characters CrLf with a single character Cr, using a Split function to separate individual lines into a string array, looping through each line to replace the selected character range, and reassembling the complete string with the Join function. For large text files, search and Replace All by text will be slow, whereas Replace All by character count will be fast by comparison.

The print function has taken some time to put together, as printing from a Text Box is not straight forward, and it has experienced limited testing due to lack of an available printer. It also has been covered in a previous post.

The Line/Col function that comes with Text Editor is not considered an option, as in NotePad. Unlike NotePad, it is available in either Wrap or Unwrap modes, and is only activated by mouse click. If it is important to you, you are welcome to add activation by cursor keys.

Originally I used the API to perform the Edit functions since the VB functions were limited to 64K. But then I discovered that the keyboard functions are not limited to 64K, and perform most of those tasks quite well and with good speed. So it made a lot of sense to use the keyboard functions instead.

Like NotePad, Text Editor provides an adjustable window that remembers it's location and size.

The surprising part of this effort is that with the additional functionality provided, the executable is 1/3 the size of Notepad. I have added functions that meet my current needs, and other users may have specific functions that can be added to meet their needs.

J.A. Coutts

Attached Images

  

Attached Files

• TextEdit.zip (10.4 KB)

---

[VB6] UcFormResizerLimiter

May 12, 2020, 5:48 pm

≫ Next: Fast Call COM object (activex.dll) ,Run Windows API

≪ Previous: VB6 - Text Editor

$

0

0

What it is? A User Control to flicker free limit the resize of a form without
the need to add any code to the form.


Also (and the reason why I created it) is the ability to disable the limits
on the IDE Form Designer screen. Now you can edit really big forms or forms that are
bigger than your screen without problem.
The control is not needed to run bigger forms. You can edit the form and then
disable and remove the control.





When enabling it from Design mode it print the original form size to the debug window
in case the user run the project/save with the expanded state and loss the original
values. (Yes, it happened to me several times!)


Note: To force the form size to become big instantly on the Design IDE set
the 'minimum' size. if you only set the 'maximum' you will need to resize
It manually


It use MST for subclassing by wqweto



Download: ucResizeLimiter_v1.0.zip

Attached Images

  

Attached Files

• ucResizeLimiter_v1.0.zip (19.7 KB)

Fast Call COM object (activex.dll) ,Run Windows API

May 15, 2020, 5:50 pm

≫ Next: Vb6 OpenOffice sdk（com.sun.star.ServiceManager）

≪ Previous: [VB6] UcFormResizerLimiter

$

0

0

How to test the method of the COM object (activex.dll) in real time and run the windows api?
【Organizing, testing the project, and uploading examples after completion】

Method 1: Use VBS to create new objects or call the API library to call the WINDOWS function library
Method 2: Use VB6's Add-in plug-in method to dynamically create a project, create an object variable, and run
Method 3: The createobject ("excel.application") method creates a new Excel vba module, automatically adds code, and runs

It would be nice if each file could have a manual like PHP online tutorial.
Each process method and function can be directly tested without running into EXE.
Each method and function are listed in the manual, and you can run the test with one click to see the effect.

It's like there are tens of thousands of windows api, such as findwindow, messageboxa.
Make a table, write a description of the parameter types required by each API, add some test data, and you can run it directly to see the effect.
To achieve the same EXCEL formula, run windows api, Activex.Class1.Method (parameter 1, parameter 2) as a formula and run it immediately.

PHP Tutorial | Rookie Tutorial
https://www.runoob.com/php/php-tutorial.html
Rookie Tutorial Online Editor
https://www.runoob.com/try/runcode.p...intro&type=php
----------------
<! DOCTYPE html>
<html>
<body>

<? php
echo "Hello World!";
?>

</ body>
</ html>

There is a button "click to run code" on the page
-------------

Vb6 OpenOffice sdk（com.sun.star.ServiceManager）

May 18, 2020, 6:44 pm

≫ Next: vb Fast Crc32 (crc32str,Crc32File)

≪ Previous: Fast Call COM object (activex.dll) ,Run Windows API

$

0

0

need install jdk first

OpenOffice_sdk http://www.openoffice.org/api/basic/...l/tutorial.pdf
JDK1.8
32bit jdk https://www.7down.com/soft/267473.html
OpenOffice4.1.7 https://www.openoffice.org/download/

HKEY_CLASSES_ROOT\com.sun.star.ServiceManager
CLSID:{82154420-0FBF-11d4-8313-005004526AB4}
C:\Program Files (x86)\OpenOffice 4\program\soffice.exe -nodefault -nologo

Code:

---

Option Explicit

Private Sub Command1_Click()
NewExcelWord
'good_新建一个Excel和Word文档
End Sub

Private Sub Command3_Click()
'新建Excel类表格
'NewExcel
Dim mNoArgs()
Dim oSpreadsheetDocument As Object
Dim oTextDocument As Object
'Using StarOffice API - Basics 19
Dim oSM As Object
Set oSM = CreateObject("com.sun.star.ServiceManager")
Dim oDesktop
Set oDesktop = oSM.CreateInstance("com.sun.star.frame.Desktop")
'oDesktop = createUnoService("com.sun.star.frame.Desktop")
Dim sUrl
sUrl = "private:factory/scalc"
Set oSpreadsheetDocument = _
oDesktop.loadComponentFromURL(sUrl, "_blank", 0, mNoArgs())
 

 'GetCell = oSheet.getCellByPosition(nColumn, nRow)
 Dim oSheet As Object
 Set oSheet = oSpreadsheetDocument.getSheets().getByIndex(0)
 Dim Row As Long, Col As Long
 Row = 2
 Col = 2
 
  Dim s As String
 For Row = 1 To 3
 For Col = 1 To 5
 
 'oSheet.getCellByPosition(Col - 1, Row - 1).Value = Row & Col
 s = "v" & Row & Col
 
 'oSheet.getCellByPosition(Col - 1, Row - 1).v = Row & Col' long,value
 oSheet.getCellByPosition(Col - 1, Row - 1).String = s '
 Next
 Next

End Sub

Sub NewExcelWord()
Dim mNoArgs()
Dim oSpreadsheetDocument As Object
Dim oTextDocument As Object
'Using StarOffice API - Basics 19
Dim oSM As Object
Set oSM = CreateObject("com.sun.star.ServiceManager")
Dim oDesktop
Set oDesktop = oSM.CreateInstance("com.sun.star.frame.Desktop")
'oDesktop = createUnoService("com.sun.star.frame.Desktop")
Dim sUrl
sUrl = "private:factory/scalc"
Set oSpreadsheetDocument = _
oDesktop.loadComponentFromURL(sUrl, "_blank", 0, mNoArgs())
sUrl = "private:factory/swriter"
Set oTextDocument = _
oDesktop.loadComponentFromURL(sUrl, "_blank", 0, mNoArgs)
End Sub

Private Sub Command4_Click()
 'OpenWord
 '打开一个WORD文件
Dim mFileProperties(0) ' As New com.sun.star.beans.PropertyValue
Dim sUrl As String
Dim oSM As Object
Set oSM = CreateObject("com.sun.star.ServiceManager")
Dim oDesktop
Dim oDocument
Set oDesktop = oSM.CreateInstance("com.sun.star.frame.Desktop")

sUrl = "file:///" & App.Path & "\002word.doc"
sUrl = Replace(sUrl, "\", "/")
sUrl = GetFileName(App.Path & "\002word.doc")

'mFileProperties(0).Name = "FilterName"
'mFileProperties(0).Value = "scalc: Text - txt - csv (StarCalc)"
Set oDocument = oDesktop.loadComponentFromURL(sUrl, "_blank", 0, mFileProperties())
End Sub
Function GetFileName(ByVal sUrl As String) As String
sUrl = "file:///" & sUrl
sUrl = Replace(sUrl, "\", "/")
GetFileName = sUrl
End Function

Private Sub Command5_Click()
 'Open Excel File
 '打开一个Excel文件,GOOD
Dim mFileProperties(0) ' As New com.sun.star.beans.PropertyValue
Dim sUrl As String
Dim oSM As Object
Set oSM = CreateObject("com.sun.star.ServiceManager")
Dim oDesktop
Dim oDocument
Set oDesktop = oSM.CreateInstance("com.sun.star.frame.Desktop")

sUrl = GetFileName(App.Path & "\001excel.xls")

Set oDocument = oDesktop.loadComponentFromURL(sUrl, "_blank", 0, mFileProperties())
End Sub

---

vb Fast Crc32 (crc32str,Crc32File)

May 20, 2020, 4:49 pm

≫ Next: Friend in Class1-VB6 calls multiple methods to run speed test

≪ Previous: Vb6 OpenOffice sdk（com.sun.star.ServiceManager）

$

0

0

Running speed test record: average time,Evaluation object
====================
use CbsPersist_20200521111942.log(161m),not 7z format

time(ms) TestObject
125.76 Crc32_Wqweto
281.03 Crc32ByAsm
326.17 Crc32Api
458.95 Crc32_LaVolpe
461.22 Crc32FromByte
====================
(USE 320M File,7z format)

----------------Advanced optimization：
249.41 Crc32_Wqweto
555.39 Crc32ByAsm
648.79 Crc32Api

905.41 Crc32_LaVolpe
906.42 Crc32FromByte
----------------Pentium Pro(Tm) optimization：
573.88 Crc32ByAsm UsedTime(Ms)
665.31 Crc32Api UsedTime(Ms)
737.25 Crc32FromByte UsedTime(Ms)
739.31 Crc32_LaVolpe UsedTime(Ms)
====================
Why is this forum picture compressed automatically? The total capacity of attachments uploaded at the same time is also pitiful？

method1:use api RtlComputeCrc32

Code:

---

Private Declare Function RtlComputeCrc32 Lib "ntdll.dll" ( _
    ByVal dwInitial As Long, _
    ByVal pData As Long, _
    ByVal iLen As Long) As Long

Public Function Crc32Api ( tBuff() As Byte) as long   
    Crc32Api = RtlComputeCrc32(0, VarPtr(tBuff(0)), UBound(tBuff) + 1)
End Function

Public Function GetStringCRC32(ByVal InString As String) As String
'123456789=CBF43926
    Dim lRet As Long, tBuff() As Byte
   
    tBuff = StrConv(InString, vbFromUnicode)
   
    lRet = RtlComputeCrc32(0, VarPtr(tBuff(0)), UBound(tBuff) + 1)
    GetStringCRC32 = Hex(lRet)
End Function

---

method2:

Code:

---

'call InitCrc32 'First
Dim CRC32Table(255) As Long


Private Declare Function MultiByteToWideChar Lib "kernel32 " (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32 " (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Const CP_ACP = 0 ' default to ANSI code page
Private Const CP_UTF8 = 65001 ' default to UTF-8 code page

'string to UTF8
Public Function EncodeToBytes(ByVal sData As String) As Byte() ' Note: Len(sData) > 0
Dim aRetn() As Byte
Dim nSize As Long
nSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sData), -1, 0, 0, 0, 0) - 1
If nSize = 0 Then Exit Function
ReDim aRetn(0 To nSize - 1) As Byte
WideCharToMultiByte CP_UTF8, 0, StrPtr(sData), -1, VarPtr(aRetn(0)), nSize, 0, 0
EncodeToBytes = aRetn
Erase aRetn
End Function

Function Crc32FromByte(B() As Byte) As Long
    Dim i As Long, iCRC As Long
    iCRC = &HFFFFFFFF
    For i = 0 To UBound(B)
        iCRC = (((iCRC And &HFFFFFF00) \ &H100) And &HFFFFFF) Xor CRC32Table((iCRC And &HFF) Xor B(i))
    Next
    Crc32FromByte = iCRC Xor &HFFFFFFFF
End Function

Function crc32byte(B() As Byte) As long
    Dim i As Long, iCRC As Long, lngA As Long, ret As Long
    dim bytT As Byte, bytC As Byte
   
    iCRC = &HFFFFFFFF
    For i = 0 To UBound(B)
        bytC = B(i)
        bytT = (iCRC And &HFF) Xor bytC
        lngA = ((iCRC And &HFFFFFF00) \ &H100) And &HFFFFFF
        iCRC = lngA Xor CRC32Table(bytT)
    Next
    ret = iCRC Xor &HFFFFFFFF
    crc32byte =ret
End Function

'string's CRC32
Public Function crc32str(item As String) As String
    Dim i As Long, iCRC As Long, lngA As Long, ret As Long
    Dim B() As Byte, bytT As Byte, bytC As Byte
    B = StrConv(item, vbFromUnicode)
   
    iCRC = &HFFFFFFFF
    For i = 0 To UBound(B)
        bytC = B(i)
        bytT = (iCRC And &HFF) Xor bytC
        lngA = ((iCRC And &HFFFFFF00) \ &H100) And &HFFFFFF
        iCRC = lngA Xor CRC32Table(bytT)
    Next
    ret = iCRC Xor &HFFFFFFFF
    crc32str = Right("00000000" & Hex(ret), 8)
End Function

Public Function Crc32File(sFilePath As String, Optional Block As Long = 1024) As Long ' String
'改进后180M左右以上的文件更快了，超过“GetFileCRC32_MapFile”
    Dim hFile As Long, i As Long, iCRC As Long, lngA As Long, Size As Long, ret As Long
    Dim bytT As Byte, bytC As Byte
    Dim sSize As Currency, total As Currency, Ub As Long
    total = FileLen(sFilePath)
    If total = 0 Then Exit Function 'Len(Dir(sFilePath))
    If total < 0 Then total = total + 256 ^ 4
    sSize = Block * 1024
    hFile = FreeFile
    Open sFilePath For Binary Access Read As #hFile
    iCRC = &HFFFFFFFF
'    Dim sSize2 As Long
'    sSize2 = sSize + 1
    'Dim sSizeX As Long
    'sSizeX = sSize - 1

    Ub = sSize - 1
    ReDim B(Ub) As Byte
 
'sSize=8,sSizeX=7
    While total >= sSize '>=8  '722-725
    'While total > sSizeX  '>7
    'While total > sSize - 1 '慢去 '713-715
        Get #hFile, , B
        For i = 0 To Ub
            bytC = B(i)
            bytT = (iCRC And &HFF) Xor bytC
            lngA = ((iCRC And &HFFFFFF00) \ &H100) And &HFFFFFF
            iCRC = lngA Xor CRC32Table(bytT)
        Next
        total = total - sSize
    Wend
   
    If total > 0 Then '余下区块
        Ub = total - 1
        ReDim B(Ub) As Byte
        Get #hFile, , B
        For i = 0 To Ub
            bytC = B(i)
            bytT = (iCRC And &HFF) Xor bytC
            lngA = ((iCRC And &HFFFFFF00) \ &H100) And &HFFFFFF
            iCRC = lngA Xor CRC32Table(bytT)
        Next
    End If
   
 
   
    Close #hFile
    ret = iCRC Xor &HFFFFFFFF
    Crc32File = ret
    'Crc32File = Right("00000000" & Hex(ret), 8)
End Function
'CRC32 Table
Public Function InitCrc32(Optional ByVal Seed As Long = &HEDB88320, Optional ByVal Precondition As Long = &HFFFFFFFF) As Long
    Dim i As Integer, j As Integer, CRC32 As Long, Temp As Long
    For i = 0 To 255
        CRC32 = i
        For j = 0 To 7
            Temp = ((CRC32 And &HFFFFFFFE) \ &H2) And &H7FFFFFFF
            If (CRC32 And &H1) Then CRC32 = Temp Xor Seed Else CRC32 = Temp
        Next
        CRC32Table(i) = CRC32
    Next
    InitCrc32 = Precondition
End Function

---

METHOD3: GetCrcByASM.CLS

Code:

---

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Sub CpyMem4 Lib "msvbvm60.dll" Alias "GetMem4" (Source As Any, Destination As Any)

Dim ASMBL() As Byte
Dim Table(0 To 255) As Long
Function Crc32ByAsm(Data() As Byte) As Long
'0为下标的数组，原来函数名：ChecksumDataEx
    Dim CRC32 As Long
    CRC32 = &HFFFFFFFF
    On Local Error GoTo ErrCB
    CallWindowProc VarPtr(ASMBL(0)), VarPtr(CRC32), VarPtr(Data(0)), VarPtr(Table(0)), UBound(Data) + 1
ErrCB:
    Crc32ByAsm = Not CRC32
End Function

Function ChecksumFileEx(Path As String) As Long
On Error GoTo ErrFC
Dim FreeF As Integer, Data() As Byte
FreeF = FreeFile
Open Path For Binary Access Read As #FreeF
ReDim Data(0 To LOF(FreeF) - 1) As Byte
Get #FreeF, , Data
Close #FreeF
ChecksumFileEx = Crc32ByAsm(Data)
ErrFC:
End Function
Function ChecksumFile(Path As String) As String
ChecksumFile = Hex(ChecksumFileEx(Path))
End Function

Function ChecksumTextEx(Text As String) As Long
If Len(Text) = 0 Then Exit Function
ChecksumTextEx = Crc32ByAsm(StrConv(Text, vbFromUnicode))
End Function
Function ChecksumText(Text As String) As String
ChecksumText = Hex(ChecksumTextEx(Text))
End Function


Function Crc32ByAsm2(Data() As Byte) As Long '非0下标
Dim CRC32 As Long
CRC32 = &HFFFFFFFF 'CRC32 初始值(必须)
On Local Error GoTo ErrCB
Dim DLen As Long
DLen = UBound(Data) - LBound(Data) + 1
CallWindowProc VarPtr(ASMBL(0)), VarPtr(CRC32), VarPtr(Data(LBound(Data))), VarPtr(Table(0)), DLen
ErrCB:
Crc32ByAsm2 = Not CRC32
End Function

Function ChecksumData(Data() As Byte) As String
ChecksumData = Hex(Crc32ByAsm(Data))
End Function

Function LngToBin(ipLong As Long) As Byte()
Dim tB() As Byte
ReDim tB(1 To 4)
CpyMem4 ipLong, tB(1)
LngToBin = tB
End Function
Function BinToLng(ipBin4() As Byte) As Long
CpyMem4 ipBin4(LBound(ipBin4)), BinToLng
End Function

Sub IntAsm()
Dim i As Long, j As Long

Const ASM As String = "5589E557565053518B45088B008B750C8B7D108B4D1431DB8A1E30C3C1E80833049F464975F28B4D088901595B585E5F89EC5DC21000"

' Decoded ASM source from HIEW 6.86 (Hacker's View)
'
' 55 PUSH BP
' 89E5 MOV BP,SP
' 57 PUSH DI
' 56 PUSH SI
' 50 PUSH AX
' 53 PUSH BX
' 51 PUSH CX
' 8B4508 MOV AX,DI[08]
' 8B00 MOV AX,BX[SI]
' 8B750C MOV SI,DI[0C]
' 8B7D10 MOV DI,DI[10]
' 8B4D14 MOV CX,DI[14]
' 31DB XOR BX,BX
' 8A1E30C3 MOV BL,0C330
' C1E808 SHR AX,008 <-.
' 3304 XOR AX,[SI] |
' 9F LAHF |
' 46 INC SI |
' 49 DEC CX |
' 75F2 JNE 000000018 -'
' 8B4D08 MOV CX,DI[08]
' 8901 MOV BX[DI],AX
' 59 POP CX
' 5B POP BX
' 58 POP AX
' 5E POP SI
' 5F POP DI
' 89EC MOV SP,BP
' 5D POP BP
' C21000 RETN 00010

ReDim ASMBL(0 To 53) 'Len(ASM) \ 2 - 1
For i = 1 To Len(ASM) - 1 Step 2
ASMBL(j) = Val("&H" & Mid(ASM, i, 2))
j = j + 1
Next i

Dim vCRC32 As Long, vB As Boolean
Const vXor32 As Long = &HEDB88320
For i = 0 To 255
vCRC32 = i
For j = 8 To 1 Step -1
vB = vCRC32 And 1
vCRC32 = ((vCRC32 And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
If vB Then vCRC32 = vCRC32 Xor vXor32
Next j
Table(i) = vCRC32
Next i
End Sub
Private Sub Class_Initialize()
IntAsm
End Sub

---

method 4:

Code:

---

Function Crc32_LaVolpe(Buffer() As Byte) As Long
Dim crc32val As Long, i As Long
crc32val = &HFFFFFFFF
For i = 0 To UBound(Buffer)
crc32val = (((crc32val And &HFFFFFF00) \ &H100&) And &HFFFFFF) Xor CRC32Table((crc32val And &HFF) Xor Buffer(i))
Next i
Crc32_LaVolpe = crc32val Xor &HFFFFFFFF
End Function

---

Attached Images

 

Friend in Class1-VB6 calls multiple methods to run speed test

May 26, 2020, 11:10 am

≫ Next: Alt+NumPad input for Unicode TextBox with surrogate pair support

≪ Previous: vb Fast Crc32 (crc32str,Crc32File)

$

0

0

Optimized for vb6 running speed
call function Fastest c=Bas_Sum(a,b)
call Friend is quick than "public function"，The operating speed is 4.6 times faster
-----------
Class_OBJ 452.38 （dim a as class1 ,call a.Sum(**))
Class_Friend_Ptr 70.38
Class_Friend 80.65(call a.FrinedSum)
----------
call objptr like stdcall :cUniversalDLLCalls.CallFunction_COM(***),The operating speed is 1 times faster(up 100%)

Pointer call function address of COM object：
call com dll(activex.dll).FrinedSum(***), Speed increased by 5.6 times
（465.77 pk 70.57)
It takes 827 seconds to call activex.exe, which is 14000 times more than the time to directly call the process

Unfortunately, this seems to be no way. It is like operating the "EXCEL.APPLICATION" object in VB6 and controlling the third-party process of excel.exe. It is very slow. Unless running in EXCEL VBA, it is also about 4 times slower than VB6, but it is slower than ActiveX.EXE with 14,000 times is still much better.
This is just a theoretical number and has not been tested specifically, but calling activex.exe is really slow.
=====================
method1:Friend Function FrinedSum(ByRef a As Long, ByRef b As Long) As Long
method2:Public Function Sum(ByRef a As Long, ByRef b As Long) As Long
method3:Public Function Bas_Sum in moudle.bas
method4:Public Sub BasSub_Sum in moudle.bas

com dll=(class1.cls in comdll1.dll)
actexe=(class1.cls in activex1.exe)
class1.cls in same vb project
call function sum(a,b)
call sub sum(a,b,returnvalue)
The main methods of testing

Code:

---

TestCount = 1000000*20
Sub Test_Exe1_MySum_object(id As Long)
dim Exe1 as new activex1_exe.Class1
Dim i As Long
For i = 1 To TestCount
    a1 = 3
    b1 = 4
    'Call Exe1_MySum2(ThisExe1, a1, b1, Ret) 'by objptr stdcall
    Ret = Exe1.Sum(a1, b1)
next
end sub

Public Function Bas_Sum(ByRef a As Long, ByRef b As Long) As Long 'method3
 
Bas_Sum = a + b
a = a * a
b = b * b
End Function
Public Sub BasSub_Sum(ByRef a As Long, ByRef b As Long, ByRef Value1 As Long) 'method4
 
Value1 = a + b
a = a * a
b = b * b
End Sub

---

class1.cls

Code:

---

Option Explicit
 Public Event Sum2(ByRef id As Long)   

Public Sub Test()
MsgBox "ComDll.lib-test"
End Sub
Public Sub TEST2()
MsgBox "ComDll.lib-test2"
End Sub
Public Function Sum(ByRef a As Long, ByRef b As Long) As Long
 
Sum = a + b
a = a * a
b = b * b
End Function
 
Public Sub test3()
Dim i As Long
Dim v2 As Long
Dim V1 As Long
For i = 1 To 1
V1 = i
v2 = i
 
RaiseEvent Sum2(v2)
 
Next
End Sub
Friend Function FrinedSum(ByRef a As Long, ByRef b As Long) As Long
 
MsgBox "FrinedSum"
FrinedSum = a + b
a = a * a
b = b * b
End Function
Friend Function FrinedSum2(ByRef a As Long, ByRef b As Long) As Long
 
MsgBox "Class_FrinedSum2"
FrinedSum2 = a + b
a = a * a
b = b * b
End Function

---