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

[VB6] Registry Hives Enumerator

$
0
0
This is very specific, but maybe will be useful for some registry guy :)

In short:

if you need to build a ton of nested loops for:

just say, you have a task to enumerate:

1) several keys
2) in the same location of HKLM / HKCU / HKU + every SID
3) separately consider WOW6432Node (read value with KEY_WOW64_64KEY flag and without) + exclude one of 'shared' keys (keys that point to the same phisical location in both 64/32-bit modes).

you can fit all in 1 single cycle with this 'Hives Enumerator' class.

Example:

Here is your old code:
Code:


    sRegRuns(1) = "Software\Microsoft\Windows\CurrentVersion\Run"
    sDes(1) = "Run"

    sRegRuns(2) = "Software\Microsoft\Windows\CurrentVersion\RunServices"
    sDes(2) = "RunServices"

        '...

    For i = 0 To UBound(aHives) 'HKLM, HKCU, HKU()

        For Each UseWow In Array(False, True)

            If (bIsWin32 And UseWow) _
              Or bIsWin64 And UseWow And _
              (sHive = "HKCU" _
              Or StrBeginWith(sHive, "HKU\")) Then Exit For

            For K = LBound(sRegRuns) To UBound(sRegRuns)

Here is how it looks now with my class:

Code:


    Dim HE as clsHiveEnum
    Set HE = New clsHiveEnum
    '...

    sRegRuns(1) = "Software\Microsoft\Windows\CurrentVersion\Run"
    sDes(1) = "Run"

    sRegRuns(2) = "Software\Microsoft\Windows\CurrentVersion\RunServices"
    sDes(2) = "RunServices"

    '...

    HE.Init HE_HIVE_ALL, HE_SID_ALL, HE_REDIR_BOTH
    HE.AddKeys sRegRuns

    Do While HE.MoveNext

        'that's all :) Just use HE.Hive, HE.Key, HE.Redirected and many more...
    Loop

Or you can enum hives without keys. Just don't use HE.AddKeys.

Required:
Some enums to Global module: just to support quick IntelliSense tips.

Dependencies:
modRegVirtualType.bas (included)

Good luck :)
-----------------


Live example (attached as demo):

Code:


    Dim HE As clsHiveEnum
    Set HE = New clsHiveEnum

    Dim aKey(1) As String

    aKey(0) = "HKLM\Software\Classes\AppID"
    aKey(1) = "Software\Classes\CLSID"

    HE.Init HE_HIVE_HKLM Or HE_HIVE_HKU, HE_SID_ALL, HE_REDIR_BOTH

    HE.AddKeys aKey

    Do While HE.MoveNext
        Debug.Print " --------- "
        Debug.Print "Hive handle: " & HE.Hive
        Debug.Print "Hive name:  " & HE.HiveName
        Debug.Print "Hive + key:  " & HE.KeyAndHive
        Debug.Print "Key:        " & HE.Key
        Debug.Print "Redirected:  " & HE.Redirected
        Debug.Print "Array index: " & HE.KeyIndex
        Debug.Print "User name:  " & HE.UserName
    Loop

    Set HE = Nothing

Result:
Quote:

---------
Hive handle: -2147483646
Hive name: HKLM
Hive + key: HKLM\Software\Classes\AppID
Key: Software\Classes\AppID
Redirected: False
Array index: 0
User name: All users
---------
Hive handle: -2147483646
Hive name: HKLM
Hive + key: HKLM\Software\Classes\CLSID
Key: Software\Classes\CLSID
Redirected: True
Array index: 1
User name: All users
---------
Hive handle: -2147483646
Hive name: HKLM
Hive + key: HKLM\Software\Classes\CLSID
Key: Software\Classes\CLSID
Redirected: False
Array index: 1
User name: All users
---------
Hive handle: -2147483645
Hive name: HKU
Hive + key: HKU\.DEFAULT\Software\Classes\CLSID
Key: .DEFAULT\Software\Classes\CLSID
Redirected: False
Array index: 1
User name: Default user
---------
Hive handle: -2147483645
Hive name: HKU
Hive + key: HKU\S-1-5-19\Software\Classes\CLSID
Key: S-1-5-19\Software\Classes\CLSID
Redirected: True
Array index: 1
User name: Local service
---------
Hive handle: -2147483645
Hive name: HKU
Hive + key: HKU\S-1-5-19\Software\Classes\CLSID
Key: S-1-5-19\Software\Classes\CLSID
Redirected: False
Array index: 1
User name: Local service
---------
Hive handle: -2147483645
Hive name: HKU
Hive + key: HKU\S-1-5-20\Software\Classes\CLSID
Key: S-1-5-20\Software\Classes\CLSID
Redirected: True
Array index: 1
User name: Network service
---------
Hive handle: -2147483645
Hive name: HKU
Hive + key: HKU\S-1-5-20\Software\Classes\CLSID
Key: S-1-5-20\Software\Classes\CLSID
Redirected: False
Array index: 1
User name: Network service
Above, we requested:
1) for HE_HIVE_HKLM + HE_HIVE_HKU hives.
2) aKey(0) have exception: list HKLM only (see prefix "HKLM\...")
3) HE_SID_ALL
4) WOW + no WOW

We got:
1) only 1 iteration of aKey(0) -> HKLM\Software\Classes\AppID, because it is 'Shared' key. WOW mode is point to the same phisical location, so WOW iteration is skipped.
2) 2 iteration of aKey(1) of HKLM. 1 - WOW, 2 - No WOW.
3) 5 iterations of aKey(1) of HKU. 1 - .Default SID, 2 - S-1-5-19, 3 - S-1-5-20, where:
- HKU\.Default\Software\Classes\CLSID is not 'redirected' key, that's why only 1 iteration
- S-1-5-19 and S-1-5-20 ARE 'redirected' keys, that's why +2 iterations for each (WOW, no WOW)

Note: that class doesn't check and skip keys that are not exist (it is responsibility of caller).
E.g. if I'll create:
- HKEY_USERS\S-1-5-19\Software\Classes\Wow6432Node\CLSID
and remove:
- HKEY_USERS\S-1-5-19\Software\Classes\CLSID
class will produce 2 iterations (with .Redirected = 'true', and with 'false').

-----------------------------------

Detailed description of the class:

Common scheme of the cycle:
Code:

' {
'  1. Keys (if supplied)
'  {
'    2. HKLM / HKCU / HKU + every SID...
'    {
'      3. REDIR_WOW (redirected) / REDIR_NO_WOW
'    }
'  }
' }

Stages of using:

I. Required initialization:

Set global rule for iterator:
Code:

HE.Init [Hives], [opt_SIDs], [opt_WOW_Modes]
where every arg. is a sum of bits, available from Intellisense, e.g.:
Code:

HE.Init HE_HIVE_HKLM Or HE_HIVE_HKCU
[Hives]

Code:

    HE_HIVE_ALL - all
    HE_HIVE_HKLM - HKLM only
    HE_HIVE_HKCU - HKCU only
    HE_HIVE_HKU - HKU only

What properties are affected:
- .Hive
- .HiveName
- .HiveNameAndSID
- .KeyAndHive
- .UserName

[SIDs]
Code:

    HE_SID_ALL - all
    HE_SID_DEFAULT - HKU\.Default (target of HKU\S-1-5-18 symlink)
    HE_SID_SERVICE - mean HKU\S-1-5-19 (Local service) and HKU\S-1-5-20 (Network service)
    HE_SID_USER - mean other currently logged users, excepting current user (available as HKCU)

What properties are affected:
- .HiveNameAndSID
- .KeyAndHive
- .UserName
- .IsSidSystem
- .IsSidUser
- .IsSidDefault properties.

[WOW_Modes]
Code:

    HE_REDIR_BOTH - to iterate both WOW modes (checking for 'Shared' keys will be activated for this flag only)
    HE_REDIR_NO_WOW - NO_WOW only (64-bit keys)
    HE_REDIR_WOW - WOW only (32-bit keys)
    HE_REDIR_DONT_IGNORE_SHARED - ignore checking for 'Shared' type. Force iteratation of every WOW mode.

What properties are affected:
- .Redirected

2. Optional. Supply key (keys).

a) Supply array of keys:
Code:

HE.AddKeys string_array
What properties are affected:
- .Key
- .KeyAndHive
- .SharedKey
- .KeyIndex

b) Supply single key (or keys one by one with several .AddKey calls)

What properties are affected:
- .Key
- .KeyAndHive
- .SharedKey
- special excludes for hives.
Code:

HE.AddKey [Key], [opt_PostPlaceholder]
where:
[Key] is a key in any of 2 formats:
1) Key
2) Hive\Key

It's can be:
Quote:

Software\Classes\CLSID
HKLM\Software\Classes\AppID
HKEY_LOCAL_MACHINE\Software\Classes\AppID
In case, you prepended concrete "Hive" to key it will be treated as an exclude from global rule (e.g., HE.Init HE_HIVE_ALL): for such key, enumerator will return only concrete hive (HKLM in example above).

[opt_PostPlaceholder] - optional. Any text. Enumerator will append it to the .Key. You can use it in your cycle e.g., to replace with a data that was not known to you at the time of class initialization (e.g. to replace manually "{CLSID}" by real CLSID in different parts of key for different keys).


II. Beginning of enumeration.

Code:

Do while HE.MoveNext
        'use any HE property
Loop


III. Using of properties.

HE.Hive - hive handle (constant)
HE.Key - string, representing the key only, e.g. 'Software\Microsoft'
HE.Redirection - boolean, representing WOW mode (false - native key, true - 32-bit key).
HE.KeyAndHive - string, "Hive\Key"
HE.HiveName - string, short name of hive, e.g. "HKLM"
HE.HiveNameAndSID - string, e.g. "HKU\S-1-5-19"
HE.UserName - string:
- for HKLM - "All users"
- for HKCU - current user's name
- for HKU\S-1-5-19 - "Local service"
- for HKU\S-1-5-20 - "Network service"
- for HKU\.Default - "Default user"
- for HKU\S-some another SID - user's name of that SID
HE.KeyIndex - index of array passed to the class used in current iteration, e.g. need, if you track several linked arrays by its index, like array of keys + array of these keys' description and want to get description by index for current iteration (see first example above - for sDes() array it will be sDes(HE.KeyIndex) ).
HE.SharedKey - boolean. To know if this key have a 'shared' type, e.g. need, if you know that this key1 linked to another key2, so if key1 is 'Shared' and key2 is not, now you know e.g. that you need to pay attention on both WOW modes of key2.
HE.IsSidService - boolean. TRUE, if current iteration is on 'HKU\S-1-5-19' or, 'HKU\S-1-5-20'
HE.IsSidUser - boolean. TRUE, if current iteration is on 'HKU\S-Some custom logged user'
HE.IsSidDefault - boolean. TRUE, if current iteration is on 'HKU\.Default'

Methods:

PrintAll - test reason. To show in debug. window all properties of all iterations. Try play with it :)


IV. Optional steps.

Repeat enum.

If you need repeat enumeration again with the same settings:
Code:

HE.Repeat

Do While HE.MoveNext
'...


Erase / fresh enum:

Just use .Init again with the same or new settings.
It will erase all data supplied before. No need to terminate the class.
Attached Files

VB6 - Very simple CoreAudio Demo (vbRichClient5)

[VB6] Detect if process is hung

$
0
0
It's a console application based on IsHungAppWindow API.

Syntax:

FreezeDetector.exe [opt_Filters]

Filters:
"IMAGENAME eq [Process name]"
"PID eq [Process ID]"

Note: All filters should be quoted

Examples:
FreezeDetector.exe without arguments - will list all processes with hung windows
FreezeDetector.exe "IMAGENAME eq my.exe" - check if my.exe process' window is hang
FreezeDetector.exe "PID eq 1234" - check if window of process with Process ID 1234 is hang.

Return exit code:
0 - was hang
1 - no hangs found.

Compatibility: Win2k+
Attached Files

XML Parser (written entirely on VB6)

$
0
0
Copyrights: Jason Thorn (Fork by Alex Dragokas)

There are 2 projects:

1) GUI
(activeX dll based)
compile vbXml-browser\Browser\Browser.vbg
Required: MSCOMCTL.OCX

2) Simple app (debug. window sample)
vbXml-simple\Project1.vbp

Some xml files samples are in 'xml-files' dir.

Classes allows to:
- read .XML files
- append nodes / attributes
- serialize back to .xml

Supported:
- all required special characters
- CDATA markup
- UTF-16 LE XML files format
- XML header
- reading tags' attributes

Currently not supported:
- Entities

P.S. There maybe some trouble with compilation GUI (vbg) caused by binary incompatibility. Maybe, someone help me to set project correctly.

PPS. Classes are not well tested. I'll be glag to get feedback.

Name:  title.jpg
Views: 31
Size:  23.7 KB

Feel free to use,
Good luck :)
Attached Images
 
Attached Files

Code for working with Unsigned Shorts

$
0
0
In VB6, the Integer data type is equivalent to a Short (signed short) in C. Now when you encounter a UShort (unsigned short) in a file or in a structure returned from a DLL call, what do you do? You can either hope that the value stored in it happens to be less than 32768 (a region in which Shorts and UShorts are identical), or try to find a way to get the full range of possible UShort values represented in VB6. My code here does the latter.

Code:

Private Function UShortToInt(ByVal Value As Integer) As Long
    UShortToInt = Value And &HFFFF&
End Function

Private Function IntToUShort(ByVal Value As Long) As Integer
    IntToUShort = (Value And &H7FFF) - (Value And &H8000)
End Function


When you get a UShort value, you simply use UShortToInt to convert it to Int (what's called Long in VB6), which even though it is technically a signed data type it can represent all positive values that UShort can. This gives you access to the full range of values that you were intended to be able to have access to in the UShort field from whatever file you read the data from. If you need to save a UShort to file, just work with the data in an Int and then use IntToUShort to convert it to a UShort prior to saving it to the file.

VB6 - Simple Hash Program

$
0
0
Attached is a program to calculate the various hash values for a string or a binary file. This can be useful if you are downloading an executable file (.exe/.dll etc) and the author has provided a hash value under a different cover. This allows you to verify that the code has not been tampered with, which is not all that uncommon an occurrence these days. Personally, I would recommend nothing less than SHA256, which is why I have made it the default.

Although the InkEdit controls used support Unicode, the conversion routine used (StrToByte) selects single byte characters. To use it with non-ASCII characters, use the UniToByte routine.

J.A. Coutts
Attached Images
 
Attached Files

Code for speed testing memory copy

$
0
0
Here's my code for testing the speed of various memory copy functions. The value printed by the print function after each 100 iterations of the function being tested is the average time (in milliseconds) that it took to execute that function. The below VB6 source code has comments that show how it works.

Code:

Private Declare Sub CopyBytes Lib "FastMemCopy.dll" (ByRef Dest As Any, ByRef Src As Any, ByVal ByteCount As Long)
Private Declare Sub CopyWords Lib "FastMemCopy.dll" (ByRef Dest As Any, ByRef Src As Any, ByVal WordCount As Long)
Private Declare Sub CopyDWords Lib "FastMemCopy.dll" (ByRef Dest As Any, ByRef Src As Any, ByVal DWordCount As Long)
Private Declare Sub CopyBytesFast Lib "FastMemCopy.dll" (ByRef Dest As Any, ByRef Src As Any, ByVal ByteCount As Long)
Private Declare Sub CopyWordsFast Lib "FastMemCopy.dll" (ByRef Dest As Any, ByRef Src As Any, ByVal WordCount As Long)

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Declare Function timeBeginPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
Private Declare Function timeEndPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long


Private Sub Form_Load()
    Dim Mem1(100000000 - 1) As Byte
    Dim Mem2(100000000 - 1) As Byte
    Dim TimeStart As Long
    Dim TimeEnd As Long
    Dim TimePassed As Double
    Dim TimePassedAvg As Double
    Dim i As Long
   
   
   
    timeBeginPeriod 1
   
   
    'Perform 100 iterations of copying 100 million bytes, 1 byte at a time
    TimePassedAvg = 0
    For i = 1 To 100
        TimeStart = timeGetTime
        CopyBytes Mem2(0), Mem1(0), 100000000
        TimeEnd = timeGetTime
        TimePassed = TimeEnd - TimeStart
        TimePassedAvg = TimePassedAvg + TimePassed / 100
    Next i
    Print TimePassedAvg
   
    'Perform 100 iterations of copying 100 million bytes, 2 bytes at a time
    TimePassedAvg = 0
    For i = 1 To 100
        TimeStart = timeGetTime
        CopyWords Mem2(0), Mem1(0), 50000000
        TimeEnd = timeGetTime
        TimePassed = TimeEnd - TimeStart
        TimePassedAvg = TimePassedAvg + TimePassed / 100
    Next i
    Print TimePassedAvg
   
    'Perform 100 iterations of copying 100 million bytes, 4 bytes at a time
    TimePassedAvg = 0
    For i = 1 To 100
        TimeStart = timeGetTime
        CopyDWords Mem2(0), Mem1(0), 25000000
        TimeEnd = timeGetTime
        TimePassed = TimeEnd - TimeStart
        TimePassedAvg = TimePassedAvg + TimePassed / 100
    Next i
    Print TimePassedAvg
   
   
   
    'Should dentical to the fourth test, as 100000000 is an exact multiple of 4 bytes
    TimePassedAvg = 0
    For i = 1 To 100
        TimeStart = timeGetTime
        CopyBytesFast Mem2(0), Mem1(0), 100000000 'Copy as many 4byte blocks as possible and then copy remaining data 1 byte at a time
        TimeEnd = timeGetTime
        TimePassed = TimeEnd - TimeStart
        TimePassedAvg = TimePassedAvg + TimePassed / 100
    Next i
    Print TimePassedAvg
   
    'Should dentical to the fourth test, as 100000000 is an exact multiple of 4 bytes
    TimePassedAvg = 0
    For i = 1 To 100
        TimeStart = timeGetTime
        CopyWordsFast Mem2(0), Mem1(0), 50000000 'Copy as many 4byte blocks as possible and then copy remaining data 2 bytes at a time
        TimeEnd = timeGetTime
        TimePassed = TimeEnd - TimeStart
        TimePassedAvg = TimePassedAvg + TimePassed / 100
    Next i
    Print TimePassedAvg
   
   
    'Perform 100 iterations of copying 100 million bytes using CopyMemory
    'Not sure what method CopyMemory uses, but it is supposed to work on overlapping memory regions, so it must use an advanced technique
    TimePassedAvg = 0
    For i = 1 To 100
        TimeStart = timeGetTime
        CopyMemory Mem2(0), Mem1(0), 100000000
        TimeEnd = timeGetTime
        TimePassed = TimeEnd - TimeStart
        TimePassedAvg = TimePassedAvg + TimePassed / 100
    Next i
    Print TimePassedAvg
   
   
   
    timeEndPeriod 1
   
End Sub

When the program is actually run, I find that there is really no speed difference at all between the different functions. Not sure why this is, but maybe on modern CPUs, it always takes the same amount of time to copy a given number of bytes, regardless if they are copied by Byte, Word, or DWord. So copying 4 bytes takes the same amount time as copying 2 words or 1 dword. Unlike on older CPUs, maybe you don't get a speed boost by optimizing your program, by having it copy dwords or words instead of bytes.

Here's the results of running this program 3 different times.
First time I ran the program:
25.66
26.17
25.90
25.83
26.29
25.71

Second time I ran the program:
27.36
30.50
30.17
26.73
26.88
26.18

Third time I ran the program:
25.58
25.98
25.64
25.44
25.86
25.73

As you can see, the there is no consistency at all between different times I ran the tester program. Nor is there any consistency regarding which function is faster. Sometimes one function was faster, and sometimes another one was faster. The only thing consistent is that the times tended to hover around 26ms, and every once in a while the functions (for no apparent reason) ran slower, sometimes taking about 30ms to complete. I'm not sure what caused those outlier 30ms times. And all of these inconsistencies I've mentioned are present despite getting calculating an average time, by running a given function 100 times, each time it was tested. I hope somebody can explain these inconsistencies.


The first 5 Copy functions are ones in a DLL I made myself in assembly language, and assembled with FASM. Below is the source code for that DLL file. It's also has comments so you can see how it works.
Code:

format PE GUI 4.0 DLL
entry dllmain
include "macro\export.inc"

Arg1 equ ebp+8
Arg2 equ Arg1+4
Arg3 equ Arg2+4


section ".text" code readable executable
        dllmain:
        mov eax,1
        ret 12

        CopyBytes:
        push ebp
        mov ebp,esp
        push esi
        push edi
        push ecx
        mov edi,[Arg1]
        mov esi,[Arg2]
        mov ecx,[Arg3] ;Number of bytes to copy
        rep movsb ;Copy data 1 byte at a time
        pop ecx
        pop edi
        pop esi
        leave
        ret 12

        CopyWords:
        push ebp
        mov ebp,esp
        push esi
        push edi
        push ecx
        mov edi,[ebp+8]
        mov esi,[ebp+12]
        mov ecx,[ebp+16] ;Number of words (2 byte blocks) to copy
        rep movsw ;Copy data 1 word at a time
        pop ecx
        pop edi
        pop esi
        leave
        ret 12

        CopyDWords:
        push ebp
        mov ebp,esp
        push esi
        push edi
        push ecx
        mov edi,[ebp+8]
        mov esi,[ebp+12]
        mov ecx,[ebp+16] ;Number of dwords (4 byte blocks) to copy
        rep movsd ;Copy data 1 dword at a time
        pop ecx
        pop edi
        pop esi
        leave
        ret 12


        CopyBytesFast:
        push ebp
        mov ebp,esp
        push esi
        push edi
        push ecx
        mov edi,[Arg1]
        mov esi,[Arg2]
        mov eax,[Arg3] ;Number of bytes to copy
        xor edx,edx
        mov ecx,4
        div ecx
        mov ecx,eax
        rep movsd ;First, copy as much data as possible 4 bytes at a time
        mov ecx,edx
        rep movsb ;Then, copy remaining data 1 byte at a time
        pop ecx
        pop edi
        pop esi
        leave
        ret 12

        CopyWordsFast:
        push ebp
        mov ebp,esp
        push esi
        push edi
        push ecx
        mov edi,[Arg1]
        mov esi,[Arg2]
        mov eax,[Arg3] ;Number of words to copy
        xor edx,edx
        mov ecx,2
        div ecx
        mov ecx,eax
        rep movsd ;First, copy as much data as possible 2 words at a time
        mov ecx,edx
        rep movsw ;Then, copy remaining data 1 word at a time
        pop ecx
        pop edi
        pop esi
        leave
        ret 12


section ".edata" export readable
        export "FastMemCopy.dll",\
              CopyBytes, "CopyBytes",\
              CopyWords, "CopyWords",\
              CopyDWords, "CopyDWords",\
              CopyBytesFast, "CopyBytesFast",\
              CopyWordsFast, "CopyWordsFast"

section ".reloc" fixups readable
        dq 0

VB6 - User SID/Path

$
0
0
I needed a value that was unique to the current logged in user, so what is more unique than the User SID (User Security ID). Using the attached code, I found the SID:
Buffer:
70 70 27 00 00 00 00 00 01 05 00 00 00 00 00 05
15 00 00 00 27 E9 C3 D8 E9 4C AB 9A D3 BA 44 5F
E9 03 00 00
Of the 36 bytes provided, the first 4 are the memory location, the next 16 are common to all User SID's, and the last 16 are 4 long values that are unique to each user when combined.

J.A. Coutts
Attached Images
 
Attached Files

[VB6] BTEnum - Enumerate Bluetooth devices

$
0
0
This uses the Microsoft Bluetooth APIs to get a list of remembered and in-range visible Bluetooth devices.

Requires Windows XP SP 2 or later, and a Bluetooth adapter/radio supporting the Microsoft Bluetooth stack.


A search can take a while, so you can specify the timeout. Shorter timeouts might miss some devices.

Demo using the BTEnum class is attached. Sample run:

Name:  sshot.png
Views: 65
Size:  6.2 KB


Only tested on Windows 10 1709.

There were some tricky aspects to getting this working. There might still be flaws and it might not work right on older OSs due to changes in structs over time.
Attached Images
 
Attached Files

Linear Algebra for 3D Space

$
0
0
I'm not sure who will actually benefit from these procedures, but I suspect a few people will occasionally find them through Google. I've just got quite a bit of work into them, and wanted to share.

Also, for those versed in linear algebra, let me provide a few definitions and some context.

1) Everything follows the right-hand-rule.

2) In the attached module, the concept of a "Segment" is actually just an ordered basis. It's basically four 3D vectors. One defines the origin, one defines the X (forward, East) axis, one defines the Y (left, North) axis, and one defines the Z (up) axis. These three axes are orthonormal (i.e., orthogonal with one unit length). The origin is not built into the three orthonormal axes. In other words, these three axes are setup as if the origin is always <0,0,0>. This makes rotations of these Segments much easier.

3) When using quaternions, they always follow the JPL convention and are unit quaternions (i.e., no built-in scaling).

4) There are some functions that are specific to emulating functions found in the BodyBuilder language by Vicon. These may be a bit unusual for a "pure" mathematician, but they serve my purposes.

5) When converting from Euler angles to quaternions (and vice-versa), many procedures found on the web will only do it in one angle order (typically ZYX). However, the attached procedures will do it in any order of your choosing. The only online reference for this that I could find was an old scanned 1977 NASA document, specifically Appendix A.

6) If you actually start studying this code, note that all the rotations are actually performed using quaternions. In other words, Euler angles aren't used directly for anything other than reporting results.

7) I'm also wondering if there's possibly some graphical API interface that I could be using to do some of this faster. Any ideas on that front are more than welcome. Don't forget though that I'll always need to specify the angle order when moving between Euler angles and quaternions, and not have it pre-defined.

The BAS module was too large to put into a CODE block, so it's attached. However, here's a list of functions.

Code:


'
' List of functions herein:
'
'  Make Segment (ordered basis) Functions:
'
'      SegFrom5Pts
'      SegFrom3Pts
'      SegFromLines
'
'  Conversion Functions:
'
'      Euler2Quat
'      Quat2Euler
'      Seg2Quat                ' Abandons origin.
'      Quat2Seg                ' Leaves origin as <0,0,0>.
'      Seg2Euler              ' Abandons origin.
'      Euler2Seg              ' Leaves origin as <0,0,0>
'
'      Rad2Deg
'      Deg2Rad
'      VecRad2Deg
'      VecDeg2Rad
'
'      Axes2Quat              ' Similar to Seg2Quat.
'      Quat2Fwd                ' Forward (x) axis of quat. Same as X axis of segment.
'      Quat2Left              ' Left (y) axis of quat.    Same as Y axis of segment.
'      Quat2Up                ' Up (z) axis of quat.      Same as Z axis of segment.
'      AxisAngle2Quat          ' This is the rotation axis, not any segment axis.
'      QuatAxis                ' This returns the rotation axis.
'      QuatAngle              ' This returns the rotation angle.
'
'  Rotation Functions:
'
'      RotSeg (with axis & angle)
'      RotSegByQuat
'      RotVec (with axis & angle)
'      RotVecByQuat
'      RotQuat (by quat)
'      UnRotQuat (by quat)    ' Same as a QuatBetween function: UnRotQuat(q2, q1).
'
'  Angles Between Functions:
'
'      EulerBetweenSegs        = -<seg1, seg2, order> (BodyBuilder)
'      FixedBetweenSegs        =  <seg1, seg2, order> (BodyBuilder)
'      EulerBetweenQuats
'      (QuatBetweenQuats)      ' Do UnRotQuat(q2, q1).
'
'  Quick Functions:
'
'      XProd
'      DotProd
'
'      VecAvg
'      VecSum
'      VecDif
'      VecAddNum
'      VecDivNum
'      VecMultNum
'      VecMag
'      NegVec
'      UnitVec
'
'      NegQuat
'
'      MakeLine
'      MakeVec
'      MakeQuat
'
'  Trigonometry Functions:
'
'      ACos
'      ASin
'      ATan2
'
'  Debugging Functions:
'
'      AngString
'      PntString
'
'      VecString
'      QuatString
'      SegString
'


Enjoy,
Elroy


EDIT1: Just to mention it, when doing Euler2Quat (or Quat2Euler), there are actually twelve possible orders, and I've only covered six of them. The six I've covered are: xyz, xzy, yzx, yxz, zxy, & zyx. There's also a way to get from Euler angles to a quaternion whereby you do the rotation on the first axis, then the second, and then finish up by returning to the first axis. In other words, these rotation orders would be denoted as: xyx, xzx, yxy, yzy, zxz, & zyz. At present, I've got no need for this approach, and they're not currently covered in the attached code.
Attached Files

Migrating RichTextBox (RTB) Control to InkEdit Control

$
0
0
The purpose of this thread will be to describe the process of moving existing RTB code to use the InkEdit control.

MSDN states this about the InkEdit control here, so the chances of a successful migration seem good:

Quote:

The InkEdit control is a super class of the RichEdit control. Every RichEdit message is passed on, directly in most cases, and has exactly the same effect as in RichEdit. This also applies to event notification messages.
Let's hope that's the case!

If you are unfamiliar with the InkEdit control, Dilettante has done a lot of work demonstrate its various improvements over the VB6 RTB control in threads such as these:

http://www.vbforums.com/showthread.p...ows-SpellCheck




Event Gotchas

Mouse Events
The Mouse* events in the InkEdit have different signatures than the RTB. Namely, all parameters are passed ByVal instead of ByRef, and last 2 parameters (x and y) are Long instead of Single. You will need to change the RTB events to match the InkEdit event signatures in your source code.

For example:

Code:

Private Sub RichTextBox1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Becomes:

Code:

Private Sub InkEdit1_MouseMove(ByVal Button As Integer, ByVal ShiftKey As Integer, ByVal xMouse As Long, ByVal yMouse As Long)
According to MSDN, InkEdit always passes Pixels via the X & Y parameters. If you have old Mouse* RTB code that always uses Twips, you will need to make the appropriate modifications when migrating the code. See: https://msdn.microsoft.com/en-us/lib...(v=vs.85).aspx

OLE* Events

The OLECompleteDrag, OLEDragDrop, OLEDragOver, OLEGiveFeedback, OLESetData, and OLEStartDrag events all appear to be missing from the InkEdit control, so you'll have to use another method to use OLE features with the control (maybe Fafalone's or Edanmo's OLE TLB(s) or similar?)




Property Gotchas

SelStrikeThru

The SelStrikeThru property appears to be missing from the InkEdit control, so another approach will have to be found to replicate the functionality of this property. Solution: Use TOM to get/set the current selection's font StrikeThrough state. e.g.:

Code:

  ' Where mo_Tom is a properly initialized TOM reference linked to the InkEdit control
  mo_Tom.TextDocument.Selection.Font.Strikethrough = True/False

RightMargin

The RightMargin property appears to be missing from the InkEdit control, so another approach is necessary. The EM_SETMARGINS and EM_GETMARGINS messages can be used instead (thank LaVolpe!)

Code:

' Note that this is quick "air code" - it should work, but I haven't tested it specifically
' Since I use various other HiWord/LoWord/Dword/ScaleMode conversion methods, helper libraries, etc...

Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal _
lParam As Long) As Long

Private Const EM_GETMARGINS As Long = &HD4
Private Const EM_SETMARGINS As Long  = &HD3

Private Const EC_RIGHTMARGIN As Long = &H2

Public Property Get RightMargin() As Long
  RightMargin = SendMessage InkEdit1.Hwnd, EM_GETMARGINS, 0, 0

  RightMargin = (RightMargin / &H10000) And &HFFFF&  ' Get HiWord of Return Value

  RightMargin = RightMargin * Screen.TwipsPerPixelX  ' Convert Pixels to Twips - may need other approach for HighDPI in UserControl
End Property

Public Property Let RightMargin(ByVal p_Twips As Long)
  p_Twips = p_Twips / Screen.TwipsPerPixelX  ' Convert Twips to Pixels
  p_Twips = p_Twips * &H10000  ' Move Pixels to HiWord
 
  SendMessage InkEdit1.Hwnd, EM_SETMARGINS, EC_RIGHTMARGIN, p_Twips
End Property




Message Gotchas

EM_FORMATRANGE

In my initial tests EM_FORMATRANGE always appears to return -1 instead of the last character index +1 that fit in the bounding box if the FORMATRANGE.hDC parameter is 0. The RTB works OK when FORMATRANGE.hDC = 0. The solution is to pass a valid DC handle to FORMATRANGE.hDC before sending the EM_FORMATRANGE message.

[VB6] Class to show a standard Explorer-style progress window

$
0
0

cProgressWindow

Windows provides a simple interface that allows you to use an asychronous Explorer-style progress dialog with just a few lines of code. So I thought I'd wrap up this functionality in a class to make it a bit easier to use, especially with automating checking for cancel, raising an event for it, and closing the dialog.

It's all pretty self-explanatory... the class comes with a demo project that shows usage of the most basic options, and the class itself implements all the functionality (except setting an animation, because that's only supported in XP).

Requirements
Windows XP or newer
oleexp.tlb, any version (or olelib)

Future Work

If you're working with files, you may want the more detailed progress window that you get with IFileOperation and Explorer in Windows 7... you can manually control such a progress dialog in a manner similar to this one with another interface supported by the same ProgressDialog object, IOperationsProgressDialog. You can then use it like this or as the custom dialog from IFileOperation.SetProgressDialog.
I'll be putting up a demo of using that interface in a few days, but if you wanted to experiment in the mean time, all the definitions are already in oleexp (but this one isn't XP compatible and not present in olelib), and you can create an instance of it via
Code:

Dim cProg As IOperationsProgressDialog
Set cProg = New ProgressDialog

Note that with this version, your first call must be .StartProgressDialog, or you get a 'catastrophic error' message. Also always use .SetMode, or the dialog might just flash at the end of the operation instead of show throughout.

Attached Files

VB6 Icon Maker

$
0
0
I was having difficulty finding appropriate Icons that could be added to VB6 programs, and using online Icon tools was a real pain. So I found an older Bmp2Icon program code, but it was overly complex, difficult to use, and contained a lot of unused code (4 forms, 4 modules, 2 Classes, and 2 User Controls). Attached is my attempt at a much simplified version.

The sample shown below used 3DLRSIGN.WMF from the VB6 graphics collection, changed the aspect ratio to make it square, changed the background from white to red, shrunk it to the size of a 32 x 32 icon, and saved it in Icon format. It was then used as the Icon for the program.

I have very little graphic experience, and I expect that the code could be simplified further. Even though I changed the background to red, the Icon showed up with a translucent background, and when I viewed the Icon with Paint, it showed up as a red dollar sign with a white background (?????).

J.A. Coutts
Attached Images
  
Attached Files

Memory Blt

$
0
0
In order to copy graphics, you typically use BitBlt which works on DCs containing Bitmap objects. But the problem with that is that you have to keep track of all your DCs and Bitmaps (and dispose of them when done, to prevent memory leaks), and color conversions can happen behind the scenes. For example, if I use LoadImage API on an older machine with 8bit graphics, it will automaticlally convert any bitmap (even a 32bit bitmap file) into either an 8bit bitmap, or a 32bit bitmap who's color values correspond to the colors of the default 8bit system palette. This causes significant loss in color depth, so any images saved after that, will be permanently lowered in color depth, and look very ugly.

So I need to avoid using the Windows APIs altogether for loading 32bit bitmaps (only using the API functions to display bitmaps to the screen after any processing is done) if I want my program to be compatible on nearly all computers (both new and very old). I will need to write my own code for loading the image data from 32bit BMP files into RGBQuad arrays. But then when I do that, I have the other problem of losing all of the API functions like BitBlt that work with bitmaps and DCs. Those don't work with arrays. So that is why I have written my own Memory Blt functions. These copy images (or parts of images) from one RGBQuad array to another. I have 2 such functions. Below is the code for these, that you can put in any VB6 Module.

Code:

Public Declare Sub CopyBytes Lib "msvbvm60.dll" Alias "__vbaCopyBytes" (ByVal ByteCount As Long, ByRef Dest As Any, ByRef Src As Any)

Public Type RGBQuad
    B As Byte
    G As Byte
    R As Byte
    unused As Byte
End Type

Public Sub MemBlt( _
    ByVal Width As Long, _
    ByVal Height As Long, _
    ByVal SrcX As Long, _
    ByVal SrcY As Long, _
    ByVal DestX As Long, _
    ByVal DestY As Long, _
    ByRef Src() As RGBQuad, _
    ByRef Dest() As RGBQuad)
   
    Dim UBXSrc As Long
    Dim UBYSrc As Long
    Dim UBXDest As Long
    Dim UBYDest As Long
    Dim y As Long
    Dim y1 As Long
    Dim y2 As Long
    Dim ByteWidth As Long
   
    UBXSrc = UBound(Src, 1)
    UBYSrc = UBound(Src, 2)
    UBXDest = UBound(Dest, 1)
    UBYDest = UBound(Dest, 2)
   
    If SrcX < 0 Then
        Width = Width + SrcX
        SrcX = 0
    ElseIf SrcX > UBXSrc Then
        Exit Sub
    End If
    If SrcX + Width - 1 < 0 Then
        Exit Sub
    ElseIf SrcX + Width - 1 > UBXSrc Then
        Width = (UBXSrc - SrcX) + 1
    End If
    If SrcY < 0 Then
        Height = Height + SrcY
        SrcY = 0
    ElseIf SrcY > UBYSrc Then
        Exit Sub
    End If
    If SrcY + Height - 1 < 0 Then
        Exit Sub
    ElseIf SrcY + Height - 1 > UBYSrc Then
        Height = (UBYSrc - SrcY) + 1
    End If
   
    If DestX < 0 Then
        Width = Width + DestX
        DestX = 0
    ElseIf DestX > UBXDest Then
        Exit Sub
    End If
    If DestX + Width - 1 < 0 Then
        Exit Sub
    ElseIf DestX + Width - 1 > UBXDest Then
        Width = (UBXDest - DestX) + 1
    End If
    If DestY < 0 Then
        Height = Height + DestY
        DestY = 0
    ElseIf DestY > UBYDest Then
        Exit Sub
    End If
    If DestY + Height - 1 < 0 Then
        Exit Sub
    ElseIf DestY + Height - 1 > UBYDest Then
        Height = (UBYDest - DestY) + 1
    End If
   
    ByteWidth = Width * 4
   
    For y = 0 To Height - 1
        y1 = SrcY + y
        y2 = DestY + y
        CopyBytes ByteWidth, Dest(DestX, y2), Src(SrcX, y1)
    Next y
End Sub


Public Sub MemBlt2( _
    ByVal Width As Long, _
    ByVal Height As Long, _
    ByVal SrcX As Long, _
    ByVal SrcY As Long, _
    ByVal DestX As Long, _
    ByVal DestY As Long, _
    ByRef Src() As RGBQuad, _
    ByRef Dest() As RGBQuad)
    Dim temppix() As RGBQuad
    ReDim temppix(Width - 1, Height - 1)
    MemBlt Width, Height, SrcX, SrcY, 0, 0, Src(), temppix()
    MemBlt Width, Height, 0, 0, DestX, DestY, temppix(), Dest()
End Sub


The two Memory Blt subs are MemBlt and MemBlt2.

MemBlt does all required bounds checking, and changes as necessary the size of the copied region so that it fits within both of the RGBQuad arrays. If the copied region is completely outside of either the source or the destination, then it exits immediately. It uses __vbaCopyBytes instead of RtlMoveMemory (aka CopyMemory), because __vbaCopyBytes is faster (no memory region overlap compensating), and also because the overlap compensating done by RtlMoveMemory only works in a 1D memory region. It fails to prevent the problems produced by overlap of source and destination when working in a 2D memory region. So why slow it down when the slower function isn't even effective in the situation it's being used in?

Of course the overlap problem does need a solution. While MemBlt is fine for use as-is when the source array and destination array are different, or when they are the same but the regions are different (and in fact MemBlt is better in these cases, because it's faster), there is still the problem of what to do when the source and destination arrays are the same and the regions overlap. To fix that, I created MemBlt2. It creates a temporary RGBQuad array, and performs 2 calls to MemBlt. First call to MemBlt copies a region from the source array to the temporary array, and the second call to MemBlt copies from the temporary array to the destination array. This is slower, but effective at preventing the problems that can occur when the source and destination arrays are the same, and source and destination regions overlap. This is the 2D equivalent to RtlMoveMemory.

LaVolpe's c32bppDIB - Filling A, R, G and B channel each with different image source

$
0
0
Hello!

In Photoshop, I can paste an image into each channel which looks like this:

Name:  photoshop1.png
Views: 28
Size:  9.5 KB

It's not easy to see in this screenshot, but each channels holds a different image.
The end results is a "packed" 3D game texture.

I would like to do the same with VB6.
Since I'm using the c32bppDIB class by LaVolpe all the time (it's my Swiss Army Knife), I tried to use it for this purpose.

But I soon gave up as it got too complex for me.

Is there anybody here who has a better understanding of the c32bppDIB class and who could help?

Thank you very much!
Attached Images
 

[vb6]Common Dialog Class (Yet Another One)

$
0
0
This class combines the Windows XP/Win2000 Open/Save dialog that uses APIs to generate the dialog with the IFileDialog interface used in Vista and higher. Basically, the class is a unicode-friendly dialog option as a drop-in, self-contained class. Do note that the class has been hard-coded to not run on any O/S less than XP/Win2000.

Though the class makes heavy use of calling to interfaces not known to VB, it does not use type libraries (TLBs). However, I have made every effort to make it compatible to TLBs you may be using in your project. In other words, objects returned by this class through its events or functions should be 100% compatible with a TLB that defines interfaces that this class is using. Anything less would be an oversight by me and considered a "bug report".

This class has absolutely no real benefit over existing code you may already be using unless you want more advanced options. Some of those options include:

- XP/Win2000: class-generated thunks for hooking the dialog. Those thunks result in raised events from the class to its host, i.e., form, usercontrol, other class, etc.

- Vista and higher
-- Customize by adding additional controls to the dialog and receive events for those controls
-- Add a read-only checkbox back to the dialog that populates the common OFN_ReadOnly flag
-- Interact with the dialog via class-generated thunks that raise events from the class to its host
-- Use embedded custom configurations. There are currently 7 of those.
1. Browse for Folders while showing file names too
2. Navigate into compressed folders (zips) while being able to select the zip itself or one of its contained files or any other file
3. Show both files and folders and be able to select either folders or files or both
4. Four "basket mode" settings which allows selecting files/folders across multiple directories. Similar to "Add to my Cart" button.
-- All custom mode button captions can be assigned by you or default to locale-aware captions (see screenshot below)

Nearly all of the advanced Vista options are incorporated into this class, but not all. If you find you need anything more that is not offered, modify as needed.

If you just want a simple Open/Save dialog where the filter is: All Files, the code needed for the dialog is as simple as:
Code:

    Dim cBrowser As OSDialogEx
    Set cBrowser = New OSDialogEx
    If cBrowser.ShowOpen(Me.hWnd) = True Then
        MsgBox "File Selected: " & cBrowser.FileName
    End If

Want to add the "Read-Only" checkbox back to the dialog?
Code:

    Dim cBrowser As OSDialogEx
    Set cBrowser = New OSDialogEx
    cBrowser.Controls_AddReadOnlyOption 100    ' << user-defined Control ID
    If cBrowser.ShowOpen(Me.hWnd) = True Then
        MsgBox "File Selected and Read-Only opted for: " & CBool(cBrowser.Flags And Dlg_ReadOnly)
    End If

Want a "Browse for Folder" like dialog that also shows files (not doable with newer dialog using standard options)?
Code:

    Dim cBrowser As OSDialogEx
    Set cBrowser = New OSDialogEx
    cBrowser.Controls_SetCustomMode cm_BrowseFoldersShowFiles
    If cBrowser.ShowOpen(Me.hWnd) = True Then
        MsgBox "Selected Folder: " & cBrowser.FileName
    End If

The screenshot below highlights locale-aware captions. The only one I haven't been able to find is a locale-aware caption like: All Files. That would be a nice-touch. But since I haven't found it yet in a common DLL, the dialog filter is hard-coded as "All Files" if you do not provide your own filter.
Name:  Dialog.jpg
Views: 117
Size:  28.4 KB

The sample project offers examples of several dialog variations. The class itself is heavily commented.
Code:

Update History
21 Jan 18 - initial release
23 Jan 18 - Minor fixes
        Fixed a couple locale-aware captions being retrieved from common dlls
        Addressed case where Windows can convert "Open" button to unexpected split-button

Attached Images
 
Attached Files

VB6 - Port Tester

$
0
0
The normal way to find your real external IP address is to use your browser to go to a site such as "WhatsMyIP". I needed to do this programatically without the burden of using HTML. What I came up with is a way to verify a forwarding port within a NAT router, while at the same time discovering your public IP address.

Port forwarding can be somewhat onerous for the casual user, and verifying that it is successful is part of the task. To accomplish this, we run a proxy type server on the other side of the NAT router. You send the port number that you want tested to that outside server, and the outside server tries to establish a TCP connection with your router on that port. If the router is properly configured, it will forward that request to your computer and the router's public IP address that was used to make the initial connection with the server will be sent to you.

Port forwarding usually requires that you use fixed IP addressing on your computer rather than DHCP, although it is sometimes possible to configure a NAT router to assign a fixed IP address using DHCP.

Even with the router properly configured, you can still have problems with your firewall. If you are running the Microsoft Firewall, it will prompt you to allow the outside connection.

Last but not least, most ISPs will block some problematic ports such as port 21(FTP), 25(SMTP), 80(WWW), 110(POP3), 6667(IRCD), 135-139(DCOM/NETBIOS), 443(SSL), 445(MS-DS), and 1433-1434(MS-SQL) on residential connections, and there is nothing you can do about it except use a different port or get a business connection.

If there is sufficient interest, I can later supply a service version of the server software.

Note: Both programs use SimpleSock, which requires operating systems that actively support both IPv4 & IPv6. This more or less restricts them to Windows Vista or better.

J.A. Coutts
Attached Images
 
Attached Files

VB6 - NAT Helper

$
0
0
Attached is an application called ExtIP. The original intent was to simply recover the External IP address used by a NAT router, but it ended up being much more. In order to use this program, your router must support Universal Plug and Play (UPnP), which most home routers do. However, not all routers support all functions, as evidenced by the descriptions below. Our own router does not support querying of the Mapping Collection, so some of the functions have not been fully tested.

If your router does not support UPnP, or it has not been turned on, executing any of the functions will produce a message stating "UPnPNAT not Found!".

If you know the external port number of an existing mapping, you can enter that number and recover the External IP address used on the WAN (Wide Area Network), as well as the Internal IP address and the Internal port. The older "GetIpAddrTable" is used to recover the Internal IP address, and uses the last address in the table. If you have more than one active Network Interface, it could produce a wrong result. It will also not produce a correct External IP address if you are using a double NAT configuration (not recommended). (tested)

If you would like to find out the External IP address and you do not know the port number used, you can leave the port number blank, and the program will scroll through the mapping collection and return the first one it finds. (not tested)

Clicking on the Get Ports button will scroll through the port mapping collection and add the External ports to the list box. Clicking on one of them will add it to the External Port box. (not tested)

You can also add a port mapping by entering an External Port number and clicking on the "Add Port Map" button. Normally the Internal Port number matches the External Port, and it will default to that, or you can add a different number. If the port mapping already exists, it will error out. (tested)

You should also be able to delete a port mapping, but our router does not support that function. (not tested)

This program does not support IPv6, because IPv6 does not require the use of NAT.

J.A. Coutts
Attached Images
 
Attached Files

(VB6) Replace VB's Circle method with API's

$
0
0
Code:

Private Declare Function Arc Lib "gdi32" (ByVal hDc As Long, ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long, ByVal nXStartArc As Long, ByVal nYStartArc As Long, ByVal nXEndArc As Long, ByVal nYEndArc As Long) As Long
Private Declare Function Ellipse Lib "gdi32" (ByVal hDc As Long, ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nDrawStyle As Long, ByVal nWidth As Long, ByVal crColor 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 TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long

' Sub Circle(Step As Integer, iX As Single, iY As Single, Radius As Single, Color As Long, StartArc As Single, EndArc As Single, Aspect As Single)
' When an arc or a partial circle or ellipse is drawn, StartArc and EndArc specify (in radians) the beginning and end positions of the arc.
' The range for both is 2 pi radians to 2 pi radians. The default value for StartArc is 0 radians; the default for EndArc is 2 * pi radians.
Sub DrawCircle(x As Single, y As Single, Radius As Single, Optional Color, Optional Aspect As Single = 1, Optional StartArc, Optional EndArc, Optional Step As Boolean)
    Dim iXStartArc As Long, iYStartArc As Long, iXEndArc As Long, iYEndArc As Long
    Dim iAspectX As Single
    Dim iAspectY As Single
    Dim iStartArc As Single
    Dim iEndArc As Single
    Dim iDontDraw As Boolean
    Dim iFilledFigure As Boolean
    Dim iColor As Long
    Dim iPen As Long
    Dim iPenPrev As Long
    Dim iX As Long
    Dim iY As Long
   
    If Step Then
        iX = Picture2.CurrentX + x
        iY = Picture2.CurrentY + y
    Else
        iX = x
        iY = y
    End If
   
    Picture2.Cls
   
    If IsMissing(Color) Then
        iColor = Picture2.ForeColor
    Else
        iColor = Color
    End If
    TranslateColor iColor, 0, iColor

    If IsMissing(StartArc) And IsMissing(EndArc) Then
        If Picture2.FillStyle = vbSolid Then
            iFilledFigure = True
        End If
    End If
   
    If Aspect > 1 Then
        iAspectX = 1 / Aspect
        iAspectY = 1
    Else
        iAspectX = 1
        iAspectY = 1 * Aspect
    End If
   
    If IsMissing(StartArc) Then
        iStartArc = 0
    Else
        iStartArc = StartArc
    End If
    If IsMissing(EndArc) Then
        iEndArc = 0
        ' Note: 0 (zero) for EndArc seems to be handled as 2 * Pi by the API (in fact they are the same point)
    Else
        iEndArc = EndArc
    End If
   
    If Not IsMissing(EndArc) Then ' VB's Circle behaves like this: if StartArc and EndArc parameters are supplied and define an entire circle or ellipse, VB does not draw it
    End If
   
    If Not iDontDraw Then
        iXStartArc = Radius * iAspectX * Cos(iStartArc) + iX
        iYStartArc = Radius * iAspectY * Sin(iStartArc) * -1 + iY
        iXEndArc = Radius * iAspectX * Cos(iEndArc) + iX
        iYEndArc = Radius * iAspectY * Sin(iEndArc) * -1 + iY
       
        If iColor <> Picture2.ForeColor Then
            iPen = CreatePen(Picture2.DrawStyle, Picture2.DrawWidth, iColor)
            iPenPrev = SelectObject(Picture2.hDc, iPen)
        End If
       
        If iFilledFigure Then
            Ellipse Picture2.hDc, iX - Radius * iAspectX, iY - Radius * iAspectY, iX + Radius * iAspectX, iY + Radius * iAspectY
        Else
            Arc Picture2.hDc, iX - Radius * iAspectX, iY - Radius * iAspectY, iX + Radius * iAspectX, iY + Radius * iAspectY, iXStartArc, iYStartArc, iXEndArc, iYEndArc
        End If
        Picture2.Refresh
   
        If iPenPrev <> 0 Then
            Call SelectObject(Picture2.hDc, iPenPrev)
        End If
        If iPen <> 0 Then
            DeleteObject iPen
        End If
   
    End If
   
    Picture2.CurrentX = iX
    Picture2.CurrentY = iY
End Sub

Attached Files

VB6 Webbrowser and Java problems

$
0
0
Hi everyone,

I see this work here and I like this forum so much. Found so many things that helped me.

Now I need your guide to me. I am using ieframe.dll(webbrowser) for vb6 and when I am trying to navigate my webbrowser to "twitch.tv" adress. Theres so many things went wrong. Errors in my page and doesnt run website well.

For example How can I make my webbrowser open "https://www.twitch.tv/eleaguetv" this site. And run without problems? Is there any other webbrowser ocx or anyway that I can upgrade my webbrowser. And any other helps? :P
Viewing all 1476 articles
Browse latest View live


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