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

Roulette Table

May 12, 2021, 8:29 am
$
0
0
roulette.zipName: Noname.bmp Views: 27 Size: 414.0 KB
My version of roulette. Tried to imitate the slowing of the wheel. Drag chips onto board and spin. Good luck.
Attached Images
 
Attached Files
↧
Search

[VB6] AddIn - Comment/Code Display + Highlight + Extra Hotkeys v0.8e

May 9, 2021, 9:49 pm
$
0
0
This is an add-in to display comments and code of user generated
Functons/Methods/Properties and also some info from typelibs in the project

Name: Snap_CCHH_1.jpg Views: 231 Size: 54.8 KB

Name: Snap_CCHH_Config.jpg Views: 221 Size: 30.8 KB


It takes the text inside comments over the declarations and also from the menu
Tools->Procedure Attributes or inside typelibs

(optional) Also have extra hotkeys:
CTRL+Q: Smart lines comment / uncomment
CTRL+D: Duplicate Lines
CTRL+SHIFT+UP and CTRL+SHIFT+DOWN: Move Up or Down selected lines

(optional) Also has selection highlight on editor on all ocurrences of text/selection. Note: Only support MONOSPACE FONTS


IMPORTANT: This is a WIA (Work In Progress) I'm releasing this AddIn as
an unfinished project. Its working but I feel there is still some more
polishing to do. Just dont have the time needed right now.


NOTE: If highlighting a word doesnt seem to work try selecting another word and then
reselecting the word you want to hihglight OR scroll the editor up/down to force
re apply highlighting.


Special thanks to Fafalone and LaVolpe for helping how to access typelibs data.


DOWNLOAD: prj (AddIn) ComCodeDisplay v0.8e.zip

Changelog:
v0.8 (06/05/21)
+Initial release.
v0.8b (07/05/21)
+Highlight: Fixed default font values and without comment viewer
v0.8c (10/05/21)
+Highlight: Fixed horizontal scrolling on editor
v0.8d (11/05/21)
+Highlight: Fixed lines with ampersand ('&')
+Removed reference to Office objects
v0.8e (12/05/21)
+Fixed default VB6 to Courier New and not Times New Roman
(for people who have never changed the font)
Attached Images
  
Attached Files
↧
↧

Load ICO From Res or Byte array by vb6,Get All Size ,BitCount

May 12, 2021, 8:51 pm
$
0
0
Code:
'FORM1.FRM

Dim NewCursor As Long, OldCursor As Long
'add 2 control: Text1,picture1

Private Sub Command1_Click()
Dim bt() As Byte

'bt = OpenBinFile(App.Path & "\02.ico")
 
 Dim SizeArr() As String
 SizeArr = GetIcoSizeArr(bt)
 MsgBox Join(SizeArr, vbCrLf)
 
 NewCursor = LoadIcoByByte(bt, 256, 32)
 'NewCursor = LoadIcoByByte(bt, 0)
 

Text1.MousePointer = vbCustom
OldCursor = SetClassLong(Text1.hwnd, GCL_HCURSOR, NewCursor)

Picture1.Width = 256 * Screen.TwipsPerPixelX + Picture1.Width - Picture1.ScaleWidth
Picture1.Height = 256 * Screen.TwipsPerPixelY + Picture1.Height - Picture1.ScaleHeight

DrawIconEx Picture1.Hdc, 0, 0, NewCursor, 256, 256, 0, 0, DI_NORMAL
Picture1.Refresh
End Sub

Private Sub Form_Load()
Picture1.AutoRedraw = True
Picture1.AutoSize = True
Command1_Click
End Sub
Code:
'*.BAS

Option Explicit
Private Declare Function CreateIconFromResourceEx Lib "user32" (presbits As Byte, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal uFlags As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

 Private Type ICONDIRENTRY
    bWidth  As Byte
    bHeight  As Byte
    bColorCount  As Byte
    bReserved  As Byte
    wPlanes  As Integer
    wBitCount  As Integer
    dwBytesInRes  As Long
    dwImageOffset  As Long
End Type
Public Const GCL_HCURSOR = -12


Public Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Const DI_NORMAL = &H3 '用常规方式绘图 (DI_IMAGE 和 DI_MASK)
Public Declare Function DrawIconEx Lib "user32" (ByVal Hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long

Public Function GetIcoSizeArr(mIcon() As Byte) As String()
 'good
'从字节数组内存流中创建ICO图标
Dim SizeArr() As String
    Dim IDETY As ICONDIRENTRY
    Dim W As Long, H As Long
    Dim i As Long, iLen As Long, pData As Long, id As Long
    iLen = LenB(IDETY)
    pData = VarPtr(mIcon(0))
    ReDim SizeArr(mIcon(4) - 1)
    For i = 1 To mIcon(4)  '第5个字节就是子图标的数目
        CopyMemory IDETY, ByVal pData + 6 + (i - 1) * iLen, iLen '读 图标目录 结构数据
        W = IDETY.bWidth
        H = IDETY.bHeight
        If W = H Then
            If W = 0 Then W = 256: H = 256
            SizeArr(id) = W & "*" & H & "," & IIf(IDETY.wBitCount = 0, "32位透明", IDETY.wBitCount)
            id = id + 1
        Else
            Exit For
        End If
    Next
    If id > 0 Then
        ReDim Preserve SizeArr(id - 1)
    Else
        ReDim SizeArr(-1 To -1)
    End If
    GetIcoSizeArr = SizeArr
End Function
Public Function LoadIcoByByte(mIcon() As Byte, Optional ByVal iSize As Long = 16&, Optional BitCount As Long) As Long
'version 2021-5-13
 'good
'从字节数组内存流中创建ICO图标,条件：大小，位度
    Dim IDETY As ICONDIRENTRY, FindSize As Long
    Dim i As Long, iLen As Long, pData As Long
    Dim FindBitCount As Boolean
    If iSize = 0 Then iSize = 256
    If iSize = 256 Then
        FindSize = 0
    Else
        FindSize = iSize
    End If
    iLen = LenB(IDETY)
    pData = VarPtr(mIcon(0))
    For i = 1 To mIcon(4)  '第5个字节就是子图标的数目
        CopyMemory IDETY, ByVal pData + 6 + (i - 1) * iLen, iLen '读 图标目录 结构数据
        If BitCount = 0 Then
            FindBitCount = True
        Else
            FindBitCount = IDETY.wBitCount = BitCount
        End If
        If FindBitCount Then
            If iSize = -1 Then
                iSize = IDETY.bWidth
                If iSize = 0 Then iSize = 256 'edit:2021-5-13
                GoTo DoLoadIco
            ElseIf IDETY.bWidth = FindSize Then '寻找符合尺寸的子图标
DoLoadIco:
                LoadIcoByByte = CreateIconFromResourceEx(mIcon(IDETY.dwImageOffset) _
                                , IDETY.dwBytesInRes, -1, &H30000, iSize, iSize, 0)
                Exit For
            End If
        End If
    Next
End Function

Function OpenBinFile(filename As String, Optional ErrInfo As String) As Byte()
  '[mycode_id:1903],edittime:2011/7/11 13:27:34
On Error Resume Next
Dim hFile As Integer
hFile = FreeFile
Open filename For Binary As #hFile
ReDim OpenBinFile(LOF(hFile) - 1)
Get #hFile, , OpenBinFile
Close #hFile
End Function
↧

Asynchronous Beep by vb6(NtDeviceIoControlFile)

May 13, 2021, 12:50 am
$
0
0
Play the sound of the specified frequency and duration
Code:
Sub Main()
Dim AsyncBeep2 As New AsyncBeep
AsyncBeep2.Play 1000, 2024
MsgBox "ok"
End Sub
Code:
' 异步版 Beep，作者YY菌，技术交流群（QQ）：250264265
'AsyncBeep.cls
'Asynchronous version of Beep, author YY bacteria, technical exchange group (QQ): 250264265
Option Explicit

'Input and output status
Private Type IO_STATUS_BLOCK
    Status As Long
    Information As Long
End Type

'Unicode string
Private Type UNICODE_STRING
    Length As Integer
    MaximumLength As Integer
    Buffer As String
End Type

'Object properties
Private Type OBJECT_ATTRIBUTES
    Length As Long
    RootDirectory As Long
    ObjectName As Long
    Attributes As Long
    SecurityDescriptor As Long
    SecurityQualityOfService As Long
End Type

'Beep parameter
Private Type BEEP_SET_PARAMETERS
    Frequency As Long
    Duration As Long
End Type

'Beep related constants
Const BEEP_FREQUENCY_MINIMUM& = &H25&
Const BEEP_FREQUENCY_MAXIMUM& = &H7FFF&
Const IOCTL_BEEP_SET& = &H10000
Const DD_BEEP_DEVICE_NAME$ = "\Device\Beep"

'Permission constant
Private Enum ACCESS_MASK
    FILE_READ_DATA = &H1&
    FILE_WRITE_DATA = &H2&
End Enum

'Open constant
Private Enum CREATE_DISPOSITION
    CREATE_NEW = 1
    CREATE_ALWAYS = 2
    OPEN_EXISTING = 3
    OPEN_ALWAYS = 4
    TRUNCATE_EXISTING = 5
End Enum

'API statement
Private Declare Function NtCreateFile Lib "ntdll" (ByRef FileHandle As Long, ByVal DesiredAccess As ACCESS_MASK, ObjectAttributes As OBJECT_ATTRIBUTES, IoStatusBlock As IO_STATUS_BLOCK, ByVal AllocationSize As Long, ByVal FileAttributes As Long, ByVal ShareAccess As ACCESS_MASK, ByVal CreateDisposition As CREATE_DISPOSITION, ByVal CreateOptions As Long, EaBuffer As Any, ByVal EaLength As Long) As Long
Private Declare Function NtDeviceIoControlFile Lib "ntdll" (ByVal FileHandle As Long, ByVal EventHandle As Long, ByVal ApcRoutine As Long, ByVal ApcContext As Long, IoStatusBlock As IO_STATUS_BLOCK, ByVal IoControlCode As Long, InputBuffer As Any, ByVal InputBufferLength As Long, OutputBuffer As Any, ByVal OutputBufferLength As Long) As Long
Private Declare Function NtClose Lib "ntdll" (ByVal FileHandle As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'Device handle
Dim hDev As Long

'Constructor (open the Beep device)
Private Sub Class_Initialize()
    Dim iosb As IO_STATUS_BLOCK
    Dim path As UNICODE_STRING
    Dim objAttr As OBJECT_ATTRIBUTES
    With path
        .Buffer = DD_BEEP_DEVICE_NAME
        .Length = LenB(.Buffer)
        .MaximumLength = .Length + 2
    End With
    With objAttr
        .Length = path.Length
        .ObjectName = VarPtr(path)
    End With
    NtCreateFile hDev, FILE_WRITE_DATA, objAttr, iosb, 0&, 0&, FILE_READ_DATA Or FILE_WRITE_DATA, OPEN_EXISTING, 0&, ByVal 0&, 0&
End Sub

'Destructor (close the Beep device)
Private Sub Class_Terminate()
    NtClose hDev
End Sub

'Get Beep device handle
Public Property Get Handle() As Long
    Handle = hDev
End Property

'Play the sound of the specified frequency and duration
Public Function Play(ByVal dwFreq As Long, ByVal dwDuration As Long) As Boolean
    Dim iosb As IO_STATUS_BLOCK
    Dim bsp As BEEP_SET_PARAMETERS
    With bsp
        .Frequency = dwFreq
        .Duration = dwDuration
    End With
    Play = NtDeviceIoControlFile(hDev, 0&, 0&, 0&, iosb, IOCTL_BEEP_SET, bsp, LenB(bsp), ByVal 0&, 0&) >= 0
End Function
↧

(VB6) Implement the Print method on any object

May 15, 2021, 9:00 pm
$
0
0
You can implement the Print method on any object with the IVBPrint interface (I discovered it some time ago thanks to The Trick).

But besides the interface, you also need some code to handle it.
This sample has in a class module the basics of that code.

It prints on a form, just used as the canvas and also for comparison with the Form's own Print method.

I'm posting this mainly trying to help the new Basics developers, just in case they can take any advantage of this information.

As a side note: this Print method prints Unicode.

Here is the Print method documentation on MSDN.

I have also code for the implementation of all the other related properties and methods:
Circle
Line
PaintPicture
ScaleMode
Scale
ScaleLeft/ScaleTop/ScaleWidth/ScaleHeight
ScaleX/ScaleY

They are not included here, but if they are needed I could help.
Attached Files
↧
↧

VirtualList,VirtualCombo,Virtual_ListView by vb6

May 16, 2021, 8:41 pm
$
0
0
Tutorial - Using Unicode in Visual Basic 6.0 - Free Unicode Controls
http://toolboxw.com/UnicodeTutorialVb.htm
VirtualCombo http://toolboxw.com/UnicodeTutorialV...ucVirtualCombo
VirtualList http://toolboxw.com/UnicodeTutorialVb.htm#ucVirtualList
Credits:
Olaf Schmidt
The Trick Subclass


vbVision -- Various Visual Basic Demos Grouped by Type
http://mvps.org/vbvision/grouped_demos.htm
Virtual_Listbox_Demo
http://mvps.org/vbvision/_samples/Vi...stbox_Demo.zip
Virtual_ListView_Demo
http://mvps.org/vbvision/_samples/Vi...tView_Demo.zip
http://mvps.org/vbvision/_other_files/DbgWProc.zip
↧

VB6 MultiThreading,A new way to get the VB header,For CreateThread

May 17, 2021, 8:13 pm
$
0
0
Msgbox GetVBHeader

Code:
Private Type MODULEINFO
    lpBaseDLL As Long
    ImageSize As Long
    EntryPoint As Long
End Type

Private Declare Function GetModuleInformation Lib "psapi.dll" (ByVal hProcess As Long, ByVal hModule As Long, mInfo As MODULEINFO, ByVal cbSize As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Function GetVBHeader() As Long
  Dim mInfo As MODULEINFO
  GetModuleInformation GetCurrentProcess(), &H400000, mInfo, 12
  If mInfo.EntryPoint Then CopyMemory GetVBHeader, ByVal mInfo.EntryPoint + 1, 4
End Function
↧

Make a Delimited File Demo

May 21, 2021, 5:34 pm
$
0
0
Was not busy ,so I went thru my junk box and threw this together. May be something usable here for someone. Enjoy.
Attached Images
 
Attached Files
↧
Search

Capacitor Values Converter

May 22, 2021, 3:04 pm
$
0
0
This is another project I started but didn't finish. Did not like the way the code was flowing so I stopped working on it . I know there has to be a better way to do this project.
Attached Images
 
Attached Files
↧
↧

Remove Blank Lines and Extra Spaces

May 27, 2021, 4:07 pm
$
0
0
This code will remove blank lines and spaces from your code and resave it converted. I would like it to keep a one blank line between procedures but haven't been able to figure it out yet. If anyone can come up with a solution I would appreciate it.
Attached Files
↧

[VB6] AddIn IDE Codefolding

June 3, 2021, 2:57 pm
$
0
0
This is an add-in to Add Codefolding like capabilities to VB6 IDE


Name: Snap_CodeFold_2.jpg Views: 121 Size: 62.5 KB

Name: Snap_CodeFold_3.jpg Views: 117 Size: 43.2 KB

Name: Snap_CodeFold_1.jpg Views: 118 Size: 21.7 KB





Unfortunately VB6 doesnt support codefolding so I came with an idea to mimic its functionality
by relocating part of the code (Functions/Sub or Regions) towards the bottom of the file and
leaving a placeholder that can be expanded (It can be used with subclasing. The fold storage can be moved up without problems)

I divide foldable content into two types:

-Function/Sub:
They can be Folded without any problem. The project can be opened by anyone without the AddIn and
be 100% compatible.

-Regions:
This are the user defined area (they can be created by selecting the lines and opening the context
menu with the right mouse). Regions can be of three types:
-Outer regions:
Regions that have several Functions/Sub inside. Like before this leave a 100% compatible project.
-Outer region with declares/enums/type:
This ones (usually at the top of the module) are automatically marked to unfold on run/compile.
-Inner region:
This are the regions inside functions.There is no limit on the number of sublevels that can be
created. If folded they are automatically unfolded on run/compile and refolded after.

IMPORTANT!!!: Inner regions need to be padded and every region inside another need another extra level
of padding. Not respecting this rule may break your code.
The last two groups needs the AddIn to be enabled only if they are Folded.
An Unfolded project is still 100% compatible with any VB6 IDE not using the AddIn.


NOTES:
-Sub/Function/Props need scope to be explicit ("Public Sub","Private Sub","Public Func...)
-May fail on FULL COMPILE (CTRL+F5) when Regions are folded and VB6 is configured with
"General->Compile on demand" (This is a bug on VB6 IDE. It dont raise the addIn event)



DOWNLOAD: prj (AddIn) CodeFold v1.0.0.zip
Attached Images
   
Attached Files
↧

Create Procedure Headers

June 4, 2021, 8:29 am
$
0
0
Creates a Procedure Header and copies it to clipboard , to be copied into your code. Very simple code.
Attached Images
 
Attached Files
↧

Simple Usercontrol Toggle/Button

June 7, 2021, 7:35 am
$
0
0
This is a simple toggle/Button usercontrol I threw together. Its probably not perfect, but still useable. See what you think of it. Enjoy.
Attached Images
 
Attached Files
↧
↧

Print to specific PDF file name

June 12, 2021, 11:55 am
$
0
0
Assumes Windows 10 with the optional Microsoft Print to PDF driver installed. This is normally the default unless the user has removed it via Windows Features.

Bare bones example. Note that for the most part printing must be done via API calls to avoid raising the driver's file picker dialog:

Code:
Option Explicit

Private Declare Function EndDoc Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function EndPage Lib "gdi32" (ByVal hDC As Long) As Long

Private Type DOCINFO
    cbSize As Long
    DocName As String
    Output As String
    Datatype As String
    fwType As Long
End Type

Private Declare Function StartDoc Lib "gdi32" Alias "StartDocA" ( _
    ByVal hDC As Long, _
    ByRef DOCINFO As DOCINFO) As Long

Private Declare Function StartPage Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" ( _
    ByVal hDC As Long, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByVal Text As String, _
    ByVal nCount As Long) As Long

Private Sub Main()
    Const LMARGIN As Long = 300
    Const TMARGIN As Long = 500
    Dim P As Printer
    Dim DOCINFO As DOCINFO
    Dim LineHeight As Long
    Dim Y As Long
    Dim I As Long
    Dim Text As String

    For Each P In Printers
        If P.DeviceName = "Microsoft Print to PDF" Then
            Set Printer = P
            GoTo FoundPDF
        End If
    Next
    MsgBox "No ""Microsoft Print to PDF"" driver!", vbExclamation
    Exit Sub

FoundPDF:
    'We can't use Printer.EndPage, Printer.EndDoc, Printer.Print, Printer.PaintPicture,
    'etc. because we need StartDoc() which VB6 will try to do for us "automagically,"
    'thus preventing us from designating the output file programmatically.  I.e. the
    'user will always see the driver's dialog to pick an output file.
    With Printer
        On Error Resume Next
        Kill App.Path & "\specific.pdf"
        On Error GoTo 0
        With DOCINFO
            .cbSize = LenB(DOCINFO)
            .DocName = "To specific file"
            .Output = App.Path & "\specific.pdf"
        End With
        StartDoc .hDC, DOCINFO
        With .Font
            .Name = "Arial"
            .Size = 12
        End With
        LineHeight = Int(.ScaleY(.TextHeight("X"), .ScaleMode, vbPixels))
        StartPage .hDC
        Y = TMARGIN
        For I = 1 To 10
            Text = "Hello"
            TextOut .hDC, LMARGIN, Y, Text, Len(Text)
            Y = Y + LineHeight
            Text = "world!"
            TextOut .hDC, LMARGIN + 250, Y, Text, Len(Text)
            Y = Y + LineHeight * 2 'Double-space here.
        Next
        EndPage .hDC
        EndDoc .hDC
    End With
    MsgBox "Complete"
End Sub
DrawText() normally makes more sense than TextOut(). You can use StdPicture.Render() but not Printer.PaintPicture(), or use BitBlt(), StretchBlt(), etc. for images.
↧

Scramble letters in a word except for the first and last letter

June 12, 2021, 3:13 pm
↧
Search

Image Viewer

June 13, 2021, 3:35 pm
$
0
0
Attached is a Picture Viewer. It does not have a bunch of fancy features, because the intent was to use as much of the screen as possible for the image itself. Inspiration for this program came from dilettante with his "Drop Send Pic".
https://www.vbforums.com/showthread....mage-to-Base64
Before anyone tells me that I could have just loaded the files directly into the Picture Box or the form Picture, I had difficulty in meeting the objectives doing it that way. I needed to not only adjust the container to suit the size of the image, but also to adjust the container for the size of the screen. I loaded the file into a byte array, and then I used a Picture Box because it was the only thing that would support "AutoRedraw". My intent is to eventually produce a remote Picture Viewer similar to dilettantes.

I don't know the reason why, but some "png" files load, and some do not?

J.A. Coutts

Updated: 06/13/2021
Attached Files
↧

Floating Desktop Date

June 14, 2021, 5:12 am
$
0
0
Sits on desktop and features week of year and day of year as well as the date and day. Plus 4 form styles. Fairly simple and straight forward.
Attached Images
 
Attached Files
↧
↧

Send Picture

June 16, 2021, 11:55 am
$
0
0
Attached is a Remote Picture Viewer. It is designed to allow you to post pictures to a remote computer. The Receiver is essentially the Picture Viewer here:
https://www.vbforums.com/showthread....3-Image-Viewer
with TCP capabilities. It uses SimpleSock as a module and class module in order to limit the files needed to be installed.

The Sender on the other hand uses my SimplSock Control, simply to demonstrate that the two are essentially the same. To use the module and class module in the Sender program rather than the control, add the two to the program and remove the control. Then uncomment the following 2 lines:
Code:
'Dim WithEvents mSocket As SimpleSock
'Set mSocket = New SimpleSock
Then remove SimpleSockCTL from the Components list and compile or run.

In order for the Sender to connect to a Receiver, the Receiver should have a static IP address or use a registered domain name. For test purposes, "localhost" & "127.0.0.1" have been added to the combo box. They are the same thing, as I believe that "localhost" is included in all default "hosts" files. If you need to use IPv6, the IPvFlg must be set to 6. This goes for both programs. The default is 4.

When the dropdown arrow on the combo box is clicked, it closes any current connection. When an item in the dropdown list is clicked, a connection is attempted to that address. Success or failure is reflected in the bottom status bar after a one second delay. Once connected, the timer interval is changed to 30 seconds. The purpose of this interval is to allow a reconnection if the connection is broken or changed to a different destination.

Once an image is received, clicking on the image causes the window to disappear. It does not appear on the task bar, and if you look for it with the Task Manager, you will find it in with the Background Processes. Because there is no active window in this state, the only way to terminate the program is to use the Task Manager, or send another image to allow the program to be exited normally. If you want the program to start as a background process, change the form "Visible" property to False.

J.A. Coutts
Attached Files
↧

TaskbarButton Progress

July 6, 2021, 7:59 am
$
0
0
Lightweight, no typelib used just DispCallFunc() hacking.

Requires Windows 7 or later, but the manifest is optional. Works in the IDE but uses subclassing so be cautious.

Demo client Form included:

Code:
Option Explicit

Private Const PROG_TOTAL As Long = 500

Private ProgCompleted As Long
Private WithEvents TaskbarList3 As TaskbarList3

Private Sub Command1_Click()
    TaskbarList3.SetProgressState TBPF_NORMAL
    Command1.Enabled = False
    Timer1.Enabled = True
End Sub

Private Sub Form_Initialize()
    'Could also do this in a Form_Load event handler instead:
    Set TaskbarList3 = New TaskbarList3
    TaskbarList3.ConnectFormToShell32 Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'Redundant since we are unloading anyway.  But normally you'd do this once
    'the action's indicated progress has completed, so we'll show it here:
    With TaskbarList3
        If .Connected Then .SetProgressState TBPF_NOPROGRESS
    End With
End Sub

Private Sub TaskbarList3_Connected()
    Command1.Enabled = True
End Sub

Private Sub Timer1_Timer()
    With TaskbarList3
        If .Connected Then 'Redundant test here, because to get here the Connected
                          'event has been raised so that Command1 got enabled so that
                          'the user could have pressed it so that Timer1 got enabled.
            ProgCompleted = ProgCompleted + 1
            If ProgCompleted > PROG_TOTAL Then ProgCompleted = 0
            .SetProgressValue ProgCompleted, PROG_TOTAL
        End If
    End With
End Sub
Run the demo. Click on Start and watch the Taskbar button. Even works minimized.

You can pause it or mark it "error" and so on as well.
Attached Files
↧

ucListPlus (ListBox, ComboBox, Menu, Autocomplete TextBox)

July 7, 2021, 8:01 am
$
0
0
Hi guys, here is my latest hobby, it is a multipurpose usercontrol, it fulfills the function of a list and tries to fulfill the function of almost everything that is a simple list, ListBox, ComboBox, Menu, Dropdown List, Autocomplete Textbox, The The novelty is that it adds several extras and aesthetic changes, such as rounded edges, shadows, custom items, support for Png and standard images, rounded corners and color changes can be applied to the images in the case of vector images (PNG), item groups, separator bars, filter and subtext. Perhaps it is necessary to correct or add things, whoever is interested can leave their comment or suggestion
Attached Images
   
Attached Files
↧
Viewing all 1484 articles
Browse latest View live
Search
<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>