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

Tar, tar.gz, tar.bz2 - Create/Extract

$
0
0
Wrapper for Yoshioka Tsuneo's open source C tar32.dll

http://openlab.ring.gr.jp/tsuneo/tar32/index-e.html

Code:

TAR32.DLL is a compression and archive library.
This library can compress/decompress/archive/extract/list archive files.
This library have Common Archivers Library Project API interface.
This library can manipulate under formats.
This library is opensource, and you can use for any purpose.

    .gz (gzip format)
    .Z (compress utility format) / extrace only
    .bz2 (bzip2 format)
    .tar (Tape ARchiver format)
    .cpio (cpio archive format)
    .a, .lib (ar tool format, COFF/a.out/b.out) / extract only
    .rpm (RPM package) (=leading + signature + header + .cpio.gz) /extract only
    .deb (Debian Package) (=ar of ("debian-binary" + "control.tar.gz" + "data.tar.gz")) /extract only
    .tar.gz(.tgz), .tar.bz2
    .tar.Z(.taz) / extract only
    .cpio.gz, .cpio.Z, .cpio.bz2 /extract only
    .a.gz, .a.Z, .a.bz2, lib.gz, lib.Z, lib.bz2, lib.gz / extract only

Class repo:
https://github.com/dzzie/libs/tree/master/tar32

edit: bugfix removed use of lenB
Attached Files

Closing File Select Dialog

$
0
0
closing a dialog window called from a process can have problems as the code will stop running while the dialog is open

a simple solution is a second exe file to find and close the dialog
compile this into a formless executable
Code:

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal HWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Private Declare Function GetWindowTextLength Lib "user32" Alias _
"GetWindowTextLengthA" (ByVal HWnd As Long) 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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Dim Ret As Long, childret As Long, openret As Long
Dim strBuff As String, ButCap As String
Dim combo As Long

Const WM_SETTEXT = &HC
Const BM_CLICK = &HF5

Sub Main()
Dim wcap As String, bcap As String, upfile As String, params() As String, s As String, timeout As Long
params = Split(Command, "-")
wcap = Replace(Trim(params(0)), """", "")  ' window caption
bcap = Replace(Trim(params(1)), """", "")  ' button caption
upfile = Replace(Trim(params(2)), """", "") ' file path\name.ext to upload
' any of the above parameters that could contain spaces, must be enclosed in quotes by the calling application
' separate the parameters using - character
'timeout value can be altered if required as optional extra parameter
If UBound(params) = 3 Then timeout = Trim(params(3)) Else timeout = 15  ' 15 seconds
'MsgBox wcap & vbNewLine & bcap & vbNewLine & upfile
t = Timer

Do While Ret = 0 And Timer < t + timeout
DoEvents
    Ret = FindWindow(vbNullString, wcap)

    s = ""
    If Ret <> 0 Then
    Sleep 1000  ' let dialog load fully was not required in older OS

        '~~> Get the handle of the TextBox Window where we need to type the filename
        combo = FindWindowEx(Ret, ByVal 0&, "ComboBoxEx32", vbNullString)

        combo = FindWindowEx(combo, ByVal 0&, "Combobox", vbNullString)

        childret = FindWindowEx(combo, ByVal 0&, "Edit", vbNullString)

        If childret <> 0 Then
            'MsgBox "TextBox's Window Found"
            '~~> This is where we send the filename to the Text Window
            SendMess upfile, childret

            DoEvents

            '~~> Get the handle of the Button's "Window"
           
            childret = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)

            '~~> Check if we found it or not
            If childret <> 0 Then
                'MsgBox "Button's Window Found"

                '~~> Get the caption of the child window
                strBuff = String(GetWindowTextLength(childret) + 1, Chr$(0))
                GetWindowText childret, strBuff, Len(strBuff)
                ButCap = strBuff

                '~~> Loop through all child windows
                Do While childret <> 0
                    '~~> Check if the caption has the word "OK"
                    If InStr(1, ButCap, bcap) Then
                        '~~> If this is the button we are looking for then exit
                        openret = childret
                        Exit Do
                    End If

                    '~~> Get the handle of the next child window
                    childret = FindWindowEx(Ret, childret, "Button", vbNullString)
                    '~~> Get the caption of the child window
                    strBuff = String(GetWindowTextLength(childret) + 1, Chr$(0))
                    GetWindowText childret, strBuff, Len(strBuff)
                    ButCap = strBuff
                Loop

                '~~> Check if we found it or not
                If openret <> 0 Then
                    '~~> Click the OK Button
                    SendMessage childret, BM_CLICK, 0, vbNullString
                    s = "Window closed"
                Else
                    s = "The Handle of OK Button was not found"
                End If
            Else
                s = "Button's Window Not Found"
            End If
        Else
            s = "The Edit Box was not found"
        End If
    Else
        s = "Dialog Window was not Found"
    End If
Loop
'MsgBox s
End Sub

Sub SendMess(Message As String, HWnd As Long)
    Call SendMessage(HWnd, WM_SETTEXT, False, ByVal Message)
End Sub

this can then be shelled from any other code VB6, VBA and possibly VBS
using code like
Code:

Private Sub Command1_Click()
Dim wb As Object, params As String
Set wb = CreateObject("internetexplorer.application")
wb.navigate2 somesite  ' with file input element
wb.Visible = True
upfile = "c:\temp\list1.txt"  file path to upload
params = """C:\Documents and Settings\user\timerclosedialog\closefiledialog2.exe"" ""Choose File to Upload-&Open-" & upfile & """"
'change path\filename above to the exe where you compile it
' change dialog caption and button caption if required
Shell params
DoEvents
wb.document.All("uploadedfile").Click    ' change to file input element on form
' end of testing, no further code used here
End Sub

you must shell the executable before displaying the dialog
the arguments passed when shelling the exe are separated by a - (spaces are not required, but will be ignored if present), 3 arguments are required, with an optional time out value
arguments are:-
dialog caption
button caption
filename to pass to dialog
timeout (optional)

dialog and button captions are language dependent and may possibly vary on other factors, which is why i made them to be passed as arguments

originally from http://www.vbforums.com/showthread.p...t=close+dialog

Increase Stack Size in a Vb6 exe

$
0
0
I want to share my method to increase stack suze for VB6. (I need that for M2000 Interpreter, so now I can calll 14500 times the same function...in m2000 (so more in vb6 inside))
I made a bat file, and all we need is the editbin.exe from Masm32.
I checked also in a signed version of m2000.exe, and the sign is ok after the stack increase.
Here we get more than 100Mbyte (but not all is used, only commited, as achunk of continues memory.

Echo off
Cls
Echo Set Stack Size for M2000 - press enter
C:\masm32\bin\editbin /stack:108000000 m2000.exe

enable / disable backspace

$
0
0
I guys ..... plz solve my prob.

I have a textbox .... and in text change event i put following code :
Code:

If Len(Trim(txtTyping.Text)) > 0 Then
        If KeyAscii = 8 Then
            If Asc(Right(txtTyping.Text, 1)) = 32 Then
                KeyAscii = 0
            Else
                KeyAscii = KeyAscii
            End If
        End If
    End If

By this code i disable the backspace after space. However, i need that user may be allow to use backspace after space also. For this, i want add a command button to Enable / Disable backspace.
Please guide how to implement this
Thanks in advance :

[VB6] Code Snippet: View shortcut path w/variables unexpanded: IShellLinkDataList

$
0
0
Shortcuts are actually far more complex than most people realize even after dealing with the IShellLink interface. The really technical bits are hidden behind a whole other interface: IShellLinkDataList.

Windows shortcuts and shortcuts placed by some programs allow the path to refer to a special location that might vary: for example, the Windows Media Player start menu shortcut on Windows 7 was actually created with a target of %ProgramFiles(x86)%\Windows Media Player\wmplayer.exe. Whether you click it, load its properties page, or call IShellLink's GetPath, the special Program Files reference will be expanded. But what if you want to see that original reference? Here I bring another article from the wonderful Old New Thing blog to VB6. As part of the code, you can also see all the SLDF_ flags associated with a link.

Requirements
-Windows XP or higher
-oleexp 3.51 or newer (released with this code on 9 May 2016; 3.5 will NOT work); oleexp3.tlb must be added under Project-References, but it's an IDE-only requirement- the typelib does not need to be distributed with the compiled EXE.

The Code
Code:

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Sub ShowLinkInfo(sLink As String)
'sLink must include .lnk suffix (hidden even when 'show extensions' is enabled)
'e.g. C:\folder\Shortcut to MyProgram.exe.lnk

Dim psdi As IShellLinkDataList
Dim pLNK As ShellLinkW
Dim ppf As IPersistFile
Set pLNK = New ShellLinkW
Set ppf = pLNK
ppf.Load sLink, STGM_READ
Set psdi = pLNK
Dim dwFlg As SHELL_LINK_DATA_FLAGS
psdi.GetFlags dwFlg
Debug.Print "flags=" & Hex$(dwFlg)

If (dwFlg And SLDF_HAS_EXP_SZ) Then
    Debug.Print "has exp_sz"
    Dim tEXP As EXP_SZ_LINK
    Dim ltPtr As Long
    psdi.CopyDataBlock EXP_SZ_LINK_SIG, ltPtr
    If ltPtr Then
        Debug.Print "got non-zero ptr"
        CopyMemory tEXP, ByVal ltPtr, LenB(tEXP)
       
        Debug.Print "struct size=" & tEXP.cbSize & ",sig=" & Hex$(tEXP.dwSignature)
        Debug.Print "str=" & WCHARtoSTR(tEXP.swzTarget)
    Else
        Debug.Print "no ptr to tEXP"
    End If
Else
    Debug.Print "no flag match"
End If
End Sub

Public Function WCHARtoSTR(aCh() As Integer) As String
Dim i As Long
Dim sz As String
For i = LBound(aCh) To UBound(aCh)
    If aCh(i) <> 0 Then
        sz = sz & ChrW(CLng(aCh(i)))
    End If
Next
WCHARtoSTR = sz
End Function

(Note: I tried copying directly into the struct by passing tEXP or trying ByVal VarPtr(tEXP); but both resulted in the value of the memory pointer being shoved into the .cbSize member.)

You can set flags and add/delete data blocks as well, look for a far more advanced demo of this interface in the future.

[VB6] Code Snippet: Make your shortcuts request elevation with IShellLinkDataList

$
0
0
This is related to my other recent post on this interface, [VB6] Code Snippet: View shortcut path w/variables unexpanded: IShellLinkDataList.

Making shortcuts to your program for Run As Administrator requires diving into the highly technical IShellLinkDataList, which is implemented by shortcut objects in addition to the IShellLink interface that is usually all you need. But shortcuts have many advanced flags and data blocks that aren't exposed by IShellLink-- look for more uses of this interface in the future.

Requirements
-Windows XP or higher
-oleexp 3.51 or newer (released with this code on 9 May 2016; 3.5 will NOT work); oleexp3.tlb must be added under Project-References, but it's an IDE-only requirement- the typelib does not need to be distributed with the compiled EXE.

The Code
It's a bit easier this time:
Code:

Public Sub MakeLinkElevated(sLink As String)

'sLink must include .lnk suffix (hidden even when 'show extensions' is enabled)
'e.g. C:\folder\Shortcut to MyProgram.exe.lnk
On Error GoTo e0
Dim psdi As IShellLinkDataList
Dim pLNK As ShellLinkW
Dim ppf As IPersistFile
Set pLNK = New ShellLinkW
Set ppf = pLNK
ppf.Load sLink, STGM_READWRITE
Set psdi = pLNK
Dim dwFlg As SHELL_LINK_DATA_FLAGS
psdi.GetFlags dwFlg
Debug.Print "flags=" & Hex$(dwFlg)

If (dwFlg And SLDF_RUNAS_USER) Then
    Debug.Print "Already elevated."
Else
    Debug.Print "Setting flag..."
    dwFlg = dwFlg Or SLDF_RUNAS_USER
    psdi.SetFlags dwFlg
    ppf.Save sLink, 1
End If
Exit Sub
e0:
Debug.Print "MakeLinkElevated.Error->" & Err.Description
End Sub

[VB6][vbRichClient] Slither-like Game

$
0
0
Hi, on free time just for fun I wrote this Slither-Like Game
Enjoy!


I don't know how to play Multiple sounds at same time.
(I mean to play even same sound with a slight delay)
I found a Module: "SoundManager" that on win-XP works like a charm
But on Vista it do not works

To Play a sound it's used my "MyPlaySound"

On vista I changed a little bit FreeBuffer Sub like this:
Code:

'        If Buffers(Index).status = BufferEmpty Then  '''' On XP works perfectlty
        If Buffers(Index).status <> BufferPlaying Then '''' On Vista a little better (it seems not not works CALLBACK)

and it works a little better but not as good as on XP. If someone could help.


DownLoad ZIP

Getting OS, Ram, CPU information

$
0
0
Over the years I have used many methods for getting the above information. None have been entirely satisfactory or involved long code.

Recently I came across the WMI classes that are part of all Windows machines (certainly since XP) and make the job quite simple.

Here is a quick demo with a very simple presentation via a Message box. I urge you to investigate for yourselves all the classes available.

All my tests have been on Win10, so I would be grateful if others would report their findings.

Code:

Option Explicit

Private Sub Form_Load()
    Dim Results As Object, Info As Object, PCInfo As String, Ram As String, TotMem As Long

    ' Get the Memory information. For more information from this query, see: https://msdn.microsoft.com/en-us/library/aa394347(v=vs.85).aspx
    Set Results = GetObject("Winmgmts:").ExecQuery("SELECT Capacity FROM Win32_PhysicalMemory")
    For Each Info In Results
        TotMem = TotMem + (Info.Capacity / 1073741824) 'Capacity returns the size separately for each stick in bytes. Therefore we loop and add whilst dividing by 1GB.
    Next Info

    ' Get the O.S. information. For more information from this query, see: https://msdn.microsoft.com/en-us/library/aa394239(v=vs.85).aspx
    Set Results = GetObject("Winmgmts:").ExecQuery("SELECT Caption,Version,ServicePackMajorVersion,ServicePackMinorVersion,OSArchitecture,TotalVisibleMemorySize FROM Win32_OperatingSystem")
    For Each Info In Results 'Info.Version can be used to calculate Windows version. E.G. If Val(Left$(Info.Version,3)>=6.1 then it is at least Windows 7.
        PCInfo = Info.Caption & " - " & Info.Version & "  SP " & _
            Info.ServicePackMajorVersion & "." & _
            Info.ServicePackMinorVersion & "  " & Info.OSArchitecture & "  " & vbNewLine
        Ram = "Installed RAM: " & Format$(TotMem, "0.00 GB (") & Format$(Info.TotalVisibleMemorySize / 1048576, "0.00 GB usable)") 'Divide by 1MB to get GB
    Next Info

    ' Get the C.P.U. information. For more information from this query, see: https://msdn.microsoft.com/en-us/library/aa394373(v=vs.85).aspx
    Set Results = GetObject("Winmgmts:").ExecQuery("SELECT Name,AddressWidth,NumberOfLogicalProcessors,CurrentClockSpeed FROM Win32_Processor")
    For Each Info In Results
        PCInfo = PCInfo & Info.Name & "  " & Info.AddressWidth & _
            "-bit." & vbNewLine & Info.NumberOfLogicalProcessors & _
            " Cores " & Info.CurrentClockSpeed & "MHz.  " & Ram
    Next Info

    Set Results = Nothing
    MsgBox PCInfo
End Sub

Attached Images
 

[VB6] Code Snippet: Load Language Specific resource String. FindResourceEx

$
0
0
This came up in another thread.
A lot of declarations out there for FindResourceEx for VB6 aren't too accurate, probably a relic of people still using APIViewer or the like.

FindStringResourceEx() was translated from the C routine by Raymond Chen.
https://blogs.msdn.microsoft.com/old...0-00/?p=40813/

And Delphi version from this blog.
https://wiert.me/2014/07/17/delphi-a...pecific-lcids/

Unicode Compliant.

Code:

Option Explicit

Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function FindResourceEx Lib "kernel32" Alias "FindResourceExW" (ByVal hModule As Long, ByVal lpType As Long, ByVal lpName As Long, ByVal wLanguage As Integer) As Long
Private Declare Function LoadResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Declare Function LockResource Lib "kernel32" (ByVal hResData As Long) As Long
Private Declare Function SysReAllocStringLen Lib "oleaut32" (ByVal pBSTR As Long, ByVal psz As Long, ByVal Length As Long) As Long
Private Declare Function GetMem2 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Const RT_STRING As Long = 6&

Private Property Get DUInt(ByVal Address As Long) As Long
    ' dereference a WORD* and copy to LOWORD of a Long
    GetMem2 ByVal Address, DUInt
End Property

'https://blogs.msdn.microsoft.com/oldnewthing/20040130-00/?p=40813/
Function FindStringResourceEx(ByVal hInstance As Long, uId As Long, langId As Long) As String
    Dim hResource As Long
    Dim hGlobal As Long
    Dim pwsz As Long, i As Long
    Const STRINGS_PER_BUCKET As Long = 16&
   
    hResource = FindResourceEx(hInstance, RT_STRING, uId \ STRINGS_PER_BUCKET + 1, langId)
    If (hResource) Then
        hGlobal = LoadResource(hInstance, hResource)
        If (hGlobal) Then
            pwsz = LockResource(hGlobal)
            If (pwsz) Then
                For i = 1 To (uId And (STRINGS_PER_BUCKET - 1))
                    pwsz = pwsz + 2 + 2 * DUInt(pwsz)
                Next
                SysReAllocStringLen VarPtr(FindStringResourceEx), pwsz + 2, DUInt(pwsz)
            End If
        End If
    End If
End Function

Private Sub Form_Click()
    Const YES_CAPTION = 805
    Const LANG_ID_ENGLISH_US = 1033
   
    Dim hModule As Long
    hModule = LoadLibrary(StrPtr("user32"))
    If (hModule) Then
        Debug.Print FindStringResourceEx(hModule, YES_CAPTION, 1033)
        FreeLibrary hModule
    End If
End Sub

VB6: Windows 10 Known Folders / SHGetKnownFolderPath

$
0
0
Download the bas module here: basKnownFolders.bas


In Windows XP, the recommended practice to find special folders was to call SHGetFolderPath(), but this was deprecated starting in Windows Vista. From Vista on, we're supposed to use SHGetKnownFolderPath(). Unfortunately, it's extremely hard to find easy-to-use code for SHGetKnownFolderPath without having to add unnecessary references or components to your project. (typelibs, or scripting objects.)

Thanks to Randy Birch's excellent sample code, here's an easy-to-use module that lets you identify special folders using API calls, no references or components needed. Simply add the attached module to your project, then call the following function:

?KnownFolder(enumerated value)

You can call the following from the debug window to see a list of known folders and their values:

KnownFolderList


The module contains two compiler directives:
Code:

#Const IncludeVirtualFolders = False
#Const IncludeDebugListing = True

Of the 88 total known folders, only 54 return any value for me. The rest are listed as virtual folders by Randy Birch's sample project. I've moved these 34 virtual folders to the end of the enumeration and wrapped them in compiler directives, letting you easily prevent them from being included. This helps reduce clutter in the enumeration dropdown.

The second compiler directive lets you discard the KnownFoldersList() debug window output routines to reduce the size of the code in your finished project.

Here's a the known folder enumeration for reference:
Code:

Public Enum KnownFolderEnum
    kfUserProfiles
    kfUser
    kfUserDocuments
    kfUserContacts
    kfUserDesktop
    kfUserDownloads
    kfUserMusic
    kfUserPictures
    kfUserSavedGames
    kfUserVideos
    kfUserAppDataRoaming
    kfUserAppDataLocal
    kfUserAppDataLocalLow
    kfUserCDBurning
    kfUserCookies
    kfUserFavorites
    kfUserGameTasks
    kfUserHistory
    kfUserInternetCache
    kfUserLinks
    kfUserNetHood
    kfUserPrintHood
    kfUserQuickLaunch
    kfUserRecent
    kfUserSavedSearches
    kfUserSendTo
    kfUserStartMenu
    kfUserStartMenuAdminTools
    kfUserStartMenuPrograms
    kfUserStartMenuStartup
    kfUserTemplates
    kfPublic
    kfPublicDesktop
    kfPublicDocuments
    kfPublicDownloads
    kfPublicMusic
    kfPublicPictures
    kfPublicVideos
    kfPublicStartMenu
    kfPublicStartMenuAdminTools
    kfPublicStartMenuPrograms
    kfPublicStartMenuStartup
    kfPublicGameTasks
    kfPublicTemplates
    kfProgramData
    kfWindows
    kfSystem
    kfSystemX86
    kfSystemFonts
    kfSystemResourceDir
    kfProgramFilesX86
    kfProgramFilesCommonX86
    kfProgramFiles
    kfProgramFilesCommon
#If IncludeVirtualFolders = True Then
    kfAddNewPrograms
    kfAppUpdates
    kfChangeRemovePrograms
    kfCommonOEMLinks
    kfComputerFolder
    kfConflictFolder
    kfConnectionsFolder
    kfControlPanelFolder
    kfGames
    kfInternetFolder
    kfLocalizedResourcesDir
    kfNetworkFolder
    kfOriginalImages
    kfPhotoAlbums
    kfPlaylists
    kfPrintersFolder
    kfProgramFilesX64
    kfProgramFilesCommonX64
    kfRecordedTV
    kfRecycleBinFolder
    kfSampleMusic
    kfSamplePictures
    kfSamplePlaylists
    kfSampleVideos
    kfSEARCH_CSC
    kfSEARCH_MAPI
    kfSearchHome
    kfSidebarDefaultParts
    kfSidebarParts
    kfSyncManagerFolder
    kfSyncResultsFolder
    kfSyncSetupFolder
    kfTreeProperties
    kfUsersFiles
#End If
#If IncludeDebugListing = True Then
    kfKnownFolders
#End If
End Enum

Attached Files

VB6 RC5-CoreAudio-Demo

$
0
0
Here a small CoreAudio-Example, based on the appropriate abstraction-Classes of the RichClient.
(as mentioned and requested in this thread): http://www.vbforums.com/showthread.p...ther-like-Game

CoreAudio was introduced as the new (LowLevel) SoundAPI for Win-Versions from Vista onwards.

It allows such things as "InApp-Session-VolumeControl, Soundbuffer-reading and -writing, Enumeration of
Sound-Devices, Fine-Control over each of the channels of e.g. a "5+1" SoundCard etc...

The Read-direction of CoreAudio-SoundBuffers I've already covered in this older example here:
http://www.vbforums.com/showthread.p...and-onwards%29
(visualizing the Buffer-Input, which comes in over: ...GetDefaultAudioEndpoint(eCapture, eCommunications) -> usually the microphone).

This example here is focusing on demonstrating the handling of "InApp-SoundVolume/Muting" -
and the SoundRendering of 4 smaller SoundBuffers (which reside as *.mp3 in the Apps \Res\-SubFolder).
Here the Zip: CoreAudioDemo.zip

With relatively low efforts, one could expand on this Demo, to e.g. implement a nice
"Piano-Roll-like Sequencer" - or something alike (as seen in some Phone- or -Tablet-Apps, that cover
simple "SoundLoop-Pattern-Mixers" which support live-changes of "correctly fitted" Sample-Loops).

Here's a ScreenShot, what the Demo currently looks like:


The 4 SoundSample-Player-Widgets to the right of the above Form can be:
- in case of the Top-Widget, labelled 'SampleLoop' - switched On and Off permanently
- and the lower three Sound-Widgets are in "Tap-Mode" (acting more like a little Drum-Kit)

So you can Switch-On the TopMost Sound - it will be in repeat-mode by default -
and then you can add sound by "tapping" the other three (if you keep the Mouse down,
the 3 Tap-Widgets will repeat themselves in a timely fashion).

So, whilst the right part of the above ScreenShot demonstrates the CoreAudio-SoundBuffer-Handling,
the left part of the Screen (the rotating Knob-Widget) demonstrates the interaction with:
- cSimpleAudioVolume (responsible for interaction with the InApp-SoundLevel and InApp-Muting)
- cAudioMeterInformation (responsible for the Peak-Meter-Visualization at the bottom of the Knob).

This InApp-AudioVolume-Handling works in a "two-way-fashion", since it is also present in
the new WinSystem-Mixer-Dialogues:


In the above ScreenShot, the focused Entry labeled "CoreAudioDemo" allows to
control your InApp-SoundVolume/Muting as well - and should be properly reflected
in the appropriate Control of your App, so that both GUI-interactions remain "synced"
(the Knob reflecting the Settings of the System-Dialogue, and vice versa).



The cSimpleAudioVolume-Class of the RC5 offers the needed Events for that kind of
two-way interaction.

But take a look at the code yourself, play around a bit - and just ask when something is not clear.

Have fun!

Olaf
Attached Files

[VB6, Vista+] Core Audio Basics

$
0
0

Core Audio Demos

A few days ago I released the latest version of my oleexp typelib containing all of the Core Audio interfaces. Here's a demo of some of the basic features.

All of the functions shown in the above screenshot work, and additionally the 'Mute Default Multimedia Device' button also demonstrates how to set a callback for that device-- if any other app, like the volume mixer, then unmutes or does something else with that device, your app will be notified of the change. Note that all interfaces used for the callback must be module-level and not released while the callback is active, otherwise your app will freeze.

Requirements
-Windows Vista or higher
-oleexp v3.6 (released 16 May 2016): Add oleexp3.tlb as a reference-- for IDE only, does not need to be redistributed with compiled app.
-All 3 oleexp addons: mCoreAudio.bas, mIID.bas, and mPKEY.bas (all of which are now included in main oleexp download, and all were updated with v3.6 with Core Audio related code. They're also included in this project's zip, although oleexp3.tlb is not).

Code Example: Muting all active capture devices (e.g. microphones)
Code:

Dim sOut As String
Dim i As Long
Dim lp As Long
Dim s1 As String
Dim sName As String

Dim pDvEnum As MMDeviceEnumerator
Set pDvEnum = New MMDeviceEnumerator

Dim pDvCol As IMMDeviceCollection

pDvEnum.EnumAudioEndpoints eCapture, DEVICE_STATE_ACTIVE, pDvCol

If (pDvCol Is Nothing) = False Then
    Dim nCount As Long
    Dim pDevice As IMMDevice
    If pDvCol.GetCount(nCount) = S_OK Then
        If nCount > 0 Then
            For i = 0 To (nCount - 1)
                sName = GetDeviceName(pDvCol, i)
                sOut = sOut & "Muting Device(" & i & ", Name=" & sName & ")..." & vbCrLf
                pDvCol.Item i, pDevice
                If (pDevice Is Nothing) = False Then
                    Dim pAEV As IAudioEndpointVolume
                    pDevice.Activate IID_IAudioEndpointVolume, CLSCTX_INPROC_SERVER, CVar(0), pAEV
                    If (pAEV Is Nothing) = False Then
                        If pAEV.SetMute(1, UUID_NULL) = S_OK Then
                            sOut = sOut & "...Device successfully muted!" & vbCrLf
                        Else
                            sOut = sOut & "...Failed to mute device " & i & " (" & sName & "). Already muted?" & vbCrLf
                        End If
                    Else
                        Debug.Print "Failed to set pAEV"
                        sOut = sOut & "...An error occured accessing the volume control." & vbCrLf
                    End If
                Else
                    Debug.Print "Failed to set pDevice"
                    sOut = sOut & "...Failed to get pointer to device." & vbCrLf
                End If
            Next
        Else
            sOut = "No active devices found." & vbCrLf
        End If
    Else
        Debug.Print "Failed to get device count."
        sOut = sOut & "An error occured getting the device count." & vbCrLf
    End If
Else
    Debug.Print "Failed to set pDvCol"
    sOut = "Failed to get device collection (no active devices or an error occured)"
End If
Text1.Text = sOut

Attached Files

[VB6] Loader, shellcode, without runtime...

$
0
0
Hello everyone! Today i want to show you the quite interesting things. One day i was investigating the PE (portable executable) file format especially EXE. I decided to create a simple loader of the executable files specially for VB6-compiled applications. This loader should load an VB6-compiled exe from the memory without file. THIS IS JUST FOR THE EXPERIMENTAL PURPOSES IN ORDER TO CHECK POSSIBILITIES OF VB6. Due to that the VB6-compiled applications don't used most of the PE features it was quite simple objective. Most of programers says that a VB6-apllication is linked with the VB6 runtime (MSVBVM), a VB6 application doesn't work without the runtime and the runtime is quite slow. Today i'll prove that it is possible to write an application that absolutely doesn't use runtime (although i was already doing that in the driver). These projects i had written quite a long time ago, but these were in the russian language. I think it could be quite interesting for someone who wants to examine the basic principles of work with the PE files.
Before we begin i want to say couple words about the projects. These projects were not tested well enough therefore it can cause problems. The loader doesn't support most of the features of PE files therefore some executables may not work.
So...
This overview consists three projects:

  1. Compiler - it is the biggest project of all. It creates an installation based on the loader, user files, commands and manifest;
  2. Loader - it is the simple loader that performs commands, unpacks files and runs an executable from memory;
  3. Patcher - it is the small utility that removes the runtime import from an executable file.

I call an exe that contains the commands, files and executable file the installation. The main idea is to put the information about an installation to the resources of the loader. When the loader is being loaded it reads the information and performs the commands from resources. I decided to use an special storage to save the files and exe, and other storage for commands.
The first storage stores all the files that will be unpacked, and the main executable that will be launched. The second storage stores the commands that will be passed to the ShellExecuteEx function after unpacking process will have been completed. The loader supports the following wildcards (for path):

  1. <app> - application installed path;
  2. <win> - system windows directory;
  3. <sys> - System32 directory;
  4. <drv> - system drive;
  5. <tmp> - temporary directory;
  6. <dtp> - user desktop.

Compiler.


Name:  Compiler.png
Views: 79
Size:  20.5 KB

This is the application that forms the installation information and puts it to the loader resource. All the information is stored in a project. You can save and load a project from file. The clsProject class in VB project represents the compiler-project. This compiler has 3 sections: storage, execute, manifest.
The 'storage' section allows to add the files that will be copied when the application is being launched. Each item in the list has flags: 'replace if exists', 'main executable', 'ignore error'. If you select 'replace if exists' flag a file will be copied even if one exists. The 'main executable' flag can be set only for the single executable file. It means that this file will be launched when all the operations have been performed. The 'ignore error' flag makes ignore any errors respectively. The order in the list corresponds the order of extracting the files except the main executable. The main executable is not extracted and is launched after all the operations. The storage section is represented as clsStorage class in the VB project. This class implements the standard collection of the clsStorageItem objects and adds some additional methods.The MainExecutable property determines the index of main executable file in the storage. When this parameter equal -1 executable file is not presented. The clsStoragaItem class represent the single item in the storage list. It has some properties that determine the behavior of item. This section is helpful if you want to copy files to disk before execution of the application.
The next section is the 'execute'. This section allows execute any commands. This commands just pass to ShellExecuteEx function. Thus you can register libraries or do something else. Each item in the execution list has two properties: the executable path and parameters. Both the path and the parameters is passed to ShellExecuteEx function. It is worth noting that all the operations is performed synchronously in the order that set in the list. It also has the 'ignore error' flag that prevents appearance any messages if an error occurs. The execute section is represented as two classes: clsExecute and clsExecuteItem. These classes are similar to the storage classes.
The last section is 'manifest'. It is just the manifest text file that you can add to the final executable. You should check the checkbox 'include manifest' in the 'manifest' tab if you wan to add manifest. It can be helpful for Free-Reg COM components or for visual styles.
All the classes refer to the project object (clsProject) that manages them. Each class that refers to project can be saved or loaded to the PropertyBag object. When a project is being saved it alternately saves each entity to the property bag, same during loading. It looks like a IPersistStream interface behavior. All the links to the storage items in the project is stored with relative paths (like a VB6 .vbp file) hence you can move project folder without issues. In order to translate from/to relative/absolute path i used PathRelativePathTo and PathCanonicalize functions.
So... This was basic information about compiler project. Now i want to talk about compilation procedure. As i said all the information about extracting/executing/launching is stored to the loader resources. At first we should define the format of the data. This information is represented in the following structures:
Code:

' // Storage list item
Private Type BinStorageListItem
    ofstFileName        As Long            ' // Offset of file name
    ofstDestPath        As Long            ' // Offset of file path
    dwSizeOfFile        As Long            ' // Size of file
    ofstBeginOfData    As Long            ' // Offset of beginning data
    dwFlags            As FileFlags      ' // Flags
End Type

' // Execute list item
Private Type BinExecListItem
    ofstFileName        As Long            ' // Offset of file name
    ofstParameters      As Long            ' // Offset of parameters
    dwFlags            As ExeFlags        ' // Flags
End Type

' // Storage descriptor
Private Type BinStorageList
    dwSizeOfStructure  As Long            ' // Size of structure
    iExecutableIndex    As Long            ' // Index of main executable
    dwSizeOfItem        As Long            ' // Size of BinaryStorageItem structure
    dwNumberOfItems    As Long            ' // Number of files in storage
End Type

' // Execute list descriptor
Private Type BinExecList
    dwSizeOfStructure  As Long            ' // Size of structure
    dwSizeOfItem        As Long            ' // Size of BinaryExecuteItem structure
    dwNumberOfItems    As Long            ' // Number of items
End Type

' // Base information about project
Private Type BinProject
    dwSizeOfStructure  As Long            ' // Size of structure
    storageDescriptor  As BinStorageList  ' // Storage descriptor
    execListDescriptor  As BinExecList    ' // Command descriptor
    dwStringsTableLen  As Long            ' // Size of strings table
    dwFileTableLen      As Long            ' // Size of data table
End Type

The 'BinProject' structure is located at beginning of resource entry. Notice that project is stored as RT_RCDATA item with 'PROJECT' name. The dwSizeOfStructure field defines the size of the BinProject structure, storageDescriptor and execListDescriptor represent the storage and execute descriptors respectively. The dwStringsTableLen field shows the size of strings table. The strings table contains all the names and commands in the unicode format. The dwFileTableLen field shows the size of all data in the storage. Both storage (BinStorageList) and execute list (BinExecList) have dwSizeOfItem and dwSizeOfStructure fields that define the size of a descriptor structure and the size of a list item. These structures also have dwNumberOfItems field that shows how many items is contained in the list. The 'iExecutableIndex' field contains the index of executable file that will be launched. The common structure of a project in the resources is shown in this figure:
Name:  BinProject.png
Views: 77
Size:  60.3 KB
An item can refers to the strings table and file table for this purpose it uses the offset from beginning of a table. All the items is located one by one. Okay, you have explored the internal project format now i tell how can you build the loader that contains these data. As i said we store data to resources of the loader. I will tell about the loader a little bit later now i want to note one issue. When you put the project data to resources it doesn't affect to exe information. For example if you launch this exe the information contained in the resources of the internal exe won't be loaded. Same with icons and version information. You should copy the resources from the internal exe to loader in order to avoid this troubles. WinAPI provides the set of the functions for replacing resources. In order to obtain the list of resources you should parse the exe file and extract data. I wrote the 'LoadResources' function that extract all the resources of specified exe data to array.
Attached Images
  

[VB6] TrickSound - class for working with audio.

$
0
0

Hi everyone!
I've created the new version of my clsTrickSound class that i used in the vocoder project. This class provides the simple interface to playback and capture sound. It doesn't require any dependencies and works autonomously. This class has the NewData event that is raised when the internal buffer with sound data has been filled or a device requires the new part of sound data. In order to playback sound you should call the InitPlayback function, to capture - InitCapture. Then you should call StartProcess in order to begin playback/capture. I've made the two examples of the usage of this class: simple synthesizer and simple recorder. Thanks for attention.
Regards,
Кривоус Анатолий (The trick).
Attached Files

Windowless Buttons

$
0
0
Typically, buttons (or any other control for that matter) in VB6 are windows, who's window function is designed to handle clicks. Each window has its own handle called an hWnd. However, this has some downsides, particularly when it comes to security. This is because windows can be "hooked" by malware which can then check to see when you click on a button. If the malware is advanced enough it can hook all the events in all the windows, allowing the hacker who's receiving the info from the malware to tell exactly what windows are being clicked, typed in, etc. This allows them to literally map out every moment of your computer usage. For example, it allows them to tell not only what is being typed at any given moment, but also that the fact that what you typed is in a password box (if the text in the titlebar of the window is "password"), so as to clue them in on the importance of what is being typed (in this example, the fact that it is a password).

This is where my sample program comes into play. It prevents malware from determining every single minutia of what you are doing on your computer, by making all of the activity on the window (as far as malware that hooks hWnds is concerned) to all be happening on the same window, preventing a significant amount of information from being leaked from your computer to a hacker. It does this by implementing windowless controls (buttons in this sample program, but I could also extend it to windowless text boxes, check boxes, etc, if given enough time to code all of that). It works by allowing each button to have its own instance of a class called NonWndButton. The only hWnd in the entire program is the one for Form1. This significantly obfuscates the activity that the user performs on the form.


Here's a description of each of the code files in this program.
Windowless Button.frm: This is the form for the program, and has all the code to handle user interactions, as well as an implementation of the NonWndButtonCallback interface.

NonWndButton.cls: This is the class that has code for just drawing the button and handling events.

NonWndButtonCallback.cls: This is actually an interface, that must be implemented in the form (Form1 in my program). This allows for callbacks from the button class so that code for handling what each button does can be directly coded in the form, rather than in the separate class file for the buttons.

modNonWndButton.bas: This is the module file that handles the framework for the buttons, including a method for adding buttons (button class instances) to the Buttons collection which is also contained in this module, as well as one for redrawing the buttons, which is necessary after a screen clearing (as happens when the Cls method). If you wanted to clear text or other graphics on the screen via Cls, but keep the buttons (as these are the main controls now), you absolutely need to be able to redraw them. Also in this module is a method for scanning the buttons when a click occurs on the form, to determine which button actually got clicked, so as to trigger ButtonUp or ButtonDown event of the correct instance of the button class.

GdiModule.bas: This contains declarations and methods needed to perform the basics of drawing text and rectangles. This is necessary for actually rendering the buttons on the screen.



Attached to this post is a zip file containing the complete source code, including the vbp project file and vbw project layout file.
Attached Files

[VB6] Palettize - A VB6 Class for converting StdPicture to 8-bit StdPicture

$
0
0
The main reason you might want this is for creating an 8-bit color or grayscale StdPicture from a StdPicture created by loading an image file. An 8-bit color StdPicture may save "smaller" as a BMP file if required.

Since this also tends to result in a "posterized" image due to the simplistic color quantization algorithm used here, 8-bit color StdPicture creation also handles color depths from 32-colors to the default 256-colors. This might be useful if your goal is posterization or you want an even smaller saved image, but otherwise it is usually pointless.

This is written entirely in VB6 and doesn't require any 3rd party DLLs or even TLBs. It also runs pretty fast.

There are two methods, one for color and one for grayscale (and yes, if you prefer to spell it "grey" feel free to do a replace on the source code). ;)


Palettize.cls is a VB_PredeclaredId = True class, so you do not need to create instances of it to use it. It also depends on the included OList.cls for color palette processing though that helper class is not needed if you delete all of the color processing to keep just the grayscale processing.

There is also a PicSave.cls included in the demo. This is also a VB_PredeclaredId = True class. It can be used to save a StdPicture as BMP, GIF, JPEG, or PNG. Palettize.cls does not need this. You'd only use this sort of thing to save in more formats than just BMP (via plain old VB6 SavePicture).


Name:  sshot.jpg
Views: 31
Size:  36.4 KB

Screenshot of the demo Project


It can benefit from native-compilation optimizations and this demo has the relevant ones turned on. Compile the Project and test the EXE to see it run at full speed.

Most of the size of the attachment is due to a pair of "photographic" sample images. You could change the program to load different images, or replace the two samples by your own for further testing. The demo is just something to test with.

Actual usage is simple: Add OList.cls and Palettize.cls to your VB6 Project. Add PicSave.cls if you want to use that too. Then you can just call the methods of the global predeclared instance Palettize, passing a StdPicture argument and getting a new StdPicture back as the return value.
Attached Images
 
Attached Files

[VB6] Full Screen a Form

$
0
0
This class was converted from the Chromium project.

CFullScreenHandler.cls
Code:

' Chromium full_screen_handler.h/.cc converted to VB6
' CFullScreenHandler.cls
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' WIN32 API
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function IsZoomed Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_SYSCOMMAND As Long = &H112
Private Const SC_RESTORE As Long = &HF120&
Private Const SC_MAXIMIZE As Long = &HF030&
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_STYLE As Long = -16
Private Const GWL_EXSTYLE As Long = -20
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Const WS_CAPTION As Long = &HC00000
Private Const WS_THICKFRAME As Long = &H40000
Private Const WS_EX_DLGMODALFRAME As Long = &H1&
Private Const WS_EX_WINDOWEDGE As Long = &H100&
Private Const WS_EX_CLIENTEDGE As Long = &H200&
Private Const WS_EX_STATICEDGE As Long = &H20000
Private Type MONITORINFO
    cbSize As Long
    rcMonitor As RECT
    rcWork As RECT
    dwFlags As Long
End Type
Private Declare Function MonitorFromWindow Lib "user32" (ByVal hWnd As Long, ByVal dwFlags As Long) As Long
Private Declare Function GetMonitorInfo Lib "user32" Alias "GetMonitorInfoW" (ByVal hMonitor As Long, lpmi As Any) As Long
Private Const MONITOR_DEFAULTTONEAREST As Long = &H2
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 uFlags As Long) As Long
Private Const SWP_HIDEWINDOW As Long = &H80
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOREPOSITION As Long = &H200
Private Const SWP_NOOWNERZORDER As Long = &H200
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOZORDER As Long = &H4
Private Const SWP_NOACTIVATE As Long = &H10&
Private Const SWP_FRAMECHANGED As Long = &H20

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Type SavedWindowInfo
    Maximized  As Boolean
    Style      As Long
    ExStyle    As Long
    WindowRect  As RECT
End Type

Private WithEvents m_Parent As Form
Private m_hWnd              As Long
Private m_FullScreen        As Boolean
Private m_MetroSnap        As Boolean
Private m_SavedWindowInfo  As SavedWindowInfo

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Class Implementation
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Class_Initialize()
    m_hWnd = GetActiveWindow()
End Sub

Public Function Init(Parent As Form, Optional HandleEscapeF11 As Boolean) As CFullScreenHandler
    If HandleEscapeF11 Then Set m_Parent = Parent
    m_hWnd = Parent.hWnd
    Set Init = Me
End Function

Public Property Let hWnd(Value As Long)
    m_hWnd = Value
End Property

Public Property Get FullScreen() As Boolean
    FullScreen = m_FullScreen
End Property

Public Property Let FullScreen(Value As Boolean)
    If (m_FullScreen = Value) Then Exit Property
    Call SetFullscreenImpl(Value, False)
End Property

Public Property Get MetroSnap() As Boolean
    MetroSnap = m_MetroSnap
End Property

Public Property Let MetroSnap(Value As Boolean)
    If (m_MetroSnap = Value) Then Exit Property
    Call SetFullscreenImpl(Value, True)
    m_MetroSnap = Value
End Property

Private Sub SetFullscreenImpl(ByVal FullScreen As Boolean, ByVal ForMetro As Boolean)
    'ScopedFullscreenVisibility visibility(hwnd_);  'Chrome's Multiple FullScreen handling not Implemented!

    ' Save current window state if not already fullscreen.
    If (Not m_FullScreen) Then
        ' Save current window information.  We force the window into restored mode
        ' before going fullscreen because Windows doesn't seem to hide the
        ' taskbar if the window is in the maximized state.
        m_SavedWindowInfo.Maximized = IsZoomed(m_hWnd)
       
        If (m_SavedWindowInfo.Maximized) Then _
            Call SendMessage(m_hWnd, WM_SYSCOMMAND, SC_RESTORE, ByVal 0&)
        m_SavedWindowInfo.Style = GetWindowLong(m_hWnd, GWL_STYLE)
        m_SavedWindowInfo.ExStyle = GetWindowLong(m_hWnd, GWL_EXSTYLE)
        Call GetWindowRect(m_hWnd, m_SavedWindowInfo.WindowRect)
    End If
   
    m_FullScreen = FullScreen
   
    If (m_FullScreen) Then
        ' Set new window style and size.
        Call SetWindowLong(m_hWnd, GWL_STYLE, _
                          m_SavedWindowInfo.Style And Not (WS_CAPTION Or WS_THICKFRAME))
        Call SetWindowLong(m_hWnd, GWL_EXSTYLE, _
                          m_SavedWindowInfo.ExStyle And Not (WS_EX_DLGMODALFRAME Or _
                          WS_EX_WINDOWEDGE Or WS_EX_CLIENTEDGE Or WS_EX_STATICEDGE))
                         
        ' On expand, if we're given a window_rect, grow to it, otherwise do
        ' not resize.
        If (Not ForMetro) Then
            Dim mi As MONITORINFO
            mi.cbSize = LenB(mi)
            Call GetMonitorInfo(MonitorFromWindow(m_hWnd, MONITOR_DEFAULTTONEAREST), mi)
            With mi.rcMonitor
            Call SetWindowPos(m_hWnd, NULL_, .Left, .Top, .Right - .Left, .Bottom - .Top, _
                              SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_FRAMECHANGED)
            End With
        End If
    Else
        ' Reset original window style and size.  The multiple window size/moves
        ' here are ugly, but if SetWindowPos() doesn't redraw, the taskbar won't be
        ' repainted.  Better-looking methods welcome.
        Call SetWindowLong(m_hWnd, GWL_STYLE, m_SavedWindowInfo.Style)
        Call SetWindowLong(m_hWnd, GWL_EXSTYLE, m_SavedWindowInfo.ExStyle)
       
        If (Not ForMetro) Then
            ' On restore, resize to the previous saved rect size.
            With m_SavedWindowInfo.WindowRect
            Call SetWindowPos(m_hWnd, NULL_, .Left, .Top, .Right - .Left, .Bottom - .Top, _
                              SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_FRAMECHANGED)
            End With
        End If
        If (m_SavedWindowInfo.Maximized) Then _
            Call SendMessage(m_hWnd, WM_SYSCOMMAND, SC_MAXIMIZE, ByVal 0&)
    End If
End Sub

Private Sub Class_Terminate()
    Set m_Parent = Nothing
End Sub

Private Sub m_Parent_KeyUp(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
    Case vbKeyEscape:  FullScreen = False
    Case vbKeyF11:      FullScreen = Not FullScreen
    End Select
End Sub

Form Code looks like this
Code:

Private m_fs    As New CFullScreenHandler

Private Sub Form_Initialize()
    m_fs.Init Me, True
End Sub

VB Multithread Library (Generic Multithreader)

$
0
0
This is a Ax-DLL (VBMThread10.DLL) for generic multithreading in VB6.

I know that there are plenty of libraries out there providing exactly this.
However, I want to share this approach and want to demonstrate how to use it.

There is only one public creatable component, the Thread class.
The Thread class is event driven and once created the new thread's main function is fired in the AsyncProcedure event.
In this event the background work will be done, as it will not lock or freeze the App.
But attention is required as showing Forms will crash VB.
Therefore in the AsyncProcedure event is a param SyncCallback. (IThreadSyncCallback class)
By this you can fire an synchronous callback. The current thread will be suspended, the method request is marshaled to the original thread.
On this SyncCallback event you can safely show forms. (as original thread)
I recommend to access project objects (classes, controls) only in the SyncCallback event.

Do not debug in the AsyncProcedure event, doing so will cause a crash.
The IDE can occasionally crash. (e.g. showing modal forms from user while a thread is running etc.)
But compiled executable should be quite stable in this regard.

Registration-Free (Side-by-side) is not supported. It must be registered normally in order to function.

List of revisions:
Code:

17-Jun-2016
- Fixed a bug in the Suspended property.
15-Jun-2016
- First release.

Attachment: VBMThread10 Ax-DLL project and a demo project.
Attached Files

[DSWC+RC5] PicSnap WebCam+Cairo Overlay Demo/Experiment

$
0
0
First, let me say that the heavy lifting in this demo has been done by the hard work of Dilettante (DSWC) and Olaf Schmidt (vbRichClient5). I've decided to experiment a bit with Olaf's RC5 widget and form classes by putting an overlay layer over the webcam work that Dilettante did in this thread: http://www.vbforums.com/showthread.p...m-Minimal-Code

Here's a screenshot to whet your appetite:

Name:  PicSnap.jpg
Views: 147
Size:  35.9 KB

As you can see we get a nice transparent overlay with semi-transparent widgets over our (now scaled to the window-size) live webcam preview. Click/Tap the top icon to cycle through your available cams (e.g. front and back cameras). Click/tap the bottom icon to take a snapshot. When you take a snapshot, the window will "flash" to indicate that the snap was taken, and a JPEG will be saved in your My Pictures folder.

This has only been tested on a Surface Pro 3 with Windows 10, and only lightly at that, so bugs are quite possible. Report issues here and I will see what I can do.

So just a bit of a fun attempt to make a camera application for dummies. Thanks once again to Olaf and Dilettante for doing the difficult stuff.

Here's the source code:

PicSnap.zip

Once you've extracted the source code, you will also need to have the vbRichClient5 library and the FSFWrap library registered on your development machine. Enjoy!
Attached Images
 
Attached Files

Fix for tabstops in the SSTab control

$
0
0
IMHO, the SSTab control is a very solid control, and I get much use out of it. However, it does have one annoying bug. When the TAB keyboard key is used, the SSTab control can pass the focus to controls on tabs that are not the current tab. In other words, the focus just sort of disappears. This is a major annoyance, and I have fixed it with the following class module. Also, an issue with combo-boxes is also corrected. See comments.

Code:

Option Explicit
'
Dim WithEvents tabCtl As SSTab
Dim frm As Form
Dim TabStops() As Boolean
'
' A primary purpose of this fix is to correctly control the tab stops.
' To make the appearance of tabs, the SSTab control simply moves the controls out of view.
' An artifact of this approach is that the controls are still able to get the focus when the
' user uses the TAB key.  The following code corrects this problem by appropriately turning
' on and off the TabStop properties of the controls as the user tabs from one tab to another.
'
' Another problem has to do with ComboBoxes.  When changing to a new tab, dropdown comboboxes
' will have their text selected.  The combobox will not have the focus, but their text will be
' selected.  The primary problem with this is that it right-justifies the text when there is more
' text than will fit in the textbox portion of the combobox, and this is confusing to users.
' This problem is corrected in the following code.
'

Friend Sub SetTabControl(TheTabControl As SSTab, TheForm As Form)
    ' Call this in the form load event.
    ' The BogusTextBox must be on the form (anywhere), and NOT the SSTab control.
    Dim ctl As Control
    Dim ptr As Long
    '
    Set tabCtl = TheTabControl
    Set frm = TheForm
    '
    ' Store the true value of the TabStops.
    ReDim TabStops(0 To frm.Controls.Count - 1)
    ' Not all controls have TabStop property, so we must set error trapping.
    On Error Resume Next
    For ptr = 0 To frm.Controls.Count - 1
        TabStops(ptr) = frm.Controls(ptr).TabStop
    Next ptr
    On Error GoTo 0
End Sub

Friend Sub SetTabStopsAccordingly()
    ' Call this in the form activate event.
    ' After this first call, it will automatically be called when the tabs change.
    Dim ctl As Control
    Dim ctlTheControlOrContainer As Control
    Dim ItsOnTheTabControl As Boolean
    Dim ptr As Long
    '
    For ptr = 0 To frm.Controls.Count - 1
        Set ctl = frm.Controls(ptr)
        Set ctlTheControlOrContainer = ctl ' The control might be on a container that's on the SSTab, rather than directly on the SSTab.
        Do
            Select Case True
            Case TypeOf ctlTheControlOrContainer.Container Is SSTab
                ItsOnTheTabControl = True
                Exit Do ' The way out.
            Case TypeOf ctlTheControlOrContainer.Container Is Form
                ItsOnTheTabControl = False
                Exit Do ' The way out.
            End Select
            Set ctlTheControlOrContainer = ctlTheControlOrContainer.Container ' Must deal with controls nested deeper than the SSTab control.
        Loop
        If ItsOnTheTabControl Then
            ' Not all controls have TabStop property, so we must set error trapping.
            On Error Resume Next
            If ctlTheControlOrContainer.Left >= 0 Then
                ctl.TabStop = TabStops(ptr) ' If it's showing, restore the original TabStop value.
                ' Must also fix the problem with combo boxes having an internal focus set.
                ctl.SelStart = 0
                ctl.SelLength = 0
            Else
                ctl.TabStop = False
            End If
            On Error GoTo 0
        End If
    Next ptr
End Sub

Private Sub tabCtl_Click(PreviousTab As Integer)
    SetTabStopsAccordingly
End Sub

Private Sub tabCtl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' This allows other controls to close up when user click off.
    ' The problem is that clicking into the body of the tab control does NOT cause change in focus.
    ' The control with the focus keeps it, and it may not close up as typically happens when clicking on dead space of a form.
    ' You may also want to consider placing this "SetFocus" code on the labels on the tabs.  This is NOT automatically done
    ' because the programmer may want to use a label click for other purposes.
    tabCtl.SetFocus
End Sub

Usage is quite simple. Let's say the above class module is named clsFixTabControl. Let's further say that you have an SSTab control on your form named tabExamData. Under these conditions, all you'd need to do is the following in your form:

Code:

Option Explicit
'
Dim FixTabControl As New clsFixTabControl
'
Private Sub Form_Load()
    SubClassForFixedSize Me ' This is to accomodate the Tablet PC.

    ' possibly other code.
End Sub

Private Sub Form_Activate()
    FixTabControl.SetTabStopsAccordingly

    ' possibly other code.
End Sub

And that's it. Your tabstops will now work perfectly on your SSTab control.
Viewing all 1321 articles
Browse latest View live




Latest Images