Quantcast
Channel: VBForums - CodeBank - Visual Basic 6 and earlier
Viewing all 1540 articles
Browse latest View live

[VB6] - Translation of the string to a number and vice versa.

$
0
0
Hello everyone! Basic functions for translation and validation of numbers to strings (and back) is very uncomfortable in terms of the fact that there is a lot to write, and they have their "eat." We can write the numbers in the hexadecimal system or brackets in exponential notation, etc. On the one hand it is good, but on the other can be a challenge. I wrote two functions that convert decimal integers of unlimited dimension from one representation to another. Can be useful for example to display the (Setup) LARGE_INTEGER or any other large (very large scale) numbers. Can somehow make a module for arithmetic operations with such numbers.
Code:

Option Explicit
 
Private Declare Function GetMem2 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
 
Private Sub Form_Load()
    Dim Value() As Byte, Res As String
 
    StrToUI "1234567891011121314151617181920", Value
   
    Res = UIToStr(Value)
   
End Sub

' Convert unsigned integer from byte array to string (decimal system)
Private Function UIToStr(bValue() As Byte) As String
    Dim i As Long, f As Boolean, loc() As Byte
    loc = bValue
    Do
        i = Div10UI(loc)
        UIToStr = CStr(i) & UIToStr
        f = False
        For i = UBound(loc) To 0 Step -1
            If loc(i) Then f = True: Exit For
        Next
    Loop While f
End Function

' Convert unsigned integer (decimal system) from string to byte array.
Private Sub StrToUI(sValue As String, Out() As Byte)
    Dim i As Long, lpStr As Long, v As Integer, b(0) As Byte
    ReDim Out(0)
    If Len(sValue) Then
        lpStr = StrPtr(sValue)
        For i = 0 To Len(sValue) - 1
            GetMem2 ByVal lpStr, v
            v = v - &H30
            If v < 0 Or v > 9 Then Err.Raise 13: Exit Sub
            b(0) = v
            If i Then Mul10UI Out
            AddUI Out, b()
            lpStr = lpStr + 2
        Next
    Else: Err.Raise 5
    End If
End Sub

Private Sub AddUI(Op1() As Byte, Op2() As Byte)
    Dim i As Long, p As Long, o As Long, q As Long
    If UBound(Op1) < UBound(Op2) Then ReDim Preserve Op1(UBound(Op2))
    Do
        If i <= UBound(Op2) Then o = Op2(i) Else o = 0
        q = CLng(Op1(i)) + o + p
        p = (q And &H100&) \ &H100
        Op1(i) = q And &HFF
        i = i + 1
    Loop While CBool(o Or p) And i <= UBound(Op1)
    If p Then ReDim Preserve Op1(i): Op1(i) = p
End Sub

Private Function Div10UI(Value() As Byte) As Long
    Dim i1 As Long, i2 As Long, acc() As Byte, loc() As Byte, q As Long, p As Long
    For i1 = 0 To (UBound(Value) + 1) * 8
        Div10UI = (Div10UI * 2) Or p
        If Div10UI < 10 Then p = 0 Else p = 1: Div10UI = Div10UI - 10
        For i2 = 0 To UBound(Value)
            q = (CLng(Value(i2)) * 2) Or p
            p = (q And &H100) \ &H100
            Value(i2) = q And &HFF&
        Next
    Next
End Function

Private Sub Mul10UI(Value() As Byte)
    Dim i As Long, p As Long, q As Long
    For i = 0 To UBound(Value)
        q = (CLng(Value(i)) * 4 + Value(i)) * 2 + p
        p = (q And &HFF00&) \ &H100
        Value(i) = q And &HFF
    Next
    If p Then ReDim Preserve Value(i): Value(i) = p
End Sub

Good luck!

[VB6] - Multithreading in VB6 part 4 - multithreading in Standart EXE.

$
0
0

Hello everyone. Now I have a little time, so I have not often been programming BASIC and less likely to appear on the forum. Today again I will be talking about multi-threading, this time in the Standart EXE. I must say that all of what I write is my personal study, and may in some way does not correspond to reality; also due to my lack of time I will complement this post with further progress in the study of this issue. So here we go.
As I said before, to multithreading worked need to initialize the runtime. Without initialization we can work very limited in the sense that the COM will not work, ie roughly all the power of BASIC is not available. You can work with the API, declared in tlb, some functions, also removing the check __vbaSetSystemError, you can use Declared-function. All previous publications showing work in separate DLL, and we could easily initialize runtime using VBDllGetClassObject function for this. Today we will try to initialize the runtime in the usual EXE, ie without using external dependencies. It's no secret that any application written in VB6 has a project header, which contains a lot of information about the project that the runtime uses to work:
Code:

Type VbHeader
    szVbMagic              As String * 4
    wRuntimeBuild          As Integer
    szLangDll              As String * 14
    szSecLangDll            As String * 14
    wRuntimeRevision        As Integer
    dwLCID                  As Long
    dwSecLCID              As Long
    lpSubMain              As Long
    lpProjectInfo          As Long
    fMdlIntCtls            As Long
    fMdlIntCtls2            As Long
    dwThreadFlags          As Long
    dwThreadCount          As Long
    wFormCount              As Integer
    wExternalCount          As Integer
    dwThunkCount            As Long
    lpGuiTable              As Long
    lpExternalCompTable    As Long
    lpComRegisterData      As Long
    bszProjectDescription  As Long
    bszProjectExeName      As Long
    bszProjectHelpFile      As Long
    bszProjectName          As Long
End Type

In this structure, a lot of fields to describe all I will not, I will note only that this structure refers to a variety of other structures. Some of them will be needed in the future, such as a field lpSubMain, which contains the address of the procedure Main, if it is defined, otherwise there is 0. The vast majority of EXE files begin with the following code:
Code:

PUSH xxxxxxxx
CALL MSVBVM60.ThunRTMain

Just xxxxxxxx points to structure VBHeader. This feature will allow to find the structure inside the EXE for initializing runtime. In a previous article, I described how to get from the ActiveX DLL that structure - for this it was necessary to read the data in one of the exported functions (eg DllGetClassObject). To get from EXE - we also make use of the same method. First you need to find an entry point (entry point), ie address that starts the EXE. This address can be obtained from the structure IMAGE_OPTIONAL_HEADER - field AddressOfEntryPoint. This structure (IMAGE_OPTIONAL_HEADER) is located in the PE header, and the PE header is located at offset specified in the field e_lfanew from structure IMAGE_DOS_HEADER, well, IMAGE_DOS_HEADER structure located in the address specified in App.hInstance (or GetModuleHandle). Pointer to VbHeader is located at offset AddressOfEntryPoint + 1, because push-opcode in this case equal 0x68h. So, gathering all together, we get the function to get the Header:
Code:

' // Get VBHeader structure
Private Function GetVBHeader() As Long
    Dim ptr    As Long
    ' Get e_lfanew
    GetMem4 ByVal hModule + &H3C, ptr
    ' Get AddressOfEntryPoint
    GetMem4 ByVal ptr + &H28 + hModule, ptr
    ' Get VBHeader
    GetMem4 ByVal ptr + hModule + 1, GetVBHeader
   
End Function

Now, if you pass this structure VBDllGetClassObject function in a new thread, then, roughly speaking, this function will start our project for execution according to this structure. Of course in this sense is not enough - it is the same as re-start the application in the new thread. For example, if the function has been set Main, and then start again with the execution of it, and if the form has, then this form. Must somehow make the project was carried out on the other, do we need in the function. To do this, you can change the field "lpSubMain" in the structure vbHeader. I also did so at first, but it has given nothing. As it turned out, in runtime, there is one global object that stores a reference to projects and related objects, and if you pass the same header at VBDllGetClassObject, then the runtime checks are not loaded if such a project, and if loaded, simply launch a new copy without parse structure vbHeader, based on the previous analysis. So I decided to do so - you can copy the structure vbHeader to another location and use it. Immediately, I note that in this structure the last 4 fields - is offset with respect to the structure, so when copying the structure they need to be adjusted. If we now try to pass this structure to VBDllGetClassObject, then everything will be fine if installed as a startup Sub Main, if the form, it will be launched and the shape and after the Main. To exclude such behavior need to fix some data referenced by the title. I do not know exactly what kind of data, as did not understand this, but "dig deeper" inside the runtime I found their place position. Field "lpGuiTable" in the structure "vbHeader" refers to a list of structures tGuiTable, which describe froms in the project. Structures are sequentially the number of structures has a field "wFormCount" in the structure "vbHeader". In the network, I have not found the normal description of the structure tGuiTable, that's what is:
Code:

Type tGuiTable
    lStructSize          As Long
    uuidObjectGUI        As uuid
    Unknown1            As Long
    Unknown2            As Long
    Unknown3            As Long
    Unknown4            As Long
    lObjectID            As Long
    Unknown5            As Long
    fOLEMisc            As Long
    uuidObject          As uuid
    Unknown6            As Long
    Unknown7            As Long
    aFormPointer        As Long
    Unknown8            As Long
End Type

As it turned out there inside the runtime code that checks the field "Unknown5" in each structure:

I've added comments; They show that "Unknown5" contains flags and if you have installed the 5th bit, the recording is a reference to some object defined register EAX, in the field at offset 0x30 within the object specified register EDX. What kind of objects - I do not know, maybe later will deal with this, we have the important fact of the recording of a value in the field at offset 0x30. Now, if you start to explore more code you can stumble on such a fragment:

I will say that the object pointed to by ESI, the same object in the previous procedure under consideration (register EDX). It can be seen that the value of this field is tested for 0 and -1, and if there is any of the numbers that starts the procedure Main (unless specified); otherwise runs the first form. So, now that is guaranteed to run only Sub Main, we change the flag lpGuiTable.Unknown5, resetting the fifth bit. To install a new Sub Main and modification flag I created a separate procedure:
Code:

' // Modify VBHeader to replace Sub Main
Private Sub ModifyVBHeader(ByVal newAddress As Long)
    Dim ptr    As Long
    Dim old    As Long
    Dim flag    As Long
    Dim count  As Long
    Dim size    As Long
   
    ptr = lpVBHeader + &H2C
    ' Are allowed to write in the page
    VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
    ' Set a new address of Sub Main
    GetMem4 newAddress, ByVal ptr
    VirtualProtect ByVal ptr, 4, old, 0
   
    ' Remove startup form
    GetMem4 ByVal lpVBHeader + &H4C, ptr
    ' Get forms count
    GetMem4 ByVal lpVBHeader + &H44, count
   
    Do While count > 0
        ' Get structure size
        GetMem4 ByVal ptr, size
        ' Get flag (unknown5) from current form
        GetMem4 ByVal ptr + &H28, flag
        ' When set, bit 5,
        If flag And &H10 Then
            ' Unset bit 5
            flag = flag And &HFFFFFFEF
            ' Are allowed to write in the page
            VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
            ' Write changet flag
            GetMem4 flag, ByVal ptr + &H28
            ' Restoring the memory attributes
            VirtualProtect ByVal ptr, 4, old, 0
           
        End If
        count = count - 1
        ptr = ptr + size
       
    Loop
   
End Sub

Now, if you try to run this procedure before sending the header at VBDllGetClassObject, it will run the procedure defined by us. However multithreading have will work, but it is not convenient because there is no mechanism to pass a parameter to the thread as it is implemented in the CreateThread. In order to make a complete analog CreateThread I decided to create a similar function that will perform all initialization and then execute the call is transferred to the thread function with parameter. In order to be able to pass a parameter to the Sub Main, I used a thread local storage (TLS). We distinguish index for TLS. After allocation of the index, we can set the value of this index, specific for each thread. In general, the idea is, create a new thread where the starting function is a special feature ThreadProc, a parameter which transmits the structure of two fields - addresses the user function and address parameter. In this procedure, we will initialize the runtime for the new thread and stored in TLS parameter passed. As the procedure Main create a binary code that will get data from TLS, forming a stack and jump to a user function. The result had such a module:

[VB6] - Using GDI+ for generation a fir-tree.

$
0
0
Hello everyone! I present to you a Christmas tree generated using GDI+.
Code:

Option Explicit
' Ёлка VB6
' © Кривоус Анатолий Анатольевич (The trick), 2013
Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
Private Type Vector
    x As Single
    y As Single
End Type
Private Type COLORBYTES
    BlueByte As Byte
    GreenByte As Byte
    RedByte As Byte
    AlphaByte As Byte
End Type
Private Type COLORLONG
    longval As Long
End Type
Private Type RECT
    iLeft As Long
    iTop As Long
    iRight As Long
    iBottom As Long
End Type
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, Graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal Graphics As Long) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipCreatePen1 Lib "gdiplus" (ByVal color As Long, ByVal Width As Single, ByVal unit As Long, Pen As Long) As Long
Private Declare Function GdipDeletePen Lib "gdiplus" (ByVal Pen As Long) As Long
Private Declare Function GdipSetPenColor Lib "gdiplus" (ByVal Pen As Long, ByVal ARGB As Long) As Long
Private Declare Function GdipSetPenWidth Lib "gdiplus" (ByVal Pen As Long, ByVal Width As Single) As Long
Private Declare Function GdipDrawLine Lib "gdiplus" (ByVal Graphics As Long, ByVal Pen As Long, ByVal X1 As Single, ByVal Y1 As Single, ByVal X2 As Single, ByVal Y2 As Single) As Long
Private Declare Function GdipFillPolygon2 Lib "gdiplus" (ByVal Graphics As Long, ByVal Brush As Long, Points As Vector, ByVal Count As Long) As Long
Private Declare Function GdipDrawPolygon Lib "gdiplus" (ByVal Graphics As Long, ByVal Pen As Long, Points As Vector, ByVal Count As Long) As Long
Private Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal ARGB As Long, Brush As Long) As Long
Private Declare Function GdipSetSmoothingMode Lib "gdiplus" (ByVal Graphics As Long, ByVal SmoothingMd As Long) As Long
Private Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal Brush As Long) As Long
Private Declare Function GdipSetSolidFillColor Lib "gdiplus" (ByVal Brush As Long, ByVal ARGB As Long) As Long
Private Declare Function GdipFillEllipse Lib "gdiplus" (ByVal Graphics As Long, ByVal Brush As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare Function GdipSetPathGradientCenterColor Lib "gdiplus" (ByVal Brush As Long, ByVal lColors As Long) As Long
Private Declare Function GdipSetPathGradientSurroundColorsWithCount Lib "gdiplus" (ByVal Brush As Long, ARGB As Long, Count As Long) As Long
Private Declare Function GdipSetPathGradientCenterPoint Lib "gdiplus" (ByVal Brush As Long, Points As Vector) As Long
Private Declare Function GdipCreatePathGradientFromPath Lib "gdiplus" (ByVal Path As Long, polyGradient As Long) As Long
Private Declare Function GdipDeletePath Lib "gdiplus" (ByVal Path As Long) As Long
Private Declare Function GdipCreatePath Lib "gdiplus" (ByVal brushmode As Long, Path As Long) As Long
Private Declare Function GdipAddPathEllipse Lib "gdiplus" (ByVal Path As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare Function GdipFillPath Lib "gdiplus" (ByVal Graphics As Long, ByVal Brush As Long, ByVal Path As Long) As Long
Private Declare Function GdipCreateBitmapFromGraphics Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal Graphics As Long, Bitmap As Long) As Long
Private Declare Function GdipDrawImage Lib "gdiplus" (ByVal Graphics As Long, ByVal image As Long, ByVal x As Single, ByVal y As Single) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal Graphics As Long, ByVal lColor As Long) As Long
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, stride As Long, ByVal PixelFormat As Long, scan0 As Any, Bitmap As Long) As Long
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, Graphics As Long) As Long
Private Declare Function UpdateLayeredWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, ByVal crKey As Long, pblend As Long, ByVal dwFlags As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
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 Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
 
Private Const HWND_TOPMOST As Long = -1
Private Const HTCAPTION As Long = 2
Private Const WM_NCLBUTTONDOWN As Long = &HA1
Private Const SPI_GETWORKAREA = 48
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE As Long = -20
Private Const ULW_ALPHA = &H2
Private Const AB_32Bpp255 = 33488896
Private Const BranchCount = 25, Ratio = 2, Factor = 3
Private Const ScaleNeedles = 10, AngleNeedles = 0.45, MinBranch = 25, MaxWidth = 10, StarSize = 25, SphereSize = 10, LampSize = 8
 
Private Const UnitPixel = 2, SmoothingModeAntiAlias = 4, PixelFormat32bppARGB = &H26200A
Dim MaxLen As Single
Dim token As Long, GpInput As GdiplusStartupInput, gr As Long, gr2 As Long, pn As Long, br As Long, bg As Long
Dim Lamp() As Vector, pt() As Vector, sw As Single
Dim WithEvents Tmr As Timer
 
Private Function vec(x As Single, y As Single) As Vector: vec.x = x: vec.y = y: End Function
Private Function Lerp(x As Single, y As Single, t As Single) As Single: Lerp = x * (1 - t) + y * t: End Function
Private Sub Branch(Pos As Vector, dir As Vector, ByVal f As Long, v As Vector)
    Dim nPos As Vector, nDir As Vector, l As Single, d As Single, q As Long, p As Single, z As Single, dr As Long
    l = Sqr(dir.x * dir.x + dir.y * dir.y)
    If Abs(Pos.x - sw + dir.x) > Abs(v.x) Then v = vec(Pos.x + dir.x - sw, Pos.y + dir.y)
    GdipSetPenWidth pn, l / MaxLen * MaxWidth / 2: GdipSetPenColor pn, &H80562B00
    GdipDrawLine gr2, pn, Pos.x, Pos.y, Pos.x + dir.x, Pos.y + dir.y
    p = 1 / l * Factor
    GdipSetPenWidth pn, 1: GdipSetPenColor pn, &H80200020 Or (CLng(l / MaxLen * 128 + 127) * &H100)
    Do While d < 1
        nPos = vec(Lerp(Pos.x, Pos.x + dir.x, d), Lerp(Pos.y, Pos.y + dir.y, d))
        nDir = vec((Cos(AngleNeedles) * dir.x * d - Sin(AngleNeedles) * dir.y * d) / l * ScaleNeedles, _
                  (Sin(AngleNeedles) * dir.x * d + Cos(AngleNeedles) * dir.y * d) / l * ScaleNeedles)
        GdipDrawLine gr2, pn, nPos.x, nPos.y, nPos.x + nDir.x, nPos.y + nDir.y
        nDir = vec((Cos(-AngleNeedles) * dir.x * d - Sin(-AngleNeedles) * dir.y * d) / l * ScaleNeedles, _
                  (Sin(-AngleNeedles) * dir.x * d + Cos(-AngleNeedles) * dir.y * d) / l * ScaleNeedles)
        GdipDrawLine gr2, pn, nPos.x, nPos.y, nPos.x + nDir.x, nPos.y + nDir.y
        d = d + p
    Loop
    If l < MinBranch Or f > 3 Then Exit Sub
    q = Rnd * 4 + 2: p = 1 / (q - 1): d = 0
    Do While q > 0
        nPos = vec(Lerp(Pos.x, Pos.x + dir.x, d), Lerp(Pos.y, Pos.y + dir.y, d))
        z = z + p: d = Rnd * 0.35 + 0.275: dr = 2
        Do While dr
            nDir = vec((Cos(d) * dir.x - Sin(d) * dir.y) / Ratio, (Sin(d) * dir.x + Cos(d) * dir.y) / Ratio)
            Branch nPos, nDir, f + 1, v: dr = dr - 1: d = -d
        Loop
        q = q - 1
    Loop
End Sub
Private Sub Form_DblClick()
    Unload Me
End Sub
Private Sub Form_Load()
    Dim n As Long, dy As Single, dx As Single, oy As Single, br2 As Long
    Dim Pth As Long, Col As Long, sp() As Vector, v As Vector, rc As RECT
    If SystemParametersInfo(SPI_GETWORKAREA, 0, rc, 0) = 0 Then End
    SetWindowPos Me.hWnd, HWND_TOPMOST, rc.iRight - 293, rc.iBottom - 336, 293, 336, 0
    GpInput.GdiplusVersion = 1
    If GdiplusStartup(token, GpInput) Then End
    If GdipCreateFromHDC(Me.hdc, gr) Then Unload Me
    If GdipCreateSolidFill(&HFF562B00, br) Then Unload Me
    If GdipCreatePen1(&HFF562B00, 1, UnitPixel, pn) Then Unload Me
    If GdipCreateBitmapFromScan0(Me.ScaleWidth, Me.ScaleHeight, Me.ScaleWidth * 4, PixelFormat32bppARGB, ByVal 0, bg) Then Unload Me
    If GdipGetImageGraphicsContext(bg, gr2) Then Unload Me
    If GdipSetSmoothingMode(gr, SmoothingModeAntiAlias) Then Unload Me
    If GdipSetSmoothingMode(gr2, SmoothingModeAntiAlias) Then Unload Me
    Set Tmr = Me.Controls.Add("VB.Timer", "Tmr")
    ReDim pt(BranchCount * 2 - 1): ReDim Lamp(BranchCount \ 3 - 2): ReDim sp(BranchCount \ 4 - 1)
    n = Me.ScaleWidth / 3: dy = Me.ScaleHeight / BranchCount / 1.4: sw = Me.ScaleWidth / 2
    dx = n / BranchCount: oy = Me.ScaleHeight * 0.25: MaxLen = Sqr(n * n + 30 * 30)
    pt(0) = vec(sw, oy): pt(1) = vec(Me.ScaleWidth / 2 - 8, Me.ScaleHeight): pt(2) = vec(sw + 8, pt(1).y)
    GdipFillPolygon2 gr2, br, pt(0), 3
    Branch vec(sw, oy + Me.ScaleHeight / 1.5), vec(0, -Me.ScaleHeight / 3), 0, vec(0, 0)
    For n = 0 To BranchCount - 1
        pt(n * 2) = vec(0, 0): pt(n * 2 + 1) = vec(0, 0)
        Call Branch(vec(sw, n * dy + oy), vec(-dx * n, -30), 0, pt(n * 2)): pt(n * 2).x = pt(n * 2).x + sw
        Call Branch(vec(sw, n * dy + oy), vec(dx * n, -30), 0, pt(n * 2 + 1)): pt(n * 2 + 1).x = pt(n * 2 + 1).x + sw
        If n Mod 3 = 0 And n > 1 And n < BranchCount - 1 Then Lamp((n - 1) \ 3) = pt(n * 2)
        If n Mod 4 = 0 And n > 1 Then sp((n - 1) \ 4) = pt(n * 2 + 1)
    Next
    For n = 0 To UBound(sp): dy = (sp(n).x - sw): For dx = 0 To dy Step 10
        v = vec(Lerp(sp(n).x, sw - dy, dx / dy), Lerp(sp(n).y, sp(n).y + 10, Sin(dx / dy * 3.14) * (dy / MaxLen) * 2))
        GdipCreatePath 0, Pth
        GdipAddPathEllipse Pth, v.x - SphereSize, v.y - SphereSize / 2, SphereSize, SphereSize
        GdipCreatePathGradientFromPath Pth, br2
        GdipSetPathGradientCenterPoint br2, vec(v.x - SphereSize / 3, v.y - SphereSize / 3)
        Col = QBColor(Rnd * 15)
        GdipSetPathGradientCenterColor br2, ARGB(255, vbWhite)
        GdipSetPathGradientSurroundColorsWithCount br2, ARGB(64, Col), 1
        GdipFillPath gr2, br2, Pth: GdipDeleteBrush br2: GdipDeletePath Pth
    Next: Next
    dx = 2.199
    For n = 0 To 9 Step 2
        pt(n) = vec(Cos(dx) * StarSize + Me.ScaleWidth / 2, Sin(dx) * StarSize + oy - StarSize - 15): dx = dx + 0.628
        pt(n + 1) = vec(Cos(dx) * StarSize / 2 + Me.ScaleWidth / 2, Sin(dx) * StarSize / 2 + oy - StarSize - 15): dx = dx + 0.628
    Next
    SetWindowLong Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED
    Tmr.Enabled = True: Tmr.Interval = 32: Call Tmr_Timer
End Sub
 
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    ReleaseCapture
    SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    If pn Then GdipDeletePen (pn)
    If br Then GdipDeleteBrush (br)
    If gr Then GdipDeleteGraphics (gr)
    If gr2 Then GdipDeleteGraphics (gr2)
    If bg Then GdipDisposeImage (bg)
    GdiplusShutdown (token)
End Sub
Private Sub Tmr_Timer()
    Static n As Long, c As Long, d As Single, x As Long, y As Long, dx As Single, Pth As Long, br2 As Long, v As Vector, _
        Col As Long, B As Single, s As Single, dir As Single, sz As Currency, pts As Currency
    d = Sin(c / 10): c = (c + 1) Mod 31: dir = 1
    GdipGraphicsClear gr, &HFF000000
    GdipDrawImage gr, bg, 0, 0
    GdipSetSolidFillColor br, ARGB(d * 128 + 127, vbBlue): GdipSetPenWidth pn, 1: GdipSetPenColor pn, &HFFFF5050
    GdipFillPolygon2 gr, br, pt(0), 10
    GdipDrawPolygon gr, pn, pt(0), 10
    For n = 0 To 9
        GdipDrawLine gr, pn, Me.ScaleWidth / 2, Me.ScaleHeight * 0.25 - StarSize - 15, pt(n).x, pt(n).y
    Next
    For n = 0 To UBound(Lamp): d = sw - Lamp(n).x: dir = -dir: For x = 0 To d Step 2
        B = Abs(Sin(s))
        v = vec(Lerp(Lamp(n).x, sw + d, x / d), Lerp(Lamp(n).y, Lamp(n).y + 10, Sin(x / d * 3.14) * (d / MaxLen) * 3))
        GdipCreatePath 0, Pth
        GdipAddPathEllipse Pth, v.x - LampSize / 2, v.y - LampSize / 2, LampSize, LampSize
        GdipCreatePathGradientFromPath Pth, br2
        GdipSetPathGradientCenterPoint br2, vec(v.x, v.y)
        GdipSetPathGradientCenterColor br2, ARGB(B * 255, vbCyan)
        GdipSetPathGradientSurroundColorsWithCount br2, 0, 1
        GdipFillPath gr, br2, Pth: GdipDeleteBrush br2: GdipDeletePath Pth
        s = s + 2 * dir
    Next:  Next
    Me.Refresh
    sz = (Me.ScaleWidth + CCur(Me.ScaleHeight) * 4294967296#) / 10000
    UpdateLayeredWindow Me.hWnd, Me.hdc, ByVal 0, sz, Me.hdc, pts, 0, AB_32Bpp255, ULW_ALPHA
End Sub
Public Function ARGB(ByVal Alpha As Byte, Col As Long) As Long
  Dim bytestruct As COLORBYTES
  Dim result As COLORLONG
  With bytestruct
      .AlphaByte = Alpha
      .RedByte = (Col And &HFF0000) \ &H10000
      .GreenByte = (Col And &HFF00&) \ &H100
      .BlueByte = (Col And &HFF)
  End With
  LSet result = bytestruct
  ARGB = result.longval
End Function

Attached Files

[VB6] - Vocoder.

$
0
0
Hello everyone. Creating music, I've seen a lot of different virtual instruments and effects. One of the most interesting effects is the vocoder, which allows you to modulate his voice and make it look like a voice for example a robot or something like that. Vocoder was originally used to compress the voice data, and then it began to be used in the music industry. Because I had free time, I decided to write something like this for the sake of the experiment and describe in detail the stages of development for VB6.
So, take a look at the simplest scheme vocoder:

The signal from the microphone (speech) is fed to a bank of bandpass filters, each of which passes only a small part of the frequency band of the speech signal. The greater the number of filters - the better speech intelligibility. At the same time, the carrier signal (e.g. ramp) is also passed through the same filter bank. Filter output speech signal is fed to envelope detectors which control modulators and outputs a filter carrier signal passes to the other input of the modulator. As a result, each band speech signal adjusts the level of the corresponding band carrier (modulates it). Further, output signals from all modulators are mixed and sent to the output. Further, all signal modulators are mixed and sent to the output. In order to improve speech intelligibility also apply additional blocks, such as the detector "sizzling" sound. So, to begin development necessary to determine the source signals, where they will take. It is possible for example to capture data from a file or directly processed in real-time from a microphone or line input. To test very easy to use file, so we will do and so and so. As the carrier will use an external file looped in a circle, to adjust the tone simply add the ability to change the playback speed, which will change the tone. To capture the sound of the file will use Audio Compression Manager (ACM), with it very convenient to make conversion between formats (because the file can be in any format, you would have to write some functions to different formats). It may be that to convert to the desired format will not correct ACM drivers, then play this file will not be available (although you can try to do it in 2 stages). As input files will use the wav - files, because to work with them in the system has special features to facilitate retrieving data from them.

[VB6] - Rotation a windowless controls.

$
0
0
Code:

Option Explicit

Private Type XFORM
  eM11 As Single
  eM12 As Single
  eM21 As Single
  eM22 As Single
  eDx As Single
  eDy As Single
End Type

Private Declare Function SetGraphicsMode Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long) As Long
Private Declare Function SetWorldTransform Lib "gdi32" (ByVal hdc As Long, lpXform As XFORM) As Long
Private Declare Function ModifyWorldTransform Lib "gdi32" (ByVal hdc As Long, lpXform As XFORM, ByVal iMode As Long) As Long
Private Const MWT_IDENTITY = 1
Private Const MWT_LEFTMULTIPLY = 2
Private Const MWT_RIGHTMULTIPLY = 3

Private Const GM_ADVANCED = 2
Private Const GM_COMPATIBLE = 1

Private Sub Form_Load()
    SetGraphicsMode Me.hdc, GM_ADVANCED
End Sub

Private Sub Form_Paint()
    Dim mtx1 As XFORM, mtx2 As XFORM, c As Single, s As Single, p As IPicture
    ModifyWorldTransform Me.hdc, mtx1, MWT_IDENTITY
    Me.Line (0, 0)-(Me.ScaleWidth, Me.ScaleHeight), Me.BackColor, BF
    c = Cos(hsbAngle.Value / 100)
    s = Sin(hsbAngle.Value / 100)
    mtx1.eM11 = c: mtx1.eM12 = s: mtx1.eM21 = -s: mtx1.eM22 = c: mtx1.eDx = Me.ScaleWidth / 2: mtx1.eDy = Me.ScaleHeight / 2
    mtx2.eM11 = 1: mtx2.eM22 = 1: mtx2.eDx = -Me.ScaleWidth / 2: mtx2.eDy = -Me.ScaleHeight / 2
    SetWorldTransform Me.hdc, mtx1
    ModifyWorldTransform Me.hdc, mtx2, MWT_LEFTMULTIPLY
End Sub

Private Sub hsbAngle_Change()
    Me.Refresh
End Sub

Attached Files

[VB6] - Module with advanced mathematical functions for real and complex numbers.

$
0
0
Code:

'+=====================================================================================================================================+
'|                                                                                                                                    |
'|                                    An additional set of mathematical functions for Visual Basic 6                                  |
'|                                                                                                                                    |
'|                                          Кривоус Анатолий Анатольевич (The trick)                                                  |
'|                                                                                                                                    |
'+=====================================================================================================================================+

Private Declare Function GetMem2 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (arr() As Any) As Long

Public Type Complex
    R  As Double
    I  As Double
End Type

Public Type Matrix
    Col As Long                ' Number of columns
    Row As Long                ' Number of rows
    D() As Double
End Type

Public Const PI = 3.14159265358979
Public Const E = 2.71828182845905

Private Const PI2 = PI / 2

'+=====================================================================================================================================+
'|                                                            Real numbers                                                            |
'+=====================================================================================================================================+

' // From degree to radians
Public Function Deg(ByVal Value As Double) As Double
    Deg = 1.74532925199433E-02 * Value
End Function

' // The logarithm to the base of a real number X
Public Function LogX(ByVal Value As Double, ByVal Base As Double) As Double
    LogX = Log(Value) / Log(Base)
End Function

' // The decimal logarithm of a real number
Public Function Log10(ByVal Value As Double) As Double
    Log10 = Log(Value) / 2.30258509299405
End Function

' // The binary logarithm of a real number
Public Function Log2(ByVal Value As Double) As Double
    Log2 = Log(Value) / 0.693147180559945
End Function

' // Rounding up
Public Function Ceil(ByVal Value As Double) As Double
    Ceil = -Int(-Value)
End Function

' // Rounding down (Int)
Public Function Floor(ByVal Value As Double) As Double
    Floor = Int(Value)
End Function

' // Secant of a real number
Public Function Sec(ByVal Value As Double) As Double
    Sec = 1 / Cos(Value)
End Function

' // Cosecant of a real number
Public Function Csc(ByVal Value As Double) As Double
    Csc = 1 / Sin(Value)
End Function

' // Cotangent of a real number
Public Function Ctg(ByVal Value As Double) As Double
    Ctg = 1 / Tan(Value)
End Function

' // Arcsine of a real number
Public Function Asin(ByVal Value As Double) As Double
    If Value = -1 Then Asin = -PI2: Exit Function
    If Value = 1 Then Asin = PI2: Exit Function
    Asin = Atn(Value / Sqr(-Value * Value + 1))
End Function

' // Arccosine of a real number
Public Function Acos(ByVal Value As Double) As Double
    If CSng(Value) = -1# Then Acos = PI: Exit Function
    If CSng(Value) = 1# Then Acos = 0: Exit Function
    Acos = Atn(-Value / Sqr(-Value * Value + 1)) + 2 * Atn(1)
End Function

' // Arcsecant of a real number
Public Function Asec(ByVal Value As Double) As Double
    Asec = 1.5707963267949 - Atn(Sgn(Value) / Sqr(Value * Value - 1))
End Function

' // Arccosecant of a real number
Public Function Acsc(ByVal Value As Double) As Double
    Acsc = Atn(Sgn(Value) / Sqr(Value * Value - 1))
End Function

' // Returns the angle whose tangent is the ratio of the two numbers
Public Function Atan2(ByVal Y As Double, ByVal X As Double) As Double
    If Y > 0 Then
        If X >= Y Then
            Atan2 = Atn(Y / X)
        ElseIf X <= -Y Then
            Atan2 = Atn(Y / X) + PI
        Else
            Atan2 = PI / 2 - Atn(X / Y)
        End If
    Else
        If X >= -Y Then
            Atan2 = Atn(Y / X)
        ElseIf X <= Y Then
            Atan2 = Atn(Y / X) - PI
        Else
            Atan2 = -Atn(X / Y) - PI / 2
        End If
    End If
End Function

' // Arccotangent of a real number
Public Function Actg(ByVal Value As Double) As Double
    Actg = 1.5707963267949 - Atn(Value)
End Function

' // Hyperbolic sine of a real number
Public Function Sinh(ByVal Value As Double) As Double
    Sinh = (Exp(Value) - Exp(-Value)) / 2
End Function

' // Hyperbolic cosine of a real number
Public Function Cosh(ByVal Value As Double) As Double
    Cosh = (Exp(Value) + Exp(-Value)) / 2
End Function

' // Hyperbolic tangent of a real number
Public Function Tanh(ByVal Value As Double) As Double
    Tanh = (Exp(2 * Value) - 1) / (Exp(2 * Value) + 1)
End Function

' // Hyperbolic cotangent of a real number
Public Function Ctgh(ByVal Value As Double) As Double
    Ctgh = 1 / (Exp(2 * Value) + 1) / (Exp(2 * Value) - 1)
End Function

' // Hyperbolic secant of a real number
Public Function Sech(ByVal Value As Double) As Double
    Sech = 2 / (Exp(Value) + Exp(-Value))
End Function

' // Hyperbolic cosecant of a real number
Public Function Csch(ByVal Value As Double) As Double
    Csch = 2 / (Exp(Value) - Exp(-Value))
End Function

' // Hyperbolic arcsine of a real number
Public Function Asinh(ByVal Value As Double) As Double
    Asinh = Log(Value + Sqr(Value * Value + 1))
End Function

' // Hyperbolic arcosine of a real number
Public Function Acosh(ByVal Value As Double) As Double
    Acosh = Log(Value + Sqr(Value * Value - 1))
End Function

' // Hyperbolic arctangent of a real number
Public Function Atanh(ByVal Value As Double) As Double
    Atanh = Log((1 + Value) / (1 - Value)) / 2
End Function

' // Hyperbolic arccotangent of a real number
Public Function Actan(ByVal Value As Double) As Double
    Actan = Log((Value + 1) / (Value - 1)) / 2
End Function

' // Hyperbolic arcsecant of a real number
Public Function Asech(ByVal Value As Double) As Double
    Asech = Log((Sqr(-Value * Value + 1) + 1) / Value)
End Function

' // Hyperbolic arccosecant of a real number
Public Function Acsch(ByVal Value As Double) As Double
    Acsch = Log((Sgn(Value) * Sqr(Value * Value + 1) + 1) / Value)
End Function

' // Return maximum of two numbers
Public Function Max(ByVal Op1 As Double, ByVal Op2 As Double) As Double
    Max = IIf(Op1 > Op2, Op1, Op2)
End Function

' // Return maximum of three numbers
Public Function Max3(ByVal Op1 As Double, ByVal Op2 As Double, ByVal Op3 As Double) As Double
    Max3 = IIf(Op1 > Op2, IIf(Op1 > Op3, Op1, Op3), IIf(Op2 > Op3, Op2, Op3))
End Function

' // Return maximum of four numbers
Public Function Max4(ByVal Op1 As Double, ByVal Op2 As Double, ByVal Op3 As Double, ByVal Op4 As Double) As Double
    Max4 = Max(Max3(Op1, Op2, Op3), Op4)
End Function

' // Return minimum of two numbers
Public Function Min(ByVal Op1 As Double, ByVal Op2 As Double) As Double
    Min = IIf(Op1 < Op2, Op1, Op2)
End Function

' // Return minimum of three numbers
Public Function Min3(ByVal Op1 As Double, ByVal Op2 As Double, ByVal Op3 As Double) As Double
    Min3 = IIf(Op1 < Op2, IIf(Op1 < Op3, Op1, Op3), IIf(Op2 < Op3, Op2, Op3))
End Function

' // Return minimum of four numbers
Public Function Min4(ByVal Op1 As Double, ByVal Op2 As Double, ByVal Op3 As Double, ByVal Op4 As Double) As Double
    Min4 = Min(Min3(Op1, Op2, Op3), Op4)
End Function

' // Returns the remainder of dividing one specified number by another specified number.
Public Function IEEERemainder(ByVal Op1 As Double, ByVal Op2 As Double) As Double
    IEEERemainder = Op1 - (Op2 * Round(Op1 / Op2))
End Function

' // Returns the remainder of dividing one specified number by another specified number.
Public Function rMod(ByVal Op1 As Double, ByVal Op2 As Double) As Double
    rMod = (Abs(Op1) - (Abs(Op2) * (Int(Abs(Op1) / Abs(Op2))))) * Sgn(Op1)
End Function

Unhighlighting ComboBox, DropdownCombo text in VB6

$
0
0
Although it is a minor aesthetic issue, when I have a dropdown list I do not like to see the text highlighted either at the program start or after selecting a list item. Most of the time I also have the keypress() method set keyascii to 0 as I rarely use these as input fields. Below is the code that uses a timer control as a one-shot outside of the list box execution: It is fast, keeps the focus in the list control and does not use cycles unless it actually needs to clear the highlight.



Code:

Public Sub uhl(index As Integer)
'//////////////////////////////////////////////////////////////////////////////
'This un-highlights the text in ComboBox controls set as a DropdownCombo.  It
'only works on a "DropdownCombo" because the "DropdownList" does not actually
'have the SelLength property.  The timer is set to 1mS and is active only
'once per list box event (As opposed to constantly monitoring/unhighlighting
'the list box:  This would not do for real time loaded apps!)
'
'Put "Call uhl(index)" in the click(), change(), dbl_click(), got_focus() and
'scroll() methods of any combo lists to un-highlight.
'
'(index) tells uhl() which control to update.
'
'This needs to be done as the last external execution of these methods as any
'call outside of the method re-highlights the text on its return as if it was
'a new got focus event.
'//////////////////////////////////////////////////////////////////////////////
Static uhlindex As Integer
Select Case index
  Case -1
    'Called by the timer, this is not called by the list box and so can
    'actually unhighlight the text.
    Select Case uhlindex
      Case 0
        combo0.SelLength = 0
      Case 1
        combo1.SelLength = 0
    End Select
    'the timer is turned off
    uhltimer.Enabled = False
  Case Else
    'Called by the list box, this saves the index and enables the timer.
    'This essentially triggers an independent process outside of the list box
    'to do the un-highlight.
    'save the index
    uhlindex = index
    'set the timer interval to 1ms and turn it on
    uhltimer.Interval = 1
    uhltimer.Enabled = True
End Select
End Sub


Private Sub uhltimer_Timer()
'This calls another instance of UHL() to do the actual un-highlighting
Call uhl(-1)
End Sub

Unhighlighting ComboBox, DropdownCombo text in VB6 SP3

$
0
0
'Although it is a minor aesthetic issue, when I have a dropdown list I do
'not like to see the text highlighted either at the program start or after
'selecting a list item. Most of the time I also have the keypress() method
'set keyascii to 0 as I rarely use these as input fields. Below is the code
'that uses a timer control as a one-shot outside of the list box execution:
'It is fast, keeps the focus in the list control and does not use cycles unless
'it actually needs to clear the highlight.



Public Sub uhl(index As Integer)
'//////////////////////////////////////////////////////////////////////////////
'This un-highlights the text in ComboBox controls set as a DropdownCombo. It
'only works on a "DropdownCombo" because the "DropdownList" does not actually
'have the SelLength property. The timer is set to 1mS and is active only
'once per list box event (As opposed to constantly monitoring/unhighlighting
'the list box: This would not do for real time loaded apps!)
'
'Put "Call uhl(index)" in the click(), change(), dbl_click(), got_focus() and
'scroll() methods of any combo lists to un-highlight.
'
'(index) tells uhl() which control to update.
'
'This needs to be done as the last external execution of these methods as any
'call outside of the method re-highlights the text on its return as if it was
'a new got focus event.
'//////////////////////////////////////////////////////////////////////////////
Static uhlindex As Integer
Select Case index
Case -1
'Called by the timer, this is not called by the list box and so can
'actually unhighlight the text.
Select Case uhlindex
Case 0
combo0.SelLength = 0
Case 1
combo1.SelLength = 0
End Select
'the timer is turned off
uhltimer.Enabled = False
Case Else
'Called by the list box, this saves the index and enables the timer.
'This essentially triggers an independent process outside of the list box
'to do the un-highlight.
'save the index
uhlindex = index
'set the timer interval to 1ms and turn it on
uhltimer.Interval = 1
uhltimer.Enabled = True
End Select
End Sub


Private Sub uhltimer_Timer()
'This calls another instance of UHL() to do the actual un-highlighting
Call uhl(-1)
End Sub

[VB6] - Combobox for color selection.

$
0
0
Standard VB combo box does not allow standard means to draw on the list. To work around this limitation, in its module I use OWNERDRAW style combo box. After small completion, you can do anything with the list.
Code:

Option Explicit
 
' Модуль для создания комбинированного списка с выбором цветов
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type DRAWITEMSTRUCT
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemAction As Long
    itemState As Long
    hwndItem As Long
    hdc As Long
    rcItem As RECT
    itemData As Long
End Type
Private Type MEASUREITEMSTRUCT
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemWidth As Long
    itemHeight As Long
    itemData As Long
End Type
 
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
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 Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function SetDCBrushColor Lib "gdi32" (ByVal hdc As Long, ByVal colorref As Long) As Long
Private Declare Function SetDCPenColor Lib "gdi32" (ByVal hdc As Long, ByVal colorref As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, lpStr As Any, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
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 Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
 
Private Const TRANSPARENT As Long = 1
Private Const COLOR_WINDOW As Long = 5
Private Const COLOR_WINDOWTEXT As Long = 8
Private Const COLOR_HIGHLIGHT As Long = 13
Private Const COLOR_HIGHLIGHTTEXT As Long = 14
Private Const ODS_SELECTED As Long = &H1
Private Const DC_PEN As Long = 19
Private Const DC_BRUSH As Long = 18
Private Const WH_CBT As Long = 5
Private Const HCBT_CREATEWND As Long = 3
Private Const GWL_WNDPROC = &HFFFFFFFC
Private Const ODT_COMBOBOX As Long = 3
Private Const CBS_OWNERDRAWFIXED As Long = &H10&
Private Const CBS_DROPDOWNLIST As Long = &H3&
Private Const CBS_HASSTRINGS As Long = &H200&
Private Const WM_MEASUREITEM As Long = &H2C
Private Const WM_DRAWITEM = &H2B
Private Const GWL_STYLE As Long = &HFFFFFFF0
Private Const WM_DESTROY As Long = &H2
Private Const DT_SINGLELINE As Long = &H20, DT_VCENTER As Long = &H4
Private Const CB_GETLBTEXT As Long = &H148
Private Const CB_GETLBTEXTLEN As Long = &H149
 
Dim hHook As Long
 
Public Function CreateOwnerdrawCombo(Form As Form, Name As String, Optional Container As Control) As ComboBox
    Dim Prev As Long
    hHook = SetWindowsHookEx(WH_CBT, AddressOf CBTProc, 0, App.ThreadID)
    If Container Is Nothing Then
        Set CreateOwnerdrawCombo = Form.Controls.Add("VB.ComboBox", Name)
    Else: Set CreateOwnerdrawCombo = Form.Controls.Add("VB.ComboBox", Name, Container)
    End If
    UnhookWindowsHookEx hHook
    If Not CreateOwnerdrawCombo Is Nothing Then
        Prev = GetProp(CreateOwnerdrawCombo.Container.hwnd, "prev")
        If Prev = 0 Then
            Prev = SetWindowLong(CreateOwnerdrawCombo.Container.hwnd, GWL_WNDPROC, AddressOf WndProc)
            SetProp CreateOwnerdrawCombo.Container.hwnd, "prev", Prev
        End If
    End If
End Function
Private Function CBTProc(ByVal uCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If uCode = HCBT_CREATEWND Then
        Dim Class As String, l As Long, Style As Long
        Class = Space(256)
        l = GetClassName(wParam, Class, 255)
        If l Then
            Class = Left(Class, l)
            If StrComp(Class, "ThunderComboBox", vbTextCompare) = 0 Or _
              StrComp(Class, "ThunderRT6ComboBox", vbTextCompare) = 0 Then
                Style = GetWindowLong(wParam, GWL_STYLE)
                SetWindowLong wParam, GWL_STYLE, Style Or CBS_OWNERDRAWFIXED Or CBS_DROPDOWNLIST Or CBS_HASSTRINGS
            End If
        End If
    End If
    CBTProc = CallNextHookEx(hHook, uCode, wParam, ByVal lParam)
End Function
Private Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim Prev As Long
    Select Case uMsg
    Case WM_DESTROY
        Prev = GetProp(hwnd, "prev")
        SetWindowLong hwnd, GWL_WNDPROC, Prev
        RemoveProp hwnd, "prev"
        WndProc = CallWindowProc(Prev, hwnd, uMsg, wParam, lParam)
    Case WM_DRAWITEM
        Dim drw As DRAWITEMSTRUCT
        CopyMemory drw, ByVal lParam, Len(drw)
        If drw.CtlType = ODT_COMBOBOX Then
            DrawItem drw
            WndProc = True
        Else
            Prev = GetProp(hwnd, "prev")
            WndProc = CallWindowProc(Prev, hwnd, uMsg, wParam, lParam)
        End If
    Case WM_MEASUREITEM
        Dim meas As MEASUREITEMSTRUCT, RC As RECT
        CopyMemory meas, ByVal lParam, Len(meas)
        If meas.CtlType = ODT_COMBOBOX Then
            GetClientRect hwnd, RC
            meas.itemWidth = RC.Right - RC.Left
            CopyMemory ByVal lParam, meas, Len(meas)
            WndProc = True
        Else
            Prev = GetProp(hwnd, "prev")
            WndProc = CallWindowProc(Prev, hwnd, uMsg, wParam, lParam)
        End If
    Case Else
        Prev = GetProp(hwnd, "prev")
        WndProc = CallWindowProc(Prev, hwnd, uMsg, wParam, lParam)
    End Select
End Function
 
Private Function DrawItem(drw As DRAWITEMSTRUCT) As Boolean
    Dim obr As Long, opn As Long, l As Long, s As String
    obr = SelectObject(drw.hdc, GetStockObject(DC_BRUSH))
    opn = SelectObject(drw.hdc, GetStockObject(DC_PEN))
    If (drw.itemState And ODS_SELECTED) Then
        SetDCBrushColor drw.hdc, GetSysColor(COLOR_HIGHLIGHT)
        SetDCPenColor drw.hdc, GetSysColor(COLOR_HIGHLIGHT)
        Rectangle drw.hdc, drw.rcItem.Left, drw.rcItem.Top, drw.rcItem.Right, drw.rcItem.Bottom
        SetDCPenColor drw.hdc, GetSysColor(COLOR_HIGHLIGHTTEXT)
        SetTextColor drw.hdc, GetSysColor(COLOR_HIGHLIGHTTEXT)
    Else
        SetDCBrushColor drw.hdc, GetSysColor(COLOR_WINDOW)
        SetDCPenColor drw.hdc, GetSysColor(COLOR_WINDOW)
        Rectangle drw.hdc, drw.rcItem.Left, drw.rcItem.Top, drw.rcItem.Right, drw.rcItem.Bottom
        SetDCPenColor drw.hdc, GetSysColor(COLOR_WINDOWTEXT)
        SetTextColor drw.hdc, GetSysColor(COLOR_WINDOWTEXT)
    End If
    SetBkMode drw.hdc, TRANSPARENT
    If drw.itemID >= 0 Then
        SetDCBrushColor drw.hdc, drw.itemData
        Rectangle drw.hdc, drw.rcItem.Left + 3, drw.rcItem.Top + 3, drw.rcItem.Left + 70, drw.rcItem.Bottom - 3
        l = SendMessage(drw.hwndItem, CB_GETLBTEXTLEN, drw.itemID, ByVal 0)
        If l Then
            s = Space(l + 1)
            l = SendMessage(drw.hwndItem, CB_GETLBTEXT, drw.itemID, ByVal s)
            s = Left(s, l)
            drw.rcItem.Left = drw.rcItem.Left + 78
        End If
    Else
        drw.rcItem.Left = drw.rcItem.Left + 2
        s = "None"
    End If
    DrawText drw.hdc, ByVal s, Len(s), drw.rcItem, DT_VCENTER Or DT_SINGLELINE
    SelectObject drw.hdc, obr
    SelectObject drw.hdc, opn
End Function

Attached Files

[VB6] - Circular spectrum visualizer.

$
0
0

Hello everyone! Representing the source code and compiled program graphical visualizer audio spectrum. The sound is analyzed through a standard recording device, i.e. You can select the microphone and view range with it, or you can select stereo mixer and view the range of playback sound. In this visualizer is possible to adjust the number of displayed octaves, adjustable transparency background, amplification. You can also loading a palette of external PNG file format 32ARGB, damping effects "blur" and "burning". Visualizer allows viewing range in two modes as arcs (rings) in the form of sectors. In the first form of the radial coordinate is responsible for the frequency octave, corner - between octaves. Harmonics are separated from each other by an octave, are on the same line, color - intensity. In the second mode, the radial coordinate - the volume, color - frequency, angular coordinate - frequency (period - 1 octave). This idea was suggested to me Vladislav Petrovky (aka Hacker), only his idea a little differently had displayed spectrum as a curve, I have done in the form of sectors.

modAudio.bas module:
Code:

Option Explicit
 
' Модуль modAudio.bas для захвата звука в программе TrickSpectrum
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Public Type WAVEFORMATEX                                        ' Структура формата аудио
    wFormatTag As Integer                                      ' Тип
    nChannels As Integer                                        ' Кол-во каналов
    nSamplesPerSec As Long                                      ' Частота дискретизации
    nAvgBytesPerSec As Long                                    ' Количество байт в секунду
    nBlockAlign As Integer                                      ' Выравнивание бока данных в байтах
    wBitsPerSample As Integer                                  ' Байт на выборку
    cbSize As Integer                                          ' Размер доп. данных
End Type
 
Public Type WAVEHDR                                            ' Структура заголовка буфера
    lpData As Long                                              ' Указатель на данные буфера
    dwBufferLength As Long                                      ' Размер буфера в байтах
    dwBytesRecorded As Long                                    ' Количество записанных байтов
    dwUser As Long                                              ' Данные пользователя
    dwFlags As Long                                            ' Флаги
    dwLoops As Long                                            ' Количество закольцованнх проигрываний
    lpNext As Long
    Reserved  As Long
End Type
 
Public Type BUFFER                                              ' Структура буфера
    Data() As Integer                                          ' Данные
    Header As WAVEHDR                                          ' Заголовок
End Type
 
Public Declare Function waveInOpen Lib "winmm.dll" (lphWaveIn As Long, ByVal uDeviceID As Long, lpFormat As WAVEFORMATEX, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Public Declare Function waveInPrepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveInReset Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInStart Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInStop Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInUnprepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveInClose Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInGetErrorText Lib "winmm.dll" Alias "waveInGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Public Declare Function waveInAddBuffer Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
 
Public Const mSampleRate As Long = 44100                        ' Частота дискретизации
Public Const BufSizeMS As Single = 0.03                        ' Размер буфера в секундах
 
Public Const WAVE_MAPPER = -1&
Public Const CALLBACK_WINDOW = &H10000
Public Const WAVE_FORMAT_PCM = 1
Public Const MM_WIM_DATA = &H3C0
 
Dim hWave As Long                                              ' Дескриптор записывающего устройства
Dim Fmt As WAVEFORMATEX                                        ' Формат записи
Dim Buffers() As BUFFER                                        ' Буферы
 
' Функция инициализирует запись
Public Function InitCapture() As Boolean
    Dim ret As Long, msg As String, i As Long, count As Long
   
    ' Задаем формат записи
    With Fmt
        .cbSize = 0
        .wFormatTag = WAVE_FORMAT_PCM
        .wBitsPerSample = 16
        .nSamplesPerSec = mSampleRate
        .nChannels = 2
        .nBlockAlign = .nChannels * .wBitsPerSample / 8
        .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
    End With
   
    ' Вычисляем размер буфера в выборках
    count = Fmt.nAvgBytesPerSec * BufSizeMS
    count = count - (count Mod Fmt.nBlockAlign)
   
    ' Открываем устройство записи
    ret = waveInOpen(hWave, WAVE_MAPPER, Fmt, frmMain.hwnd, 0, CALLBACK_WINDOW)
   
    If ret Then ShowMessage ret: Exit Function
   
    ' 4 буфера
    ReDim Buffers(3)
   
    ' Подготовка буферов
    For i = 0 To UBound(Buffers)
        With Buffers(i)
            ReDim .Data(count - 1)
            .Header.lpData = VarPtr(.Data(0))
            .Header.dwBufferLength = count * 2
            .Header.dwFlags = 0
            .Header.dwLoops = 0
            ret = waveInPrepareHeader(hWave, .Header, Len(.Header))
            If ret Then ShowMessage ret: Exit Function
        End With
    Next i
   
    ' Отправка буферов устройству
    For i = 0 To UBound(Buffers)
        ret = waveInAddBuffer(hWave, Buffers(i).Header, Len(Buffers(i).Header))
        If ret Then ShowMessage ret: Exit Function
    Next i
   
    ' Начинаем запись
    ret = waveInStart(hWave)
    If ret Then ShowMessage ret: Exit Function
   
    ' Успешно
    InitCapture = True
End Function
 
' Процедура останавливает запись
Public Sub EndCapture()
    Dim i As Long
    ' Сброс устройства и возвращение всех буферов приложению
    waveInReset hWave
    ' Остановка записи
    waveInStop hWave
   
    ' ОСвобождение заголовков буферов
    For i = 0 To UBound(Buffers)
        waveInUnprepareHeader hWave, Buffers(i).Header, Len(Buffers(i).Header)
    Next
   
    ' Закрытие устройства записи
    waveInClose hWave
End Sub
 
' Функция вызывается при очередном заполненном буфере
Public Function OnCapture(Hdr As WAVEHDR) As Boolean
    Dim i As Long
    ' Получаем индекс буфера
    i = modAudio.GetBufferIndex(Hdr.lpData)
    If i = -1 Then Exit Function
    ' Вызываем отрисовку
    modMain.Draw modAudio.Buffers(i).Data
    ' Отправка буфера устройству
    waveInAddBuffer hWave, Buffers(i).Header, Len(Buffers(i).Header)
End Function
 
' Функция возвращает индекс буфера по его указателю
Private Function GetBufferIndex(ByVal Ptr As Long) As Long
    Dim i As Long
    For i = 0 To UBound(Buffers)
        If Buffers(i).Header.lpData = Ptr Then GetBufferIndex = i: Exit Function
    Next
    GetBufferIndex = -1
End Function
 
' Процедура показывает сообщение об ошибке
Private Sub ShowMessage(ByVal Code As Long)
    Dim msg As String
    msg = Space(255)
    waveInGetErrorText Code, msg, Len(msg)
    MsgBox "Error capture." & vbNewLine & msg
End Sub

[VB6] - Custom rendering window.

$
0
0

In Windows 7, there was a remarkable thing - indication of progress on the taskbar button. To use this feature on VB6 (and any other language) you need to create an object TaskBarList, get ITaskBarList3 interface and use its methods - SetProgressState and SetProgressValue. In my module, I added the ability to set the state of the progress bar on the taskbar, and duplicated this indicator on the form itself + added ability to use animated icons in the form header (also supported by the usual icons). From this example, you can learn how to draw the non-client area of the window, make buttons that are highlighted when hovering. The example uses double buffering, so everything works smoothly and without flicker. This module can be connected to any project with any forms.
Functions:
SetNCSkin - set new style window;
RemoveNCSkin - remove style from window;
SetIcon - set animated (or simple) icon to window;
PlayAnimation - enable playing icon animation;
StopAnimation - stop animation playing;
SetProgressState - set state of taskbar button;
GetProgressState - get state of taskbar button;
SetProgressValue - set value of progressbar in the taskbar button (0..1);
GetProgressValue - same, only get a value.

Example use:
Code:

Option Explicit
 
' Тестовая форма модуля пользовательской отрисовки окна
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Dim Value As Single
 
Private Sub cboIcon_Click()
    Select Case cboIcon.ListIndex
    Case 0: SetIcon Me, LoadResPicture("TRICKICON", vbResBitmap), 21
    Case 1: SetIcon Me, LoadResPicture("WAITICON", vbResBitmap), 20
    End Select
End Sub
 
Private Sub cmdDuplicate_Click()
    Dim frm As frmTest
    Set frm = New frmTest
    frm.Show
End Sub
 
Private Sub cmdHideProgress_Click()
    SetProgressState Me, TBPF_NOPROGRESS
End Sub
 
Private Sub cmdIcon_Click()
    PlayAnimation Me, 32, False
End Sub
Private Sub cmdIconLoop_Click()
    PlayAnimation Me, 32, True
End Sub
Private Sub cmdProgress_Click()
    tmrTimer.Enabled = True
    Value = 0
End Sub
Private Sub cmdShowProgress_Click()
    If optState(0).Value Then SetProgressState Me, TBPF_NORMAL
    If optState(1).Value Then SetProgressState Me, TBPF_PAUSED
    If optState(2).Value Then SetProgressState Me, TBPF_ERROR
End Sub
Private Sub cmdStopAnimation_Click()
    StopAnimation Me
End Sub
Private Sub cmdStopProgress_Click()
    tmrTimer.Enabled = False
End Sub
Private Sub Form_Load()
    SetNCSkin Me
    cboIcon.ListIndex = 0
End Sub
Private Sub Form_Unload(Cancel As Integer)
    RemoveNCSkin Me
End Sub
Private Sub optState_Click(Index As Integer)
    Call cmdShowProgress_Click
End Sub
 
Private Sub tmrTimer_Timer()
    Value = Value + 0.01
    SetProgressValue Me, Value
End Sub

Attached Files

[VB6] Bytarr - String-style operations by wrapping a Byte array

$
0
0
People seem to get tangled up in their underwear a lot trying to fiddle with binary data in String variables. Often they run into nightmares where they convert Unicode "to Unicode" and then back later, in the vain hope of avoiding data corruption. And then some locale boundary gets crossed and it all falls down. Hard.

From what I've seen the bulk of this comes from the desire to use String operations on binary data. But most of these are fairly trivial to synthesize, especially with the help of CopyMemory.


The Bytarr Class wraps a dynamic Byte array along with several properties and methods to make this easier.

You can use the Class for lots of applications, or when you only need one or two operations it can server as a template for inline code when you don't want the Class.


Bytarr (biter?) is bundled with a test program in the attachment. This also includes my Dump Class, which I find handy for debugging and testing.

Name:  sshot.png
Views: 77
Size:  8.0 KB


There may be lingering bugs, but these should be easily found and fixed as required. You could also add more operations or convert the Class into a binary stringbuilder for better performance when you need to accumulate a lot of chunks into one array.
Attached Images
 
Attached Files

Login and registry system for application

$
0
0
Hi all

As part of my Computing coursework I need to create an application as per a scenario. The full thing is explained in the pdf below:
Training Log.pdf

Due to my work being deleted, I was forced to start again a few weeks back. I decided to approach the scenario a different way. As opposed to creating a database I would use file storage to create and edit the records. My idea has been to create the records using the ''register'' form, but the problem has been that during the debugging phase, instead of creating new records each time it replaces the file each time. E.g, the file in question is called ''runner1'' and when I run the app, I input details and click ''send to file''. If I then open the file under Visual Basic 2008 > Debug > bin > runner1, it opens up a notepad document with the information I entered. However, if I were to debug again, then if I were to enter completely different data, it would not create a new file. Rather, ''runner1'' would simply have the previous information replaced with the new load. I also need to make it so my login system can use the ''ID'' and ''password'' stored in the files can be used for my login screen.

Here are two screenshots of the code I used to create this form of my application:
Name:  structure.PNG
Views: 24
Size:  12.0 KB
Name:  Proceed code.jpg
Views: 15
Size:  21.5 KB

Officially the complete coursework needs to be in by May 15th but my teachers wish to collect it all in by Easter, so I'm really under pressure to get this complete!

Can someone please tell me what I'm doing wrong? I'd really appreciate it, and I'm sorry if this turns out to be trivially easy. I'm a noob and an idiot but I suppose everyone was a beginner once.
Attached Images
  
Attached Images

[VB6] - Injection to another process.

$
0
0

Everyone knows the utility SPYXX. With it you can do a lot of interesting things. Among its features - View messages sent by the window, and the results of their treatment. I decided to do something like that just to VB6 (not as the creation of programs such as SPYXX, as well as a demonstration of the possibility of an injection of code from VB6, so that the functionality of a program is very small). As you know SPYXX does this by using a global hook, but I was interested in the idea of injection without DLL (DLL can be much easier to do, Richter describes how to inject several functions in a foreign process using DLL, and I put an example) and I decided to do a little differently. In my example code along with the window procedure directly copied into the address space of the desired process and it starts (only works with 32-bit applications). There I place the code that establishes a new procedure for processing messages for the window and sleeping thread. In the new procedure, I just superfluous to pass a parameter that someone else got the window, my window (frmSpy), hereinafter called the original window procedure. I have to say - the transfer is not the most efficient way, it was possible to make a much more effective working directly with "FileMapping", or asynchronously transmit 2 posts in a row. But I did not complicate the code over, because my ultimate goal is not effective. Cancel injection is performed awakening threads and completion of its natural way, then from its program I release resources. Work I checked in the debugger everything works as intended.
When running in another process, the runtime is not used, although it is possible to download and use (about context initialization thread separately) its functions, arrays, strings, etc. Also, there is a problem working with variables, as global variables "does not exist", and, accordingly, any reference to such variables could be fatal to the whole process. To call the API I'm using splicing "pseudofunctions API", replace the call to an unconditional jump to the desired function. Working with variables is carried out in a dedicated area for this. To keep it, I use "SetProp", because from "WindowProc" I can identify something only through "hWnd". If you need to add any global variables, it is possible in this field to allocate space for the string, etc. (for example to call "LoadLibrary" with the required parameter). If in VB was to work directly with pointers (without VarPtr, GetMem functions, etc.), it was much easier. You can do once the assembly adapter and it is possible to learn the values of variables passed to the stream without "SetProp" and "CopyMemory", but it's the details, who wants to - he did.
Everything works only in a compiled (native) form.

[VB6] Scroller - DataRepeater alternative

$
0
0
If the stock DataRepeater control works well for you that's just great. But sometimes it can be awkward to work with because of its use of data binding and the need for a separate OCX containing the "scrolled" control.

Refresher:

Quote:

The DataRepeater control functions as a scrollable container of data-bound user controls. Each control appears in its own row as a "repeated" control, allowing the user to view several data-bound user controls at once.

Scroller

Scroller, as presented here, is not a finished drop-in component but a technique that can be used as an alternative to the MSDatRep.ocx plus one or more additional custom "scrolled control" OCXs. Unlike the DataRepeater control, the Scroller technique shown here even allows scrolled items to vary in height.

Note that this demo only explores a repeated control that presents static information, i.e. it has no data entry controls. This simplifies the demo though you could certainly extend the concept to do so.

Instead of normal data binding, Scroller was built using a "virtual view" approach. As the user scrolls the Scroller control a callback event is raised to fetch data to be "painted" into the scrolled view. So you will still need access to the entire set of data, though it could be held in a database, a Recordset, or Collections and arrays as done in the demo.

If you added data entry/edit controls to your scrolled control you might want to add a second callback to feed changes back to the parent Form for storage.


Scroller Demo

The demo uses a set of Twitter™-like messages based on quotes and images from the movie Office Space, just to make it a little more entertaining.


Name:  sshot1.png
Views: 82
Size:  15.0 KB


While this demo doesn't do data entry, it does accept mouse clicks. A click on an item brings up a secondary window with more detail than may have fit in the scrollable view, e.g.:


Name:  sshot2.png
Views: 52
Size:  19.0 KB


This is obviously a stripped down bare example, but I hope you find uses for it. I'm not sure most programmers are even aware of the DataRepeater, and fewer still have bothered dealing with its quirks. Maybe this simplified approach will offer inspiration.

The trickiest part of this demo is the dynamic vertical sizing that tracks autosize Label controls. If you stripped that out there isn't a whole lot here.

The data and images are included. The data is in a delimited text format next to the JPEG images used here.
Attached Images
  
Attached Files

Enumerate Schannel Cipher Suites

$
0
0
Learning from our experience with BCryptEnumAlgorithms, we can enumerate the Cipher Suites supported by Schannel our system (43 on my system).

J.A. Coutts

Code:

Option Explicit
'================================
'EVENTS
'================================
Public Event Error(ByVal Number As Long, Description As String, ByVal Source As String)

Private Const MS_SCHANNEL_PROVIDER As String = "Microsoft SSL Protocol Provider"

Private Const NCRYPT_SSL_MAX_NAME_SIZE As Long = 64
Private Type NCRYPT_SSL_CIPHER_SUITE
    dwProtocol As Long
    dwCipherSuite As Long
    dwBaseCipherSuite As Long
    szCipherSuite(NCRYPT_SSL_MAX_NAME_SIZE) As Byte
    szCipher(NCRYPT_SSL_MAX_NAME_SIZE) As Byte
    dwCipherLen As Long
    dwCipherBlockLen As Long  'in bytes
    szHash(NCRYPT_SSL_MAX_NAME_SIZE) As Byte
    dwHashLen As Long
    szExchange(NCRYPT_SSL_MAX_NAME_SIZE) As Byte
    dwMinExchangeLen As Long
    dwMaxExchangeLen As Long
    szCertificate(NCRYPT_SSL_MAX_NAME_SIZE) As Byte
    dwKeyType As Long
End Type

'CNG API Declares
Private Declare Function SslOpenProvider Lib "ncrypt.dll" (ByRef hSslProvider As Long, ByVal pszProviderName As Long, ByVal dwFlags As Long) As Long
Private Declare Function SslFreeObject Lib "ncrypt.dll" (ByVal hObject As Long, ByVal dwFlags As Long) As Long
Private Declare Function SslEnumCipherSuites Lib "ncrypt.dll" (ByVal hSslProvider As Long, ByVal hPrivateKey As Long, ByRef ppCipherSuite As Long, ByRef ppEnumState As Long, ByVal dwFlags As Long) As Long
Private Declare Function SslFreeBuffer Lib "ncrypt.dll" (ByVal pvBuffer As Long) As Long

'API memory functions
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function lstrcpyn Lib "kernel32" Alias "lstrcpynW" (ByVal lpStringDest As Long, ByVal lpStringSource As Long, ByVal iMaxLength As Long) As Long

'Constants for Cryptography API error messages
Private Const SOP As String = "SslOpenProvider"
Private Const SECS As String = "SslEnumCipherSuites"

Public Function Test1() As Boolean
    Const Routine As String = "clsSSL.Test1"
    Dim hSslProvider As Long
    Dim ppCipherSuite As Long 'NCRYPT_SSL_CIPHER_SUITE
    Dim ppEnumState As Long
    Dim lRet As Long
    Dim NameLen As Long
    Dim CipherName As String
    Dim N%
    lRet = SslOpenProvider(hSslProvider, StrPtr(MS_SCHANNEL_PROVIDER), 0)
    If lRet <> 0 Then
        RaiseEvent Error(lRet, SOP, Routine)
        GoTo ReleaseHandles
    End If
    While SslEnumCipherSuites(hSslProvider, 0&, ppCipherSuite, ppEnumState, 0) = 0
        NameLen = lstrlen(ppCipherSuite + 12)
        CipherName = Space$(NameLen)
        lstrcpyn StrPtr(CipherName), ppCipherSuite + 12, NameLen + 1
        Debug.Print CipherName
    Wend
ReleaseHandles:
    SslFreeBuffer ppCipherSuite
    SslFreeObject hSslProvider, 0
End Function

VB6 Handling of PNG-Sprites in a Game-like Scenario

$
0
0
Well, this small Demo shows, how to properly handle a Sprite-based "Game-Scenario"
(using a 64x64 tiled Map of "plain-Grass") - as well as a few other "static Sprites"
(as unmoving Trees, and two unmoving, but animated "Coins") - as well as four moving
(and animated) "Person-Sprites".

There's no vbRichClient5-Reference needed for this Demo - instead the transparent
(Alpha)Sprite-Rendering is ensured with a small Helper-Class cPngCacheGDIP,
which supports Alpha-Pngs, but also all kind of other Image-Resources.
I'd say, it's quite easy to either make or find nice PNG-Images for your Sprites...,
and thus good old "masked Bitmap-Handling" is "banned for good" here. ;)

The Demo handles the Sprites in 2 small and simple Classes (no Picture- or Image-Controls are needed)
and shows, how to use a normal VB-PictureBox as the Game-Canvas in Double-Buffered-Mode properly.
So there's no flickering, since any Sprites are rendered onto the (AutoRedraw-)BackBuffer,
before the Buffer is flipped back onto the Screen per PicCanvas.Refresh.

The "Game-Loop" is ensured over a fast ticking Timer here (for simplicitys sake) - and
refreshes the Screen with a new Scene (constantly redrawing 95 Sprites) any 15msec or so
(that's roughly 60Hz) - and it causes only 0.3% CPU-Load whilst doing so, because the
Systems AlphaBlend-Call is done in Hardware on most Systems these days.

The CodeBase is really quite small ...
When we leave out the unchanging Helper-Class cPngCacheGDIP, we have only:

modMain.bas
Code:

Option Explicit

Public PngCache As New cPngCacheGDIP 'let's declare it here for global usage
 
Sub Main()
  'add true Alpha-Channel-Png-resources (once, at App-Startup)
  PngCache.AddImage "Grass", App.Path & "\Res\Grass.jpg"
  PngCache.AddImage "Tree", App.Path & "\Res\Tree.png"
  PngCache.AddImage "AnimCoin", App.Path & "\Res\AnimCoin.png"
  PngCache.AddImage "Person", App.Path & "\Res\Person.png"

  fTest.Show 'load and show the Main-Form
End Sub

cSprites.cls (which aggregates the Sprites in a Collection and offers an Add-method)
Code:

Option Explicit

Public Col As New Collection

Public Sub AddAndInit(Sprite As cSprite, Key, ImgKey, x, y, Optional aShiftX, Optional aShiftY)
  Sprite.Key = Key
  Sprite.ImgKey = ImgKey
  Sprite.dX = PngCache.Width(ImgKey)
  Sprite.dY = PngCache.Height(ImgKey)
  Sprite.x = x
  Sprite.y = y
  If Not IsMissing(aShiftX) Then Sprite.aShiftX = aShiftX
  If Not IsMissing(aShiftY) Then Sprite.aShiftY = aShiftY
 
  Col.Add Sprite, Key
End Sub

cSprite.cls (which offers StateProperties for a single Sprite-Instance and Draw- and Animate-Methods)
Code:

Option Explicit
 
Public Key, ImgKey, x, y, dX, dY 'standard Properties
Public aShiftX, aShiftY, aX, aY  'additional Props for (optional) animation
 
Public Sub Draw(ByVal hDC As Long)
  PngCache.AlphaRenderTo hDC, ImgKey, x, y, IIf(aShiftX, aShiftX, dX), IIf(aShiftY, aShiftY, dY), aX, aY
End Sub

Public Sub MoveRel(xRel, yRel)
  x = x + xRel
  y = y + yRel
End Sub

Public Sub Animate()
  aX = aX + aShiftX: If aX >= dX - 1 Then aX = 0
  aY = aY + aShiftY: If aY >= dY - 1 Then aY = 0
End Sub

And finally the Form-Code, which ensures the Loading and animated rendering of the Sprites:
Code:

Option Explicit 'shows, how to make use of the two small Classes: cSprites and cSprite

Private x, y, Statics As New cSprites, Movers As New cSprites, Sprite As cSprite

Private Sub Form_Load()
  'add a static BackGround-Image onto our Canvas
  Set picCanvas.Picture = LoadPicture(App.Path & "\Res\Checker.jpg")
 
  'add the "Map"-Content (grass only in this demo)
  For y = 0 To 480 Step 64: For x = 0 To 640 Step 64
    Statics.AddAndInit New cSprite, "Grass_" & x & "_" & y, "Grass", x, y
  Next x, y
  Statics.Col.Remove "Grass_0_0" 'just to show, that "removing by key" works of course
  Statics.Col.Remove "Grass_128_128" 'and another one (leaving the BackGround-Image shine through)
 
  'add a few more static Sprites into the same (static) Collection as the Map-Content above
  Statics.AddAndInit New cSprite, "Tree1", "Tree", 40, 40
  Statics.AddAndInit New cSprite, "Tree2", "Tree", 300, 200
  Statics.AddAndInit New cSprite, "Tree3", "Tree", 540, 320
  Statics.AddAndInit New cSprite, "AnimCoin1", "AnimCoin", 580, 80, 44
  Statics.AddAndInit New cSprite, "AnimCoin2", "AnimCoin", 60, 420, 44
 
  'now the "PlayerSprites" which are to be moved (we add them to the Movers-Collection)
  Movers.AddAndInit New cSprite, "Person1", "Person", 120, 120, 45
  Movers.AddAndInit New cSprite, "Person2", "Person", 500, 120, 45
  Movers.AddAndInit New cSprite, "Person3", "Person", 500, 320, 45
  Movers.AddAndInit New cSprite, "Person4", "Person", 120, 320, 45
 
  Caption = Statics.Col.Count + Movers.Col.Count & " Sprites handled in a 60Hz-Refresh-Loop"
End Sub
 
Private Sub Redraw() 'our central scene-drawing-routine
  picCanvas.Cls 'clear anything on the backbuffer (leaving only the background-picture)
    DrawAllSpritesIn Statics 'all statics first
    DrawAllSpritesIn Movers 'movers are drawn on top of statics
  picCanvas.Refresh 'flip the DoubleBuffer to the Screen
End Sub

Private Sub DrawAllSpritesIn(Sprites As cSprites)
  For Each Sprite In Sprites.Col
    Sprite.Draw picCanvas.hDC
  Next
End Sub
 
Private Sub tmrRefresh_Timer() 'we handle the Sprites-State in a timer
Static Cnt&: Cnt = (Cnt + 1) Mod 72
Static Fac&: If Cnt = 0 Then Fac = IIf(Fac, -Fac, 1)
 
  For Each Sprite In Statics.Col
    Select Case Sprite.Key
      Case "AnimCoin1", "AnimCoin2": If Cnt Mod 4 = 0 Then Sprite.Animate
    End Select
  Next
 
  For Each Sprite In Movers.Col
    Select Case Sprite.Key
      Case "Person1": Sprite.MoveRel 1 * Fac, 1 * Fac
      Case "Person2": Sprite.MoveRel -1 * Fac, 1 * Fac
      Case "Person3": Sprite.MoveRel -1 * Fac, -1 * Fac
      Case "Person4": Sprite.MoveRel 1 * Fac, -1 * Fac
    End Select
    If Cnt Mod 3 = 0 Then Sprite.Animate
  Next
 
  Redraw
End Sub

Here's a ScreenShot:




And here the Zip-Archive for the Project:
PngSprites.zip

Have fun,

Olaf
Attached Files

VB6 fast MJPG-Stream-Decoding from (http-streamed) WebCams - vbRichClient5

$
0
0
Ok, the title is mentioning it already - this Demo is related to the decoding
of "true WebCam-streams" (not to the Cams, which hang on your USB-port),
and those Internet-Cams are usually directly accessible per Browser over http -
and then (most) often pump their stream continously, using: mime=multipart/x-mixed-replace
on a (Keep-Alive) http-Connection.

The Demo shows, how to capture such streams in a decent performance
without using a Browser-Client ... as e.g. FireFox, which has no problem with
e.g. this URL here in Helsinki (Finland): http://77.72.56.163/mjpg/video.mjpg

Important in such a scenario is a fast (M)JPEG-Decoder - and vbRichClient5 contains
a quite speedy one (based on libJPGTurbo), which works about factor 2-3 faster than
what's available on Windows per default (e.g. when decoding per WIA or GDI+).

So, to avoid using a Browser-Client (and the default-JPG-Decoder which comes with
the Browser-API), we would also need our own socket-handling for the http-GET-
request, and in this case we use cTCPClient (also from RC5) for this part.

What's also shown is, how to configure a CommandString for the quite wellknown
VLC-MediaPlayer, which supports different Streaming-Modes - and to be compatible
with true WebCam-Streaming, we have to force VLC into "multipart/x-mixed-replace"-
mode as well.

This is done in the Demo-Code in Sub Main() - and I've split the different parts
of the VLC-CommandString into easier to understand snippets, as shown below:

complete content of modMain.bas (the important parts, which ensure WebCam-compatible http-streaming are in Magenta)
Code:

Option Explicit
 
Sub Main() 'just a short demonstration, how to build a proper VLC-http-MJPG-CommandString
  Dim FilePath$:  FilePath = "C:\Tests\Test.mp4"
  Dim VLCPath$:    VLCPath = "C:\Program Files (x86)\VideoLAN\VLC\vlc.exe"
  Dim transcode$:  transcode = "vcodec=MJPG,vb=5600,scale=Automatic,acodec=none"
  Dim http$:      http = "mime=multipart/x-mixed-replace;boundary=--7b3cc56e5f"
  Dim dst$:        dst = "127.0.0.1:8080/"
 
  If MsgBox("Shall I start a VLC-Instance for: " & FilePath & "?", vbYesNo) = vbYes Then
    Shell VLCPath & " " & FilePath & " " & BuildStreamSettingsVLC(transcode, http, dst)
  End If
 
  fWebCam.Show
End Sub

Public Function BuildStreamSettingsVLC(transcode As String, http As String, dst As String) As String
  Const VLCBaseSettings$ = ":sout=#transcode{@1}:standard{access=http{@2},mux=mpjpeg,dst=@3}"
  BuildStreamSettingsVLC = Replace(Replace(Replace(VLCBaseSettings, "@1", transcode), "@2", http), "@3", dst)
End Function

So, the above code asks any time the Demo is started, if you want to Shell an appropriate
Instance of the VLC-Player (in Stream-Mode) - in case you find that unnerving, just comment
out the appropriate Lines in Sub Main().

The achieved performance is quite good - also because the final (stretched) rendering happens
over a Cairo-DirectX-uploaded Surface (which performs the final stretch to the picVid-PictureBox
in Hardware)...

The CPU-Load is only around 1% whilst receiving+JPGDecoding+StretchedRendering takes place
with about 24-25FPS receiving streamed VideoFrames from a 1280x696 VLC-transcoded Video.
(the VLC-Player which has to perform a transcoding from MP4 to MJPG in this case, has a bit
more Stress - and thus needs about 4-5% of the CPU - but it runs in a different process and
doesn't affect the VB6-App whilst doing so...

Here's a ScreenShot, which shows the whole thing in action:


And here's the Download-Link for the Demo-Zip:
WebCamRC5.zip

Olaf
Attached Files

[VB6] Code Snippet: Converting an hIcon to an hBitmap

$
0
0
So this isn't a full on project (although it will be part of an upcoming one), just some code- doing this conversion in VB turned out to be very difficult for someone unfamiliar with graphics APIs. Found tons of other people having the same question with mostly incomplete answers, and I couldn't find anywhere showing it done in VB.. spent hours figuring it out from other codes, which turned the issue into something far more complicated than the ultimate solution I found turned out to be.

The use case this was developed as a response to was to be able to use take hIcon's extracted from files and be able to use them as a value for MENUITEMINFO.hbmpItem.
Code:


'Declares
Private Type BITMAPINFOHEADER
  biSize                  As Long
  biWidth                  As Long
  biHeight                As Long
  biPlanes                As Integer
  biBitCount              As Integer
  biCompression            As Long
  biSizeImage              As Long
  biXPelsPerMeter          As Long
  biYPelsPerMeter          As Long
  biClrUsed                As Long
  biClrImportant          As Long
End Type

Private Type BITMAPINFO
  bmiHeader                As BITMAPINFOHEADER
  bmiColors(3)            As Byte
End Type

Private Const DIB_RGB_COLORS = 0&
Private Const DI_NORMAL = 3&

Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByRef lplpVoid As Any, ByVal Handle As Long, ByVal dw As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal XLeft As Long, ByVal YTop As Long, ByVal hIcon As Long, ByVal CXWidth As Long, ByVal CYWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long

'Functions
Public Function HBitmapFromHIcon(hIcon As Long, cx As Long, cy As Long) As Long
        Dim hdc As Long
        Dim hBackDC As Long
        Dim hBitmap As Long
        Dim hBackSV As Long

        hdc = GetDC(0)
        hBackDC = CreateCompatibleDC(hdc)
        hBitmap = Create32BitHBITMAP(hBackDC, cx, cy)
       
        hBackSV = SelectObject(hBackDC, hBitmap)
        DrawIconEx hBackDC, 0, 0, hIcon, cx, cy, 0, 0, DI_NORMAL
       
        Call SelectObject(hBackDC, hBackSV)
        Call ReleaseDC(0, hdc)
        Call DeleteDC(hBackDC)
HBitmapFromHIcon = hBitmap
End Function
Public Function Create32BitHBITMAP(hdc As Long, cx As Long, cy As Long) As Long
Dim bmi As BITMAPINFO
Dim hdcUsed As Long
    bmi.bmiHeader.biSize = Len(bmi.bmiHeader)
    bmi.bmiHeader.biPlanes = 1
    bmi.bmiHeader.biCompression = 0

    bmi.bmiHeader.biWidth = cx
    bmi.bmiHeader.biHeight = cy
    bmi.bmiHeader.biBitCount = 32
    Create32BitHBITMAP = CreateDIBSection(hdc, bmi, DIB_RGB_COLORS, ByVal 0&, 0, 0)
   
End Function

The initial hIcon can be from any source that has that type returned; e.g. ExtractIcon[Ex], LoadImage, etc.

EDIT - KNOWN ISSUES
**The above code only works for 24-bit icons with an alpha channel.**
For 24-bit icons without an alpha channel, and icons with 256 or fewer colors:
Code:

Public Function HBitmapFromHIconNoAlpha(hIcon As Long) As Long
Dim himg As Long
Dim hb As Long
GdipCreateBitmapFromHICON hIcon, himg
GdipCreateHBITMAPFromBitmap himg, hb, &HFF000000
GdipDisposeImage himg
HBitmapFromHIconNoAlpha = hb
End Function

(note that this requires gdiplus to be initialized, so use the entire module below which includes it)

This of course requires knowing which one to use, I'm working on one without GDIPlus, in the mean time there's this one from Leandro Ascierto's clsMenuImage:
Code:

Option Explicit
'If you are using this don't just copy the main function, note the startup and shutdown of gdiplus
Public gInitToken As Long
Private Const PixelFormat32bppRGB  As Long = &H22009
Private Type GdiplusStartupInput
    GdiplusVersion          As Long
    DebugEventCallback      As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs  As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type ARGB
    Blue            As Byte
    Green          As Byte
    Red            As Byte
    Alpha          As Byte
End Type
Private Type BitmapData
    Width          As Long
    Height          As Long
    Stride          As Long
    PixelFormat    As Long
    Scan0          As Long
    Reserved        As Long
End Type
Private Enum ImageLockMode
    ImageLockModeRead = &H1
    ImageLockModeWrite = &H2
    ImageLockModeUserInputBuf = &H4
End Enum
Private Declare Function GdiplusStartup Lib "GdiPlus.dll" (Token As Long, gdipInput As GdiplusStartupInput, GdiplusStartupOutput As Long) As Long
Private Declare Sub GdiplusShutdown Lib "GdiPlus.dll" (ByVal Token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus.dll" (ByVal hBmp As Long, ByVal hPal As Long, GpBitmap As Long) As Long
Private Declare Function GdipGetImagePixelFormat Lib "GDIplus" (ByVal Image As Long, ByRef PixelFormat As Long) As Long
Private Declare Function GdipGetImageDimension Lib "GDIplus" (ByVal Image As Long, ByRef Width As Single, ByRef Height As Single) As Long
Private Declare Function GdipBitmapLockBits Lib "GDIplus" (ByVal BITMAP As Long, ByRef RECT As RECT, ByVal Flags As ImageLockMode, ByVal PixelFormat As Long, ByRef LockedBitmapData As BitmapData) As Long
Private Declare Function GdipBitmapUnlockBits Lib "GDIplus" (ByVal BITMAP As Long, ByRef LockedBitmapData As BitmapData) As Long
Private Declare Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal Image As Long) As Long

Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long


Public Sub InitGDIP()
    Static Token    As Long
    If Token = 0 Then
        Dim gdipInit As GdiplusStartupInput
        gdipInit.GdiplusVersion = 1
        GdiplusStartup Token, gdipInit, ByVal 0&
        gInitToken = Token
    End If
End Sub

Public Function pvIsAlphaIcon(ByVal IconHandle As Long) As Boolean

    Dim tARGB() As ARGB
    Dim tRECT As RECT
    Dim tICONINFO As ICONINFO
    Dim tBitmapData As BitmapData
    Dim lPixelFormat As Long
    Dim lngX As Long
    Dim lngY As Long
    Dim sngWidth As Single
    Dim sngHeight As Single
    Dim lngArgbBmp As Long
    Dim lngColorBmp As Long
    Dim bolRet As Boolean
    Dim hr As Long
   
On Error GoTo e0
If gInitToken = 0 Then InitGDIP
hr = GetIconInfo(IconHandle, tICONINFO)
If hr <> 0 Then
    If tICONINFO.hBMColor <> 0 Then
        If GdipCreateBitmapFromHBITMAP(tICONINFO.hBMColor, 0&, lngColorBmp) = 0 Then
            If GdipGetImagePixelFormat(lngColorBmp, lPixelFormat) = 0 Then
                If lPixelFormat <> PixelFormat32bppRGB Then
                    bolRet = False
                Else
                    If GdipGetImageDimension(lngColorBmp, sngWidth, sngHeight) = 0 Then
                        With tRECT
                            .Right = CLng(sngWidth)
                            .Bottom = CLng(sngHeight)
                        End With
                        ReDim tARGB(tRECT.Right - 1&, tRECT.Bottom - 1&)
                        With tBitmapData
                            .Scan0 = VarPtr(tARGB(0&, 0&))
                            .Stride = 4& * tRECT.Right
                        End With
                        If GdipBitmapLockBits(lngColorBmp, tRECT, ImageLockModeRead Or ImageLockModeUserInputBuf, lPixelFormat, tBitmapData) = 0 Then
                            For lngY = 0 To tBitmapData.Height - 1
                                For lngX = 0 To tBitmapData.Width - 1
                                    If tARGB(lngX, lngY).Alpha > 0 Then
                                        If tARGB(lngX, lngY).Alpha < 255 Then
                                            bolRet = True
                                            Exit For
                                        End If
                                    End If
                                Next lngX
                                If bolRet Then Exit For
                            Next lngY
                            Call GdipDisposeImage(lngArgbBmp)
                            Call GdipBitmapUnlockBits(lngColorBmp, tBitmapData)
                        End If
                    End If
                End If
            End If
            Call GdipDisposeImage(lngColorBmp)
        End If
        Call DeleteObject(tICONINFO.hBMColor)
    End If
    Call DeleteObject(tICONINFO.hBMMask)
Else
    bolRet = False
End If
pvIsAlphaIcon = bolRet
ReleaseGDIP
On Error GoTo 0
Exit Function

e0:
Debug.Print "modGDIP.pvIsAlphaIcon.Error->" & Err.Description & " (" & Err.Number & ")"
   
End Function
Public Function HBitmapFromHIconNoAlpha(hIcon As Long) As Long
Dim himg As Long
Dim hb As Long
GdipCreateBitmapFromHICON hIcon, himg
GdipCreateHBITMAPFromBitmap himg, hb, &HFF000000
GdipDisposeImage himg
HBitmapFromHIconNoAlpha = hb
End Function
Public Sub ReleaseGDIP()
GdiplusShutdown gInitToken
End Sub

[VB6] List/Execute File Handlers: IAssocHandler and IAssocHandlerInvoker (Vista+)

$
0
0
Association Handlers Demo

IAssocHandler | IEnumAssocHandlers | IAssocHandlerInvoker

Windows Vista and above provider a shell interface to get a list of all handlers registered to open a particular file type that also returns where the icon is and what the friendly name is. Most importantly, it provider an interface to invoke that handler in a much better way than trying to make a command to launch it.

These things were just crying out to be made into an example of how to replicate the Open With menu in VB. There's even two groups: the recommended ones that show up on that menu in Explorer, or if so inclined you could list all the ones that appear on the actual Open With dialog.

Requirements
The project uses the newest version of oleexp.tlb, my Modern Interfaces Type Library project, which is a large expansion of the original olelib. The latest versions of both of those must be referenced, see the link for more details.

Ambition is also a bit of a requirement... using the invoker (which you don't have to) involves getting deep into IShellFolder and pidls, and there's a lot of supporting code.

Basic Outline

SHAssocEnumHandlers is called to get an object that can enumerate all the handlers for the extension passed- IEnumAssocHandlers.
That object lists IAssocHandler interfaces for each handler, and in the demo project we use the information provided by that to list them on a menu.
When one is chosen, the handlers are cycled through again to find the desired one to launch- it's here that we need some complex stuff like IShellFolder and IDataObject.


Main Code
Code:

Dim sFile As String
Dim sExt As String
Dim nIcoIdx As Long
Dim MII() As MENUITEMINFO
Dim miiZ As MENUITEMINFO

Dim uRec() As AssocInfo
Dim i As Long, j As Long, k As Long
Dim ieah As IEnumAssocHandlers
Dim iah As IAssocHandler
Dim hr As Long
Dim lPtr As Long
Dim sApp As String
Dim sIcon As String
Dim hIcon As Long
Dim hBmp As Long
Dim PT As POINTAPI
Dim idCmd As Long
Dim hMenu As Long

Const widBase As Long = 1000
Const sCP As String = "Choose program..."

j = -1
ReDim MII(0)
ReDim uRec(0)

sFile = Text1.Text
sExt = Right(sFile, Len(sFile) - InStrRev(sFile, ".") + 1)

'First, we use an API call to get the object that will list the handlers
'The other flag value will show all handlers- the recommended ones are the
'ones that show up in Explorer's right click open-with menu

hr = SHAssocEnumHandlers(StrPtr(sExt), ASSOC_FILTER_RECOMMENDED, ieah)
If hr <> S_OK Then Exit Sub

'now we're ready to start enumerating the handlers, in this project
'we're going to load them into a popup menu
hMenu = CreatePopupMenu()

'Most IEnum______ classes work exactly like this. .Next fills the IAssocHandler iface
Do While (ieah.Next(1, iah, 0) = 0)
    If (iah Is Nothing) = False Then
        j = j + 1
        ReDim Preserve MII(j)
        ReDim Preserve uRec(j) 'in case we need the info later
       
        Call iah.GetUIName(lPtr) 'can't receive a LPWSTR As String like sending it
        sApp = BStrFromLPWStr(lPtr)
        uRec(j).sUIName = sApp
        Call iah.GetName(lPtr)
        sApp = BStrFromLPWStr(lPtr)
        uRec(j).sPath = sApp
        Call iah.GetIconLocation(lPtr, i)
        sIcon = BStrFromLPWStr(lPtr)
        uRec(j).sIcon = sIcon
        uRec(j).nIcon = i
       
        'association interface includes icon info for our menu
        Call ExtractIconEx(sIcon, i, ByVal 0&, hIcon, 1)
        hBmp = HBitmapFromHIcon(hIcon, 16, 16) 'can't use hIcon directly
       
        With MII(j)
            .cbSize = Len(MII(j))
            .fMask = MIIM_ID Or MIIM_STRING Or MIIM_BITMAP
            .wID = widBase + j
            .cch = Len(uRec(j).sUIName)
            .dwTypeData = uRec(j).sUIName
            .hbmpItem = hBmp
           
            Call InsertMenuItem(hMenu, j, True, MII(j))
           
        Call DestroyIcon(hIcon)
        End With
             
    Else
        Debug.Print "iah=Nothing"
    End If
    Set iah = Nothing
Loop

'Add separator and open with other
miiZ.cbSize = Len(miiZ)
miiZ.fMask = MIIM_ID Or MIIM_TYPE
miiZ.fType = MFT_SEPARATOR
miiZ.wID = 9999
Call InsertMenuItem(hMenu, -1, False, miiZ)

miiZ.fMask = MIIM_ID Or MIIM_STRING
miiZ.wID = 3000
miiZ.cch = Len(sCP)
miiZ.dwTypeData = sCP
Call InsertMenuItem(hMenu, -1, False, miiZ)

Call GetCursorPos(PT)
PT.y = PT.y + 5

idCmd = TrackPopupMenu(hMenu, TPM_LEFTBUTTON Or TPM_RIGHTBUTTON Or TPM_LEFTALIGN Or TPM_TOPALIGN Or TPM_HORIZONTAL Or TPM_RETURNCMD, PT.x, PT.y, 0, Me.hWnd, 0)

Set ieah = Nothing

If idCmd Then
    If idCmd = 3000 Then
        OpenWith Text1.Text, OAIF_ALLOW_REGISTRATION Or OAIF_EXEC, Me.hWnd
    Else
       
        k = idCmd - widBase
    '    MsgBox "Handler selected: " & uRec(k).sUIName & vbCrLf & _
    '            uRec(k).sPath & vbCrLf & _
    '            "Icon=" & uRec(k).sIcon & "," & uRec(k).nIcon, _
    '            vbOKOnly, App.Title
    '
        'i know.. pidl and ishellfolder stuff is confusing, but there's no other way
        Dim isf As IShellFolder
        Dim pidl As Long, pidlFQ As Long
        Dim zc As Long
        pidlFQ = PathToPidl(sFile)
        pidl = GetPIDLParent(pidlFQ)
        Set isf = GetIShellFolder(isfDesktop, pidl)
        Dim pidlChild As Long
        pidlChild = GetItemID(pidlFQ, GIID_LAST)
       
        'Now that we have the pidl and shellfolder representing our file, we create
        'an IDataObject for it, then re-enumerate the handlers- we still have the
        'selected one stored in k. it may be possible to just have an array to avoid
        'the reenumeration
        Dim ido As olelib.IDataObject
        Call isf.GetUIObjectOf(0, 1, pidlChild, IID_IDataObject, 0, ido)
        Dim invk As IAssocHandlerInvoker
        hr = SHAssocEnumHandlers(StrPtr(sExt), ASSOC_FILTER_RECOMMENDED, ieah)
        Do While (ieah.Next(1, iah, 0) = 0)
            If (iah Is Nothing) = False Then
                If zc = k Then
                    'theoretically, we could take the path to the executable and
                    'run a launch command, but the actual invoke interfacer is a
                    'far better choice
                    Call iah.CreateInvoker(ido, invk)
                    invk.Invoke
                    Exit Do
                Else
                    zc = zc + 1
                End If
            End If
            Set iah = Nothing
        Loop
    End If
End If
 
If pidlFQ Then CoTaskMemFree pidlFQ
If pidl Then CoTaskMemFree pidl
If pidlChild Then CoTaskMemFree pidlChild

Set ido = Nothing
Set isf = Nothing
Set invk = Nothing
Set iah = Nothing
Set ieah = Nothing

End Sub


Included in ZIP
-All the core and supporting code required to generate a menu like that in the picture.
-The latest versions of oleexp.tlb and olelib.tlb (v1.5 and v1.91 respectively; this version or better is required). TLB files only, for full source visit the main oleexp project thread.

Future Goals
This is the very first release, and I do plan on trying to simplify things a bit as well as test out Unicode support. Please report any and all bugs so they can be fixed in the next version.
Attached Files
Viewing all 1540 articles
Browse latest View live


<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>