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

[VB6] Fastest File Search Engine

0
0
It is a well-tested code to iterate files by MFT (like 'Everything' by David Carpenter do).
Full enumeration took ~ 10 sec. / per volume.

Required:
1. Admin (elevated) privilages.
2. NTFS file system.

Purpose:
E.g., it can be used to do a huge increase in the speed of Backup software.

Demo
Will create file "Files.txt" with all *.lnk files on disk C:
Will show how many time elapsed.
Attached Files

Percentage fixed column Graph

0
0
Just a small program to create a simple percentage column graph of up to 25 values. Has a simple save load function. Wanting to add some vertical labels at the bottom and a save to bmp feature. Enjoy.

Name:  screen.jpg
Views: 46
Size:  30.1 KB

Simple column graph.zip
Attached Images
 
Attached Files

[VB6] Parse Font Name from TTF File/Data

0
0
Goal: Get the font name from the source itself: TTF file
Good specifications source found here

Did not want to have to install a font to get the information. Wanted to know how to do this, so did some research & played around.

Some caveats first...
- This has not been extremely vetted. Only tested on a few hundred font files ;)
- Does not give you any other font information; parsing font files is kinda intense
- Will only return a font name if it has been included as a Microsoft format; common but not 100%
- May need some more playing, but it suits my needs & thought I'd share it
- Already found a malformatted file or two that MS allows to be installed. So, the routines below are a bit lenient also

I'm including two sample versions: 1) for files using VB file's Open; modify to use APIs for unicode paths/file names and 2) for arrays, should you have the font available that way

This function is common to both samples below
Code:

Private Function pvReverseLong(ByVal inLong As Long) As Long

    ' fast function to reverse a long value from big endian to little endian
    ' PNG files contain reversed longs, as do ID3 v3,4 tags, TTFs & more
    pvReverseLong = _
      (((inLong And &HFF000000) \ &H1000000) And &HFF&) Or _
      ((inLong And &HFF0000) \ &H100&) Or _
      ((inLong And &HFF00&) * &H100&) Or _
      ((inLong And &H7F&) * &H1000000)
    If (inLong And &H80&) Then pvReverseLong = pvReverseLong Or &H80000000
End Function

Arrays... A bit lazy, so I used CopyMemory to transfer bytes to Long
Sample call: MsgBox pvParseFontNameFromArray(theFontFilearray(), 0, UBound(theFontFilearray)+1)
Code:

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

Private Function pvParseFontNameFromArray(fData() As Byte, ByVal offsetBegin As Long, ByVal dataLength As Long) As String

    ' fData() is a byte array, any LBound
    ' offsetBegin is where in the byte array the font file begins; not required to be @ LBound
    ' dataLength is total size of the font file; not required to be UBound(array)+1

    ' note: multi-byte values are stored in big endian (reverse order from Microsoft)

    Dim lngValue As Long, tCount As Long
    Dim lSize As Long, sName As String
    Dim nOffset As Long, lPtr As Long
   
    tCount = (dataLength - 12&) \ 16& - 1&
    For tCount = 0& To tCount
        lPtr = offsetBegin + tCount * 16& + 12&
        CopyMemory lngValue, fData(lPtr), 4& ' include 12-byte header
        If (lngValue And &HFF) > &H6E Then GoTo EH  ' passed up the n's
        If lngValue = 1701667182 Then  ' each byte is a char & it spells: name
            lPtr = lPtr + 8& ' skip checksum & add 4 bytes just read
            CopyMemory lngValue, fData(lPtr), 4& ' get offset to table, reversed
            nOffset = pvReverseLong(lngValue)
            ' minimum 12 bytes for the 'name' table
            If nOffset + 12& > dataLength Then GoTo EH
            lPtr = offsetBegin + nOffset
            Exit For
        End If
    Next
    If nOffset = 0& Then GoTo EH ' should not get here unless there is no 'name' table
   
    lngValue = fData(lPtr) * &H100& Or fData(lPtr + 1&): lPtr = lPtr + 2&
    If Not lngValue = 0& Then GoTo EH    ' invalid font structure?
    ' get number of 'names' in the 'name' table
    tCount = fData(lPtr) * &H100& Or fData(lPtr + 1&): lPtr = lPtr + 2&
    ' each 'names' entry is 12 bytes & we still have 2 bytes to read here
    If tCount * 12& + nOffset + 2& > dataLength Then GoTo EH
    ' get offset to the strings from last cached offset
    lngValue = fData(lPtr) * &H100& Or fData(lPtr + 1&): lPtr = lPtr + 2&
    nOffset = nOffset + lngValue
    If nOffset > dataLength Then GoTo EH
       
    For tCount = 0& To tCount - 1&      ' loop thru each 'names' entry
        ' we are specifically looking for Microsoft encoded names
        ' in the 12byte table...
        '  1st set of 2-bytes will be 3 (Microsoft encoding)
        '  4th set of 2-bytes will be 4 (Full name of the font)
        lngValue = fData(lPtr) * &H100& Or fData(lPtr + 1&): lPtr = lPtr + 6&
        lSize = fData(lPtr) * &H100& Or fData(lPtr + 1&): lPtr = lPtr + 2&
        If (lngValue = 3&) And (lSize = 4&) Then
            ' found what we're looking for
            ' get the size of the string
            lSize = fData(lPtr) * &H100& Or fData(lPtr + 1&): lPtr = lPtr + 2&
            ' get its additional offset
            lngValue = fData(lPtr) * &H100& Or fData(lPtr + 1&)
            nOffset = nOffset + lngValue + 1
            If nOffset + lSize > dataLength Then GoTo EH
           
            ' size our string & seek to the beginning of the string
            sName = String$(lSize \ 2, vbNullChar)
            lPtr = nOffset + offsetBegin
            CopyMemory ByVal StrPtr(sName), fData(lPtr), lSize
            Exit For
        Else
            lPtr = lPtr + 4& ' skip next 4 bytes
        End If
    Next
    pvParseFontNameFromArray = sName
   
EH:
End Function

Files...
Sample call: MsgBox pvParseFontNameFromFile(FontFileName)
Code:

Private Function pvParseFontNameFromFile(FileName As String) As String

    ' note: multi-byte values are stored in big endian (reverse order from Microsoft)

    Dim lngValue As Long, intValue As Integer
    Dim f As Integer, tCount As Long
    Dim lSize As Long, sName As String
    Dim lMax As Long, nOffset As Long
   
    f = FreeFile
    Open FileName For Binary Access Read As #f
   
    lMax = LOF(f)
    tCount = (lMax - 12&) \ 16& - 1&
    For tCount = 0& To tCount
        Get #f, tCount * 16& + 13&, lngValue ' 13 = 12-byte header + VB file start pos of 1
        If (lngValue And &HFF) > &H6E Then GoTo EH  ' passed up the n's
        If lngValue = 1701667182 Then  ' each byte is a char & it spells: name
            Seek #f, Seek(f) + 4& ' skip checksum
            Get #f, , lngValue  ' get offset to table, reversed
            nOffset = pvReverseLong(lngValue)
            ' minimum 12 bytes for the 'name' table
            If nOffset + 12& > lMax Then GoTo EH
            Seek #f, nOffset + 1&
            Exit For
        End If
    Next
    If nOffset = 0& Then GoTo EH ' should not get here unless there is no 'name' table
   
    Get #f, , intValue                  ' specs dictate the be zero
    If Not intValue = 0 Then GoTo EH    ' invalid font structure?
    Get #f, , intValue                  ' get number of 'names' in the 'name' table
    tCount = (intValue And &HFF) * &H100 Or (intValue And &HFFFF&) \ &H100
    ' each 'names' entry is 12 bytes & we still have 2 bytes to read here
    If tCount * 12& + nOffset + 2& > lMax Then GoTo EH
    Get #f, , intValue                  ' get offset to the strings from last cached offset
    nOffset = nOffset + ((intValue And &HFF) * &H100 Or (intValue And &HFFFF&) \ &H100)
    If nOffset > lMax Then GoTo EH
       
    For tCount = 0& To tCount - 1&      ' loop thru each 'names' entry
        ' we are specifically looking for Microsoft encoded names
        ' in the 12byte table...
        '  1st set of 2-bytes will be 3 (Microsoft encoding)
        '  4th set of 2-bytes will be 4 (Full name of the font)
        Get #f, , lngValue  ' reading 4 instead of two to prevent seek
        Get #f, , lSize    ' reading 4 instead of two to prevent seek
        If (lngValue And &HFFFF&) = &H300& And (lSize And &HFFFF0000) = &H4000000 Then
            ' found what we're looking for
            Get #f, , intValue          ' get the size of the string
            lSize = (intValue And &HFF) * &H100 Or (intValue And &HFFFF&) \ &H100
            Get #f, , intValue          ' get its additional offset
            nOffset = nOffset + ((intValue And &HFF) * &H100 Or (intValue And &HFFFF&) \ &H100) + 1
            If nOffset + tCount > lMax Then GoTo EH
           
            ' size our string & seek to the beginning of the string
            sName = String$(lSize \ 2, vbNullChar)
            Seek #f, nOffset + 1&
            For lSize = 1 To lSize \ 2    ' transfer content into our string
                Get #f, , intValue
                Mid$(sName, lSize, 1) = ChrW$(intValue)
            Next
            Exit For
        Else
            Seek #f, Seek(f) + 4&  ' skip next 4 bytes
        End If
    Next
    pvParseFontNameFromFile = sName
   
EH:
    Close #f
End Function

Updated above routine to request read-only access, else routine will fail to read font name if system has font opened without write-sharing. VB's default Open statement wants write-sharing. Only sample code, so add error handling as needed -- i.e., passing an invalid file name or one that is opened exclusively & won't allow reading.

VB6 elevated IE-Control-usage with HTML5-elements and COM-Event-connectors

0
0
Just a small Demo, how one can work these days with the IE-Control on a VB6-Form.

There's three main-topics which this Demo addresses:
- how to elevate the IE-Version from its default (which for compatibility-reasons always mimicks the age-old version 7)
- how to load the IE-Control dynamically, after the elevation above went through
- how to connect Elements on a page comfortably to normal VB6-EventHandlers

But also addressed is stuff like:
- how to load ones own HTML-template-code from a string into the Control
- how to enable the "themed look" of the Browser-Controls (avoiding the old "sunken edge 3D-style")
- how to work with the HTML5-canvas (in a "cairo-like-fashion") to produce antialiased output

The Event-approach as shown in the Demo does not require any References
or COMponent-check-ins, or Typelibs - the whole thing is based on a plain, virginal VB6-Project
which does not have any dependencies (and thus should work without installation anywhere when compiled).

Here's what is produced:


And here the Source-Code for the Demo:
http://vbRichClient.com/Downloads/WebEvents.zip

Olaf

IEDevKit

0
0
This is an old free control that I made many many years ago and I figured I would finally release open source.

It allows you to customize the IE web browser control in many ways.
There is a complete help file, you can see most of the features from the demo app screen shot below.

The most powerful feature is being able to use window.external from your web scripts to directly call vb6 code
and access form elements.

The main code compiles as an ActiveX Dll. You will need to register the tlb file to compile the dll.
An installer with a precompiled dll is available on the libraries homepage.

this was written in the Windows 2000 era, I just tested it on Win7/IE11 and everything still works. A quick look on Windows 10 seems ok too.

I am afraid I do not have the time/energy to do any updates on this so consider it as is and you guys can run with it from here.

Name:  mainform.jpg
Views: 49
Size:  52.4 KB
Attached Images
 
Attached Files

VB6 Easing-Functions (a more powerful alternative to AnimateWindow)

0
0
For those who never heard of Easing-Functions, they are used in all kind of
animation-scenarios - these days most often for Browser-(js)Widgets and -Effects.

Here's a link which describes them (with a nice Overview-Chart, which animates its Images on MouseOver):
http://easings.net/en

The underlying math is not that difficult - and I've encapsulated the most interesting Easing-Methods in a little Class.

This Class now also contains an 'Animate'-Method, which you can hand a Control,
a Property-Name, and PropStart - PropEnd-Values, you want to animate (over a given Duration).

For that 'Animate'-Method the little cEasing-Class now makes use of an internal cTimer-Class
(for which I've choosen the first one I was able to find in the CodeBank that supported an Event):
http://www.vbforums.com/showthread.p...ule-2008-06-15

Here is what it looks like in action (animating two Control-Properties at once - the Top- and the Alpha-Property):



Here is the Source-Code: http://vbRichClient.com/Downloads/Easing.zip

Have fun with it...

Olaf

Make a modal form wich is modal by software, no with modal show

0
0
I post the code in a thread to resolve a problem, but i think this code must be here.

We have a Form1 like a dialog and we wish to open a "modal" form Form2 and maybe a help form Form3 which maybe stay open while Form2 closed.
Also we don't like to disable Form1 controls. So how we can shield Form1 from clicks?

The answer is by using a form as shield in front of Form1. This shield turned transparent so nobody knows that exist. If we click on form1 in taskbar then we send focus to this transparent Form, but our "modal" Form2 and perhaps if visible Form3 are both always in front of this transparent form. So we did nothing if we click on Form1 (which is covered with shield form). When Form2 close, turn transparency of shield form to 0, so we can use Form1 without unload shield, because shield is like no exist any more (but is loaded and in show state, so can hold other forms).
If we wish we can turn transparensy to an ammound of 50 so to dimm Form1, the way we see in Html forms when modal windows popup.
Attached Files

[VB6] Compression API: Another post-Win7 gem

0
0
Here is a wrapper class for the Compression API. This requires Windows 8 or newer.

It is used here in a simple demo, which creates a 2.5MB file test.txt which is then read back and run through compression and written out as comp.bin, and then that is read back and run through decompression and written as the expanded.txt file.

Writing the before and after files makes it easy to run WinDiff to verify results.

There is some work remaining to be done but the essentials are all working.

Caveat:

Programs that use this system DLL may be flagged as a trojan horse by antivirus software, even by Windows Defender. Malware droppers have gotten out of control so all security suites are tightening these things up a lot. When they see a VB6 program they turn on quite a few other checks, and your suspicion score can rise quickly. Blame the miscreants who started using VB6 to create their monsters.
Attached Files

[VB6] Simple Unicode Textbox (Input Only)

0
0
With common controls v6 (available since XP), we can use VB's own textbox (some limitations explained later) for a simple input-only textbox, and have it accept unicode text. Of course, you can get the unicode text also. No subclassing, no custom controls.

CAVEAT: Not perfect, but for many scenarios, this is as simple as it gets without subclassing or adding other controls to your project for the sole purpose of an input unicode-aware textbox.

Limitations.... If the textbox is only meant for input, these limitations are not that bad.

1. This 'trick' requires the textbox to be multi-line. You can kind of imitate a single-line textbox by setting the scrollbar to horizontal only, then hiding the scrollbar during form_load. This will prevent the text from wrapping when the caret goes past the visible horizontal boundary. What this doesn't do is prevent a user from getting to a new line via Enter or Ctrl+Enter, nor does it prevent the user from pasting multiple lines of text from the clipboard. With a little effort you can overcome this limitation with keyboard events and/or keyboard-related APIs; along with monitoring the textbox change event. A simple Enter key can be prevented with something like:
Code:

Private Sub Text1_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then KeyAscii = 0
End Sub

2. You can't really edit the text other than sending text to the clipboard in unicode format and pasting it to the textbox. This is why I suggest limiting this trick to just input-text boxes, i.e., custom inputbox, textbox on a usercontrol's property page, etc.

3. Must include a manifest with the project, textbox has got to be themed with common controls v6. An external manifest can be applied to VB6.exe to have the IDE themed, allowing you a WYSIWYG experience while in IDE.

4. Use of APIs to hide the horizontal scrollbar and get text

How to set it up.

1. Place a textbox on your form. Size it the way you need and ensure at least these properties are set:
Mutliline = True
Scrollbars = Horizontal

2. If you actually want a multiline textbox, then set the scrollbars how you want & ignore this step. In form_load, hide the scrollbar
Code:

Private Declare Function ShowScrollBar Lib "user32.dll" (ByVal hWnd As Long, ByVal wBar As Long, ByVal bShow As Long) As Long
Private Const SB_HORZ As Long = 0

Example:  ShowScrollBar Text1.hWnd, SB_HORZ, 0&

3. Retrieving the text in unicode, requires several APIs. The reason why a multiline textbox is required is that EM_GETHANDLE message is invalid for single line textboxes. And simple APIs like GetWindowTextW don't return unicode from the textbox; neither does VB's .Text property.
Code:

Private Declare Function SendMessageW Lib "user32.dll" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function lstrlenW Lib "kernel32.dll" (ByVal lpString As Long) As Long
Private Declare Function LocalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function LocalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Const EM_GETHANDLE As Long = &HBD

Example:
    Dim s As String
    Dim lCount As Long, lHandle As Long, hGlobal As Long
   
    lHandle = SendMessageW(Text1.hWnd, EM_GETHANDLE, 0&, ByVal 0&)
    If lHandle = 0 Then Exit Sub ' fails on single-line textbox controls
    hGlobal = LocalLock(lHandle)
    lCount = lstrlenW(hGlobal)
    s = String$(lCount, 0)
    CopyMemory ByVal StrPtr(s), ByVal hGlobal, lCount * 2&
    LocalUnlock hGlobal
   
    ' variable s now contains the unicode text

4. Pick a decent, scalable true-type font for your textbox.

For a bit more control without the 1st limitation mentioned above, you can always create an API unicode textbox, setting the window style as you need. Still shouldn't need to subclass or add external controls.

The best solution is a full-blown unicode textbox, but this thread is simply meant to offer a suitable substitute if the scenario fits.

Screenshot below simply shows that this will not work if the project is not themed via a manifest. When the text was retrieved, here are the hex values of each character (AscW), after pasting those Chinese characters: 5C0F 7EA2 72D0 72F8

Name:  Untitled.jpg
Views: 127
Size:  1.8 KB

FYI: Google Translate -- great place to get various language translations & unicode characters for copying and pasting for testing.

Edited: I hosed up the lstrlenW API, sorry about that. Always a risk of leaving in test code. Oops & fixed the sample code above.
Attached Images
 

[VB6] "HashTub" - a collection class

0
0
We have a very versatile Collection class built into VB6 and we also have Scripting.Dictionary. Most of the time one or the other of these is all we need. But sometimes we have a special need for larger scale collections.

Scripting.Dictionary works well (if used carefully) up to 100K items or so. But beyond that point performance begins to degrade exponentially.

HashTub

A simple hash table where Keys are String and Item values are Variants.

A memory hog meant for very large tables (approx. one million or more entries, max about 18 million but less for Variant String items, Variant array items, etc.). Long key strings can also limit the maximum count. Most programs will do better using a Collection or a Scripting.Dictionary unless they need a huge table.

If you don't need Variants you can adjust to specific types (Long, String, some Class, etc.) and save on memory.

Assigning to an existing Item updates the Item's value. Item access is by key or index, indexes are base-1 like a Collection. A new item must be added by key.

No "insert" or "remove" operations.

Assign the Chunk property first. This should be 1/20 to 1/2 of the expected population. Larger is more wasteful, smaller is slower.

A better String hash might improve performance. Keys are case-sensitive and Unicode-aware. The current hash can accept ANSI Strings as well as normal Unicode Strings as keys.

HashTub is a fairly small class, 100% VB6 aside from one API call used for hashing.


Sample Run

Name:  sshot.png
Views: 116
Size:  3.6 KB


Requirements

Windows 2000, or earlier 32-bit Windows versions (including Win9x) with IE 5.0 or later installed. That is for the HashData() API call. If you substitute another hash it should work wherever VB6 runs.


Methods and Properties

Add NewItem, NewKey

Chunk [R/W]

Count [RO]

Exists(Key) [RO]

Key(Index) [RO]

Item(Index or Key) [R/W, write adds when Key is new]

Trim


Tweaks

Memory consumption can be reduced by changing the Item type from Variant to a specific type (String, Long, Currency, etc.).

You could also define a UDT in a static .BAS module and then you could use that as your Item type.

You can improve performance by dropping features. One is to drop access by Index. Then you will no longer need or have to update the NodeIndexes array. At that point the "Key" parameter can be passed ByRef and this speeds things up too.

You can also drop Object support even if you stay with Variant Items. That can simplify the code a little but gains little or nothing in performance. The capability isn't worth using though because creating a million or more Objects isn't a viable strategy.
Attached Images
 
Attached Files

New to Visual Basic- need help with coding for Microsoft word purposes

0
0
I am brand new to visual basic, using it to make documents within Microsoft Word 2016 easier to use. Right now I am designing a userform to ask for data to be entered into a textbox and then for the text entered to be displayed within the document in multiple locations. Currently I am using bookmarks, but I can only display the the text in one bookmark (I can't link the text from one text box to multiple locations within the document). How can I code it to populate this data several times throughout my document? Thanks

[VB6, Vista+] Finding and deleting invalid shortcuts with IShellLink and IShellItem

0
0

Dead Link Cleaner
So I went looking for a utility to do this for me, and couldn't find one that either itself or its installer didn't look shady/spammy. Since shell interfaces are my favorite thing anyway, I went ahead and wrote program to make it.

I'm posting here instead of utilities because this example marks the first VB6 a technique for enumerating/searching files recursively using the standard IShellItem interface, where most previous examples either aren't recursive, aren't for general file system locations, or use a different method- sticking with IShellItem increases your coding efficiency since you don't need to convert between different ways of interacting with the file system.

Unicode is fully supported. The textbox and listbox are the standard VB controls so won't display Unicode, but the names are stored internally so everything will work; just if you need to use a path with Unicode extended characters in the name, select it with the Browse... button.

Requirements
-Windows Vista or newer (the link check/delete works on XP but the file enumeration uses IEnumShellItems, which is only available as of Vista)
-oleexp.tlb v4.0 or newer
-oleexp addon mIID.bas (included in oleexp download)

Code
The code here is to show core concepts, see the full project in the attachment for additional declares and support functions that the below requires to run.

We use IShellLinkW and IPersistFile to load links and grab their target:
Code:

Public Function GetLinkTarget(sLNK As String) As String
Dim pSL As ShellLinkW
Dim ipf As IPersistFile
Dim sTar As String
Dim wfd As WIN32_FIND_DATAW
Set pSL = New ShellLinkW
Set ipf = pSL

ipf.Load sLNK, STGM_READ

sTar = String$(MAX_PATH, 0)
pSL.GetPath sTar, MAX_PATH, wfd, SLGP_UNCPRIORITY

pSL.Release

If InStr(sTar, vbNullChar) > 2 Then
    sTar = Left$(sTar, InStr(sTar, vbNullChar) - 1)
End If
If Left$(sTar, 1) = vbNullChar Then
    GetLinkTarget = ""
Else
    GetLinkTarget = sTar
End If

End Function

And the new recursive scanning with only IShellItem and IEnumShellItems is done like this:
Code:

Private Sub Command2_Click()
Dim psi As IShellItem
Dim piesi As IEnumShellItems
Dim isia As IShellItemArray
Dim pidl As Long
Dim pFile As IShellItem
Dim lpName As Long
Dim sName As String
Dim sDisp As String
Dim pcl As Long
Dim sTarget As String
Dim sStart As String
Dim lAtr As SFGAO_Flags
List1.Clear
ReDim arToDel(0)
nToDel = 0
nLinks = 0

pidl = ILCreateFromPathW(StrPtr(sRoot))
SHCreateItemFromIDList pidl, IID_IShellItem, psi
psi.BindToHandler 0&, BHID_EnumItems, IID_IEnumShellItems, piesi

Do While piesi.Next(1&, pFile, pcl) = S_OK
    pFile.GetAttributes SFGAO_FOLDER, lAtr
    If (lAtr And SFGAO_FOLDER) = SFGAO_FOLDER Then
        If Check1.Value = vbChecked Then
            ScanDeep pFile
        End If
    Else
        pFile.GetDisplayName SIGDN_DESKTOPABSOLUTEPARSING, lpName
        sName = LPWSTRtoStr(lpName)
        sDisp = Right(sName, Len(sName) - InStrRev(sName, "\"))
        If Right$(sName, 4) = ".lnk" Then
            Debug.Print "Found link: " & sName
            nLinks = nLinks + 1
            sTarget = GetLinkTarget(sName)
            If PathFileExistsW(StrPtr(sTarget)) Then
                Debug.Print "Link is valid, skipping."
            Else
                Debug.Print "Link is invalid, deleting..."
                ReDim Preserve arToDel(nToDel)
                arToDel(nToDel) = sName
                nToDel = nToDel + 1
                List1.AddItem sDisp
            End If
        End If
    End If
Loop
Label2.Caption = "Found " & nLinks & " total, " & nToDel & " pending deletion."
Call CoTaskMemFree(pidl)

End Sub
Private Sub ScanDeep(psiLoc As IShellItem)
'for recursive scan
Dim psi As IShellItem
Dim piesi As IEnumShellItems
Dim pFile As IShellItem
Dim lpName As Long
Dim sName As String
Dim sDisp As String
Dim pcl As Long
Dim sTarget As String
Dim lAtr As SFGAO_Flags


psiLoc.BindToHandler 0&, BHID_EnumItems, IID_IEnumShellItems, piesi
Do While piesi.Next(1&, pFile, pcl) = S_OK
    pFile.GetAttributes SFGAO_FOLDER, lAtr
    If (lAtr And SFGAO_FOLDER) = SFGAO_FOLDER Then
        ScanDeep pFile
    Else
        pFile.GetDisplayName SIGDN_DESKTOPABSOLUTEPARSING, lpName
        sName = LPWSTRtoStr(lpName)
        sDisp = Right(sName, Len(sName) - InStrRev(sName, "\"))
        If Right$(sName, 4) = ".lnk" Then
            Debug.Print "Found link: " & sName
            nLinks = nLinks + 1
            sTarget = GetLinkTarget(sName)
            If PathFileExistsW(StrPtr(sTarget)) Then
                Debug.Print "Link is valid, skipping."
            Else
                Debug.Print "Link is invalid, deleting..."
                ReDim Preserve arToDel(nToDel)
                arToDel(nToDel) = sName
                nToDel = nToDel + 1
                List1.AddItem sDisp
            End If
        End If
    End If
Loop
End Sub

Attached Files

lite weight progress bar control with percent

0
0
digging through old projects and found this small control I thought I would share.

very lite weight progress bar user control, drop in replacement for mscomctl one
and includes some extra features like an inc/dec methods, reset, set by percent, ability to set colors
and can also display the current percentage if desired. also does not throw errors if value > max

free for any use

Name:  screenshot.png
Views: 65
Size:  6.0 KB
Attached Images
 
Attached Files

[VB6] CC6 Graphical Buttons

0
0
We have "graphical style" command buttons, but they won't accept Common Controls 6 UxTheme adjustments. However I have found a way around this:

Code:

Option Explicit

'Demonstrates using CommandButtons where Style = vbButtonStandard and
'Picture = <some icon> along with a Common Controls 6 manifest to get
'"graphical" buttons with CC6 styling and effects.
'
'Why do this?
'
'It can come in handy when you want to make a "toolbar" without the
'need to deploy any toolbar OCX.  Just put them into a PictureBox,
'UserControl, etc.
'
'And some people just like to have icons on buttons here and there.

Private Const BM_SETIMAGE As Long = &HF7&
Private Const IMAGE_ICON As Long = 1

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 GWL_STYLE As Long = -16&

Private Enum BS_TEXTALIGN_STYLES
    [_BS_TEXTPOSMASK] = &HF00&
    'Note: the next two values seems to be swapped in winuser.h, or at least
    'have the opposite meaning when used with an icon, so I have swapped them:
    BS_RIGHT = &H100&
    BS_LEFT = &H200&
    'Note: the next two values seems to be swapped in winuser.h, or at least
    'have the opposite meaning when used with an icon, so I have swapped them:
    BS_BOTTOM = &H400&
    BS_TOP = &H800&
    BS_CENTER = &H300&
End Enum

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" ( _
    ByVal hWnd As Long, _
    ByVal nIndex As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" ( _
    ByVal hWnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long

Private Sub IconizeButton( _
    ByVal CommandButton As CommandButton, _
    Optional ByVal TextAlignment As BS_TEXTALIGN_STYLES = BS_BOTTOM)
    'Assumes the CommandButton has an icon as its Picture property.
    Dim NewStyle As Long
   
    With CommandButton
        NewStyle = GetWindowLong(.hWnd, GWL_STYLE) And Not [_BS_TEXTPOSMASK] Or TextAlignment
        SetWindowLong .hWnd, GWL_STYLE, NewStyle
        SendMessage .hWnd, BM_SETIMAGE, IMAGE_ICON, .Picture.Handle
    End With
End Sub

Private Sub Form_Load()
    IconizeButton cmdBurn
    IconizeButton cmdSave
    IconizeButton cmdSmiley
    IconizeButton cmdSomeButton, BS_CENTER
    IconizeButton cmdSubmit, BS_LEFT
End Sub


These buttons are larger than they need to be, and a normal toolbar would probably use smaller icons anyway:


Name:  sshot1.png
Views: 12
Size:  7.1 KB

As it begins


Name:  sshot2.png
Views: 8
Size:  7.5 KB

Tabbed to move focus, hovering mouse


Name:  sshot3.png
Views: 8
Size:  7.5 KB

Just hovering


I put my "toolbar buttons" within a PictureBox, but I haven't figured out how to theme that to look like a proper toolbar. Maybe the BackColor at least ought to be a different color? There are no borders but a Line control at the "bottom" of the PictureBox is standing in for one here.


Requirements

Should work on Windows XP or later. Only tested on Windows 10 so far.

IDE runs of course look clunky and the icons don't show, but if you apply a CC6 manifest to the IDE that might not happen. I haven't tried this since I don't use an IDE manifest for theming.
Attached Images
   
Attached Files

[VB6] Extending the DataGrid Control

0
0
Been playing with the DataGrid control to see if it could be usable in a project of mine. It's not a bad control, just a bit under-powered.

Caveat: The code and this posting is 99% focused on using the Data Grid without bound data. In other words, how to use the control without having a database to connect to.

This control is unicode aware and has a professional appearance. It can be very useful in many cases as a simple spreadsheet or to display subsets of databases. There are a few drawbacks to using this control.

1. It requires a bound list. Unlike its older counterpart, the DBGrid which could create its own internal collection of data, this control requires a data source. However, if you are connecting to an established DB, then not much to worry about. If you want to display your own custom data (no database), you can still do that via disconnected recordsets. They aren't that difficult, but you lose the advantage of SQL that could be used with a real DB. Here is a good example of using that other grid control: DBGrid, provided by dilettante

2. The multiselect feature is 'simple' vs. 'extended'. You can't use the shift key to select a range of rows

3. It has no OLE drag/drop feature.

4. The scrollbar does not respond to mouse wheels.

Most of those deficiencies can be overcome.

In the sample project provided, you will find a class: cGridEx. Lot's of comments provided too. This class extends the DataGrid control a bit. It does offer workarounds for extended mutliselection and dragging records from the control. I did not include code to drag stuff into the DataGrid; but you could do that with lots of elbow grease. The mouse wheel is not addressed in the cGridEx class since that workaround requires subclassing, but shown below one way to handle it.

As far as the bound data... The class has an option that can help generate an empty ADO recordset where you fill in the data and assign the recordset to the data grid. Populating a recordset is not rocket science -- use your favorite method. Remember that Excel & CSVs can be loaded into recordsets also (nearly automatically), allowing you to view them via a DataGrid. Also, recordsets can be persisted to file.

To handle the mouse wheel, the cGridEx class has a function to be called from subclassing. Here is an example I am using (not included in the zip file)

1. In a bas module, include this code and the API declarations:
Code:

Private Declare Function DefSubclassProc Lib "comctl32.dll" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32.dll" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Const WM_DESTROY As Long = &H2
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const WHEEL_DELTA As Long = 120

Public Sub UnSubclassGrid(hWnd As Long, Key As cGridEx)
    RemoveWindowSubclass hWnd, AddressOf pvWndProc, ObjPtr(Key)
End Sub
Public Sub SubclassGrid(hWnd As Long, Key As cGridEx)
    SetWindowSubclass hWnd, AddressOf pvWndProc, ObjPtr(Key), 0&
End Sub
Private Function pvWndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, _
                            ByVal uIdSubclass As cGridEx, ByVal dwRefData As Long) As Long
                           
    If uMsg = WM_MOUSEWHEEL Then
        wParam = (wParam And &HFFFF0000) \ &H10000
        uIdSubclass.ScrollGrid wParam \ -WHEEL_DELTA
    Else
        If uMsg = WM_DESTROY Then UnSubclassGrid hWnd, uIdSubclass
        pvWndProc = DefSubclassProc(hWnd, uMsg, wParam, lParam)
    End If
   
End Function

2. After attaching the data grid control to the cGridEx class, subclass the control
Code:

' for example, in Form_Load
    Set m_GridEx = New cGridEx
    m_GridEx.Attach DataGrid1
    SubclassGrid DataGrid1.hWnd, m_GridEx

3. Remember to unsubclass the control before it is destroyed -- else a crash will occur, if you or VB sets the grid's cGridEx class to nothing before the control is unloaded by VB.
Code:

' for example, in Form_Unload
    Set DataGrid1.DataSource = Nothing
    UnSubclassGrid DataGrid1.hWnd, m_GridEx

Edited: For a slightly different version, see post #5 below.
Attached Files

VB6 - Unicode ListBox/ComboBox

0
0
After dilettante pointed out that the MS InkEdit Control could be used to support Unicode non-latin text, I used it effectively in one of my projects. But I was still looking for a ListBox that would support Unicode and did not require third party controls. It suddenly came to me that the InkEdit control might have everything I need. The only difficulty I ran into is that when the multiline InkEdit Control contents are converted to text, it automatically adds a CrLf to each line even if you just add a Cr. This meant that searching for the CrLf using the SelStart property produced a count error of 1 for each line. The solution was to copy the text to a string and replace the CrLf with a zero. This brought the SelStart property in line with the text.

J.A. Coutts
Attached Images
 
Attached Files

VBFlexGrid Control (Replacement of the MSFlexGrid control)

0
0
This project is intended to replace the MSFlexGrid control for VB6.

The "MSFLXGRD.OCX" can be replaced completly.

Even though some enhancements of the MSHFlexGrid control are included, it can't replace it completly (yet).
But there are also new features included that are not available on both MSFlexGrid and MSHFlexGrid.

The VBFlexGrid supports Unicode and is DPI-Aware.

At design time (IDE) there is only one dependency. (OLEGuids.tlb)
This is a modified version of the original .tlb from the vbaccelerator website.
But for the compiled .exe there are no dependencies, because the .tlb gets then compiled into the executable.

Everything should be self explained, because all functions and properties have a description.

ActiveX Control version has not yet been developed. (trial period)

Notes:
- When using the SetParent API, pass .hWndUserControl and not .hWnd.
- When changing the "Project Name", have all forms open, else all properties are lost. Because the library to which the controls are referring to is the "Project Name" itself. Having all forms open will ensure that the .frx files will be updated with the new "Project Name".
- In order to trap error raises via "On Error Goto ..." or "On Error Resume Next" it is necessary to have "Break on Unhandled Errors" selected instead of "Break in Class Module" on Tools -> Options... -> General -> Error Trapping.

List of revisions:
Code:

14-Jun-2017
- First release.

Name:  VBFlexGridDemo.jpg
Views: 1
Size:  94.0 KB
Attached Images
 
Attached Files

VB6 - Fisher–Yates shuffle

0
0
Attached is a short demonstration of the Fisher–Yates shuffle. In this particular case we wanted to be able to restore the shuffle back to it's original format, so we had to ensure that the Random number generator produced predictable results depending on the key supplied. To truly randomize the shuffle, you would need to use a better random number generator.

J.A. Coutts
Attached Images
 
Attached Files

VB6 ThemedControls.ocx (uxTheme-based replacements for SSTab and VB.Frame)

0
0
The title says it already - this is a project which shows how to use the
uxTheme.dll (without any involvement of the comctl32.dll), to render directly
onto the default-hWnd of a VB6-UserControl.

In the compiled binary are currently hosted (and publically available on the outside):
- cGDIPlusCache.cls (a Class to manage resource-loading from ByteArrays or Files "outside of any Control" - it's comparable to an ImageList, but supports PNG and HighQuality-resizing)
- cSubClass.cls (a simple SubClasser, which the Controls are using - but it's also available on the outside)
- ucFrame.ctl (a transparent, unicode-aware replacement for the VB.Frame-Control - interface-calling-compatible)
- ucSSTab.ctl (also unicode-aware and nearly 100% compatible to the original, with the exception of the Property .TabSelIdx (instead of just .Tab as the original is using).

Here's what the two Controls look like "in action" on a Win8-machine (with Scaling at 100% = 96dpi):


And here the same Form on Win-XP (running with a Desktop-Scaling of 125% = 120dpi):



As already mentioned, due to the quite high compatibility of the two Controls, one should be able
to just replace (on a given "old Form" with original SSTabs and VB.Frames) the appropriate:
ProgID in the ... " Begin ProgID ControlName " lines of a VB-*.frm ...
All the old terms: TabDlg.SSTab ... can be replaced with: ThemedControls.ucSSTab
and the terms/ProgIDs: VB.Frame ... can be replaced with: ThemedControls.ucFrame

I've done this Search/Replace within a TextEditor on this original Form here (which is included in the Demo-Project):


And the result which came out (since I use the same PropBag-formats as the original) after loading the replaced-*.frm file was:


So, in case you feel encouraged to work on this project (to enhance it about other uxTheme-based
VB.compatible Controls like e.g. CommandButtons, OptionBoxes, CheckBoxes - please post back here,
so that it can be included into the Main-OCX-Zip (which I would update when new interesting stuff comes in).

Oh, and yes, the ucSSTab-replacement is "DesignTime-clickable" (tab-container-wise) -
it also doesn't have the "Focus- and Tabbing-issues" of the original. What's missing currently
(as an enhancement on top of the old SSTab) is Auto-Focusing of contained Controls on Tab-Switch -
but I leave that for interested developers who want to contribute such an extension... ;)

Here's the Zip: http://vbRichClient.com/Downloads/ThemedControls.zip
(please compile the OCX first into its \CtlSource\-SubFolder - after that you can run the Demo in the ThemedControls-MainFolder.

Have fun...

Olaf

Layered Form + InkPicture = DoodleTop

0
0
One of the things we got when mainstream desktop Windows inherited the infrastructure from XP Tablet Edition was the InkPicture control.

While there are lot of things you can do with this, few people seem to be playing with it. Odd because it has an excellent API for use in VB6: it is just another nice control we get as part of Windows.

Combining that with layered windows led to a fun prototype application: "DoodleTop."


Requirements

Windows XP Tablet Edition, or any Windows version from Vista through 10.


DoodleTop

So the idea here is that you do screencasts presenting your conclusions from your research into the Illuminati. But it would be great to be able to circle your points, highlight them, even sketch or doodle a bit on those blown up images of the All Seeing Eye.

DoodleTop to the rescue:

Name:  sshot1.jpg
Views: 46
Size:  25.0 KB

This is just rough of course. More likely you would want to move the "control panel" into a separate non-layered Form that you can drag onto a second monitor or just hide/show via a function key or something. Here's that "control panel" area:

Name:  sshot2.png
Views: 21
Size:  2.2 KB


Anyway maybe this is a fun concept that might get you thinking and playing with the Tablet Ink controls we got so many years ago.
Attached Images
  
Attached Files
Viewing all 1304 articles
Browse latest View live




Latest Images