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

[VB6] Crossword Puzzle Constructor

April 10, 2022, 11:47 am
$
0
0
This is a program i threw together to generate crosswords based on a word/clue list. You can then print out the generated puzzle on a printer or solve it from within the program.

For those that haven't followed the thread on creating the program with SamOscarBrown you can view it here:
https://www.vbforums.com/showthread....word-Generator

Name: ss8.jpg Views: 40 Size: 52.3 KB
Attached Images
 
Attached Files
↧
Search

[VB6] CSharedMemory - class for dynamic memory allocation in shared memory

April 13, 2022, 3:31 am
↧
↧

[VB6] CWaveFile - class for working with WAVE-PCM files.

April 17, 2022, 11:22 am
↧

ReDimPreserve Two dimension array

April 17, 2022, 8:25 pm
$
0
0
Code:
Public Sub ReDimPreserve(arrPreserve, ByVal end_row2&, ByVal end_col2&, Optional ByVal start_row2, Optional ByVal start_col2)
'funtion: to break the limitation that ReDim Preserve cannot handle two-dimension array
'Param1: arrPreserve, original array to be ReDim Preserve
'Param2: end_row2, superscript of 1st dimension
'Param3: end_col2, superscript of 2nd dimension
'Param4: start_row2, subscript of 1st dimension, optional, original array 1st dimension subscript by default
'Param5: start_col2，subscript of 2nd dimension, optional, original array 2nd dimension subscript by default
'Attension: please make sure end_row2 >= start_row2, and end_col2 >= start_col2
    Dim arrTemp As Variant
    Dim i As Long, j As Long
    Dim start_row1 As Long, end_row1 As Long  'original 1st dimension info
    Dim start_col1 As Long, end_col1 As Long  'original 2nd dimension info
    If Not IsArray(arrPreserve) Then Exit Sub
    start_row1 = LBound(arrPreserve, 1)
    end_row1 = UBound(arrPreserve, 1)
    start_col1 = LBound(arrPreserve, 2)
    end_col1 = UBound(arrPreserve, 2)
    If VarType(start_row2) = 10 Then start_row2 = start_row1  'if not given, set to default
    If VarType(start_col2) = 10 Then start_col2 = start_col1  'if not given, set to default
    ReDim arrTemp(start_row2 To end_row2, start_col2 To end_col2) 'dynamic redim new array
    If start_row2 > end_row1 Or _
      end_row2 < start_row1 Or _
      start_col2 > end_col1 Or _
      end_col2 < start_col1 Then  'check if new array subscript or superscript out of original range
        Err.Raise 0, "ReDimPreserve", "New array superscript or subscript out of range"
        Exit Sub
    Else  'contain part of origianl array data at least
        If start_row2 > start_row1 Then start_row1 = start_row2
        If start_col2 > start_col1 Then start_col1 = start_col2
        If end_row2 < end_row1 Then end_row1 = end_row2
        If end_col2 < end_col1 Then end_col1 = end_col2
        For i = start_row1 To end_row1      'copy data by fixed range
            For j = start_col1 To end_col1
                arrTemp(i, j) = arrPreserve(i, j)  'copy data
            Next
        Next
        arrPreserve = arrTemp  'return ByRef
    End If
End Sub
Useage:
Code:
Sub Test()
Dim arr
ReDim arr(1 To 4, 1 To 4)
Dim i&, j&
For i = 1 To 4
    For j = 1 To 4
        arr(i, j) = i & "-" & j
    Next j
Next i
ReDimPreserve arr, 3, 3
ReDimPreserve arr, 3, 3, 0, 0
ReDimPreserve arr, 3, 3, 2, 2
End Sub
↧

Shagratt's VB6 IDE AddIns collection (Latest versions)

April 19, 2022, 9:29 am
$
0
0
Hi Guys! I dont have plans to keep working on them so I'm releasing all my work on VB6 IDE Addins as a collection.
They are all stable and I use all of them daily for my projects.
AddIns included are updated (bugfixed) and unreleased versions.


Screenshots+Videos and Download: https://shagratt.github.io/VB6ideAddins/


The list include:

-Document Map (v2.2)
-Comment Display+Highlight+Hotkeys (v1.2)
-CodeFold (v1.1)
-Fix Palette Button Mod (v1.3)
-Resizer (v1.0)




↧
↧

Create Access 97 database with VB6

April 20, 2022, 1:15 pm
$
0
0
I would like to create an Access 97 database with VB6. Have gotten my code to work one time. But VB6 shut down before code was saved, and have been unable to recreate it. I am running Windows 10 and have Access 97 but my Windows 10 wants me to reinstall Access 97 almost every time I want to use it.
↧

SimpleSock Update

April 23, 2022, 3:46 pm
$
0
0
If you use SimpleSock or SimpleServer, I have found a more efficient and faster way to receive sockets when using a fixed record header. TLS 1.3 encrypted records for example use a fixed 5 byte header.
Code:
    TLSHeader(0) = RecType
    TLSHeader(1) = VERSION_MAJOR
    TLSHeader(2) = VERSION_MINOR_3
    TLSHeader(3) = Reclen (high byte)
    TLSHeader(4) = RecLen (low byte)
It uses a function that was built into these routines that allows a specific number of bytes to be recovered from the Winsock buffer. There was however a bug in SimpleSock that prevented this function from working properly. SimpleServer did not exhibit the same problem, so the SimpleSock download has been updated at:
https://www.vbforums.com/showthread....B6-Simple-Sock

The problem code was in the BuildArray Function.
Code:
    If m_Protocol = SCK_TCP Then 'TCP transfers data from m_bRecvBuffer
        BuildArray = m_bRecvBuffer  'lSize
        If Not blnPeek Then
            Call DeleteByte(m_bRecvBuffer, lSize)
        End If

was changed to:

    If m_Protocol = SCK_TCP Then 'TCP transfers data from m_bRecvBuffer
        ReDim bTmp(lSize - 1)
        CopyMemory bTmp(0), m_bRecvBuffer(0), lSize
        BuildArray = bTmp
        If Not blnPeek Then
            Call DeleteByte(m_bRecvBuffer, lSize)
        End If
Previously, the buffer was managed in the calling function using static variables and self contained buffers:
Code:
Private Sub mClient_EncrDataArrival(ByVal bytesTotal As Long)
    Dim bData() As Byte
    'This routine is re-entrant, hence the next 3 variables must be static
    Static InBuff() As Byte
    Static Header() As Byte
    Static RecLen As Long
    Call mClient.RecoverData
    bData = mClient.bInBuffer
    Call AddByte(InBuff, bData) 'Add data to buffer
GetNextRecord:
    If GetbSize(InBuff) < 5 Then Exit Sub 'If no record length yet then exit & wait
    If RecLen = 0 Then 'New record
        ReDim Header(4)
        CopyMemory Header(0), InBuff(0), 5  'Save Header
        Call DeleteByte(InBuff, 5)          'Remove Header from buffer
        RecLen = CLng(Header(3)) * 256 + Header(4) 'Calculate record length
        Select Case Header(0)
            Case 1, 2, 4, 5, 6, 8, 9, 16
                'Record type OK
            Case Else 'Ignore record
                Call DeleteByte(InBuff, RecLen)
                GoTo Done
        End Select
    End If
    If GetbSize(InBuff) >= RecLen Then  'Complete record available
        ReDim bData(RecLen - 1)      'Resize buffer to record length
        CopyMemory bData(0), InBuff(0), RecLen  'Copy record data to buffer
        Call DeleteByte(InBuff, RecLen) 'Delete record data from inbuff
        Crypt.InBuffer = bData          'Save record to encryption InBuffer
    Else
        Exit Sub 'Wait for complete record
    End If
    'record complete - Process it
....
....
....
Done:
    RecLen = 0
    ReDim Header(0)
    If GetbSize(InBuff) > 0 Then GoTo GetNextRecord
End Sub
Using the class buffer instead, we extract the header, recover the record length, and then wait for the full record to be accumulated in the class buffer. There is no danger of overflowing the class buffer because it is self regulating.
Code:
Private Sub mClient_EncrDataArrival(ByVal bytesTotal As Long)
    Dim bRecord() As Byte
    Dim Header() As Byte
    Dim RecLen As Long
GetNextRecord:
    If RecLen = 0 Then 'Remove header
        If bytesTotal < 5 Then Exit Sub 'If no record length yet then exit & wait
        mClient.RecoverData 5
        Header = mClient.bInBuffer
        Call DebugPrintByte("Header", Header)
        RecLen = CLng(Header(3)) * 256 + Header(4)
        bytesTotal = bytesTotal - 5
    End If
    If RecLen = 0 Then 'Invalid record
        'Do nothing
    ElseIf bytesTotal >= RecLen Then
        mClient.RecoverData RecLen
        bRecord = mClient.bInBuffer
        bytesTotal = bytesTotal - RecLen
        Crypt.InBuffer = bRecord
        'record complete - Process it
....
....
....
Done:
        RecLen = 0
        If bytesTotal > 0 Then GoTo GetNextRecord
    Else
        'Wait for all the data
    End If
End Sub
Using TLS, record lengths are limited, but if you are streaming large records using this technique, you should make "RecLen" static, and process bytes as they are received. This can usually be accomplished by using the SendComplete routine and comparing the total bytes received to RecLen.

J.A. Coutts
↧

Add scroll bars to VB-Forms, PictureBoxes and UserControls

May 8, 2022, 12:48 am
$
0
0
Steve McMahon (www.vbAccelerator.com) provides a Scrollbar class which can add scroll bars to VB-Forms, PictureBoxes and UserControls. But the subclass (SSUBTMR.DLL) used by this class is not IDE-Safe. To test and compare various IDE-Safe subclasses, I replaced SSUBTMR.DLL with 4 subclasses.

The four subclasses are:

(1) The trick's cTrickSubclass
(2) wqweto's MST subclass
(3) RC6.Subclass
(4) jpbro's RC6SubclassWrapper (RC5SubclassWrapper)

Hope this test code is useful to some people.
↧
Search

Environment variable dumper

May 8, 2022, 6:22 pm
$
0
0
Put this code into Form1 of your project and run it. It will put automatically save a file called EnvironmentVariables.txt and then close. This text file contains the environment variables and their values. This text file file will be in your VB6 IDE's working directory, or in the directory where the EXE file is if you already compiled it into an EXE file and ran it from that EXE file.

Code:
Private Declare Function GetEnvironmentStrings Lib "kernel32.dll" Alias "GetEnvironmentStringsA" () As Long
Private Declare Function FreeEnvironmentStrings Lib "kernel32.dll" Alias "FreeEnvironmentStringsA" (ByVal lpsz As Long) As Long
Private Declare Sub GetMem1 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Destination As Any)

Private Sub Form_Load()
    Dim CharVal As Byte
    Dim CurrentString As String
    Dim lpStringBlock As Long
    Dim n As Long
   
    lpStringBlock = GetEnvironmentStrings
   
    Open "EnvironmentVariables.txt" For Output As #1
    n = lpStringBlock
    Do
        GetMem1 ByVal n, CharVal
        If CharVal = 0 Then
            If Len(CurrentString) > 0 Then
                Print #1, CurrentString; vbCrLf
                CurrentString = ""
            Else
                Exit Do
            End If
        Else
            CurrentString = CurrentString & Chr$(CharVal)
        End If
        n = n + 1
    Loop
    Close #1
   
    FreeEnvironmentStrings lpStringBlock
   
    Unload Me
End Sub
Note that the line "Print #1, CurrentString; vbCrLf" contains a vbCrLf, even though it seems redundant (as the Print statement already will automatically put Cr and Lf characters at the end of each line), for a very good reason. It puts a blank line between lines of output text. This is to accommodate the line-wrap that Windows Notepad uses for too-long lines of text, and guaranty separation of the environment variables. In particular, the value stored for the PATH environment variable is VERY long. Notepad will automatically line-wrap at the end of long lines (even breaking words in the middle), even if you have disabled the "word wrap" option. The word wrap option breaks lines when they are longer than the width of the Notepad window, and guaranties that there won't be a break in the middle of a word, but Notepad still forces a break on lines that are too long (they go WAY PAST the width of the Notepad window) even with word wrap disabled, and that can't be disabled. To guaranty visual separation of environment variables in Windows Notepad, I've made sure that there's a blank line after every environment variable (otherwise each next environment variable will be on the next line, but there also could be a next line for the same variable if it's too long, and this leads to ambiguity).

If you are using Notepad++ (a 3rd party software, not part of Windows), it doesn't automatically break a line no matter how long it is, making the insertion of blank lines between environment variables unnecessary. If you will be viewing the text file output from my program in Notepad++, then you can change the line "Print #1, CurrentString; vbCrLf" in the above code to instead say "Print #1, CurrentString". This will keep the text file smaller, and in Notepad++ it is guarantied that each environment variable will be entirely on its own line.
↧
↧

ucCalendar (Events calendar)

May 14, 2022, 9:03 am
$
0
0
Hi, I want to share my last user control of a calendar of events, I will not be able to upload the control here since within the example I use two dll to link the calendar to a database with SQLite, so I will put the link to download directly from my website, if any moderator considers this inappropriate you can delete this post.

Name: ucCalendar_Month.jpg Views: 49 Size: 19.4 KB

Name: ucCalendar_Week.jpg Views: 48 Size: 19.0 KB



Go to web page:
http://leandroascierto.com/blog/ucca...io-de-eventos/
Attached Images
  
↧

Export/Import Variables, Properties & UDT's for VB6 & VBA

May 22, 2022, 4:36 am
$
0
0
This system enables you to bundle data from a program into a highly compact binary array that can be sent to other programs, saved to disk, re-used within a program, etc. It works in 32- and 64-bit VBA and VB6. It allows you to easily transfer data between 32 and 64-bit programs. You specify one or more variables in your program to bundle and BinaryMagic will auto-generate the code you can include in your code to bundle the variables any time you want to. There is an equivalent set of procedures that allow you use the binary array and copy those values back into variables, presumably in the import program. Below are some simple examples of its use:


  • Saving and restoring data for forms including size and position and values for the controls on the form. You can save this to file and easily restore it the next time your form loads.
  • You want to pass data between 2 programs that are running at the same time. This data can be saved to a file or it could be sent via COM, memory-mapped files, etc.
  • You have a 64-bit VBA program and you want to use a sophisticated form for Data I/O. Oops, Microsoft crippled 64-bit VBA from when it first came out in Office 2010 and it only has a bare minimum of forms available for you to use. Now that Krool, fafalone and others on VBForums have created modern Unicode-capable controls for 32-bit VB6, you might be tempted to run your VBA code, shell out to a VB6 program which will restore prior data, get user input using these new controls on VB6 Forms and transmit the user entry data back to the VBA program. It is normally not so easy to send data between a 64-bit and a 32-bit program but we will show you how easy this is a bit later.
  • You can save/restore your program settings to/from the Windows Registry with all of the data in one binary string.
  • You can easily take the binary array generated for export and make it into a String (such as for an INI file) and then easily get the binary data back from the String on the Import PC with no data loss (we do it in such a fashion that VB does not try to convert the data from Unicode to ANSI).


We can handle virtually any type of data or properties VB can generate in any order including:

  • Scalar values such as Byte, Integer, Long, Boolean, Date, Single, Double, Currency and Boolean. These include individual values and arrays of any size up to 10 dimensions.
  • Scalar values unique to 64-bit VBA- LongLong and LongPtr including arrays of up to 10 dimensions. It even handles movement of these data types to/from 64 and 32-bit programs even though 32-bit programs don’t have these data types.
  • Strings (and String arrays) - Completely copied/restored in Unicode (no ANSI conversion).
  • Variants- This is by far the most complex variable in VB. It can contain any of the scalar values; it can handle arrays of any type including more Variants; it can contain arrays of arrays; and it can contain arrays of mixed data types. We handle any of these.
  • User-Defined Types (UDT’s)- It can handle simple and array UDT's. It can handle any complexity of UDT’s including nested to any levels. For example, a UDT can contain other UDT’s within its Type definition and that UDT can be simple or array or even contain other UDT’s. If you want to save all of the variables in a UDT you can do so with one line of code.
  • Objects, individual and arrayed- Note that at present, any arriving objects are set to Nothing. This program exports a set of values and an Object is not a value but rather a link to something else. For example, if you have a variable in Excel defined as “myWorksheet As Worksheet” and you used Set to start the COM connection, sending that connection to another program makes no sense because the other program wouldn’t have the connection made so it couldn’t use the Object information. In order to not crash the data transfer I decided to include Objects but will set them to Nothing (no Object data is sent and all Objects on the incoming end are Set to Nothing). You can still have arrays of Objects, up to 10 dimensions with each member Set to Nothing.
  • Public variables in Class/Standard modules and Forms.
  • Properties in Class/Standard modules and Forms. This includes Property Get (for export) and Property Let (for import). Note that these are actually not variables but are instead stack values that may be manipulated in the Class or Form code. If you Export/Import properties, ensure that you have a Property Get in the Exporting program and a corresponding Property Let in the importing program. Note also that the Property Get/Let statements can only have the property itself in the call. No other passed parameters are allowed. That isn't as restrictive as it sounds. If you have Property Get/Let statements that take additional parameters, you can just do the calls, assign the property to a variable on the Export and use that variable. Then reverse that on the import side by making the value you exported to a variable and then use that variable plus whatever other parameters you need for the Property Let call.
  • In general, a Variant cannot contain a UDT. There is an exception for ActiveX DLL’s and EXE’s. My impression is that this is rarely used so I chose not to deal with UDT’s in Variants (let me know if you think otherwise). I believe I cover all other VB variables as well as properties but if you find I have missed one or more, please let me know and I’ll make sure it is covered.


Variable Scope- One key aspect of all of this is that your variables and properties need to be in scope wherever you make the calls in both the exporting program and the importing program. For example, suppose you have two modules, ModA and ModB and that you have a variable you declare with a Dim statement in ModB which makes that variable only available in ModB. If you put the generated code (more on that in a bit) in ModA, you can’t export the Dim’d variable in ModB because it is not visible in ModA.

This is really no different than your normal coding. If you have a statement “a = b + c” in ModA but “c” is Dim’d as a local variable in another procedure, your code won’t work because the code can’t “see” variable “c”.

Enums- We can handle values (alone or as an array) declared as an Enum but you must tell our code that it is an Enum. Any variable declared as an Enum is actually a Long so you will need to tell our code that it is an Enum so it can be dealt with as a Long. Otherwise, the code will check all of the other variables and UDT definitions and Objects for the variable Type and will not find it, generating an error. It is easy to handle this and we’ll cover this later.

Objects- Likewise, if you have a variable declared as an Object, we won’t know what to do with it (and will error like described above because we can’t find its Type). The easiest thing to do is change the declaration in your code to be a variable of Type Object instead of Workbook or whatever else you have defined it to be. This is not a big deal since our code will set it to Nothing on the import end so we really don’t need to know what Type of Object it really is.

If you need to move the binary array as a String or a Variant, this is very simple to do and I provide easy directions for how to do this (especially important for strings so you don't get the "helpful" VB technique of automatically converting the internal Unicode string to ANSI which is horrible for binary data).

There are 3 examples attached for VB6 and 3 for Excel. A detailed user's guide is attached. I believe I have handled every type of variable you can use except for UDT's inside of a Variant. If I have left out any variable or Property types, please let me know and I'll get them included.

I have focused on generating the binary array and restoring data from the binary array. There are many ways to get this data to move where you need it, much of which has been covered in VBForums. This includes reading/writing to the registry, comm between processes such as pipes, memory mapped files, sockets, disk files, Windows messages etc. so I have not specifically covered that here other than in one of the examples.
Attached Files
↧

Luhn checksum algorithm

May 22, 2022, 3:34 pm
$
0
0
This allows you to calculate the Luhn checksum for a string of decimal digits, as well as to validate that checksum. Here's the code.
Code:
Public Function Luhn(ByVal DecimalString As String) As Byte
    Dim x As Long
    Dim y As Long
    Dim temp As String
    Dim n As Long
   
    If InStr(1, DecimalString, "-") Then
        DecimalString = Replace("DecimalString", "-", "")
    ElseIf InStr(1, DecimalString, " ") Then
        DecimalString = Replace("DecimalString", " ", "")
    End If
   
   
    n = 1
    For x = Len(DecimalString) To 1 Step -1
        temp = CLng(Mid$(DecimalString, x, 1)) * ((n And 1) + 1)
        If Len(temp) = 2 Then
            y = y + CLng(Mid$(temp, 1, 1)) + CLng(Mid$(temp, 2, 1))
        Else
            y = y + CLng(temp)
        End If
        n = n + 1
    Next x
    Luhn = (10 - (y Mod 10)) Mod 10
End Function

Public Function LuhnAppend(ByVal DecimalString As String) As String
    LuhnAppend = DecimalString & CStr(Luhn(DecimalString))
End Function

Public Function LuhnValidate(ByVal DecimalString As String) As Boolean
    LuhnValidate = (Luhn(Left$(DecimalString, Len(DecimalString) - 1)) = CByte(Right$(DecimalString, 1)))
End Function

Public Function LuhnValidateSeparate(ByVal DecimalString As String, ByVal Checksum As Byte) As Boolean
    LuhnValidateSeparate = (Luhn(DecimalString) = Checksum)
End Function
Just paste that code in a module and the functions will be accessible from anywhere else in your code. The functions are used as follows.
Luhn() calculates the Luhn checksum from a string of decimal digits, and outputs that checksum as a byte.
LuhnAppend() calculates the Luhn checksum from a string of decimal digits, and outputs a string that contains the original string with the checksum digit appended to it.
LuhnValidate() takes a complete decimal string including the checksum digit, and validates it. The output is boolean (True or False)
LuhnValidateSeparate() takes a decimal string without the checksum digit, and validates it against a separately provided byte that contains the checksum digit. The output is Boolean.

The Luhn calculation function ignores common separators found in decimal digit strings that typically use the Luhn checksum (such as those on credit cards). These separators are spaces and dashes.
↧

Visual Basic IDE dependencies

May 26, 2022, 9:43 am
$
0
0
Good afternoon guys

I happen to be playing with Visual Basic and I have several third party applications written in this language that I think have downgraded the versions of some system files.

When I'm creating a project and I checked the components and their versions, I realised that I'm not using the latest DLLs in the system. So I downloaded a DLL and OCX updater for an Argentinian game. And there it turns out that I found more outdated versions.

Too bad the updater didn't give any log. So I can't tell which file versions I had and which ones I have now. But I found it all very strange.
Is there something similar but more reliable?

I would like to know what system DLLs I may be using Visual Basic6 I have out of date please, manually is a headache.

These are the files that the updater comes with, how do I know these are the latest versions?, some are not from Microsoft, as this was meant to update a game:

[
{
"filename": "MSVBVM60.DLL",
"type_lib": "{000204EF-0000-0000-C000-000000000046}\\6.0\\9\\win32",
"version": "6.0.98.48",
"checksum": "898288bd3b21d0e7d5f406df2e0b69a5bbfa4f241baf29a2cdf8a3cf4d4619f2",
"filesize": 1436032
},
{
"filename": "MSVBVM50.DLL",
"type_lib": "{000204EF-0000-0000-C000-000000000046}\\5.0\\9\\win32",
"version": "5.1.43.19",
"checksum": "4aef0066e8e4bad65018ec85d46b902303155ec2d8f049f3803e571005a90ff0",
"filesize": 1347344
},
{
"filename": "MSINET.OCX",
"type_lib": "{48E59290-9880-11CF-9754-00AA00C00908}\\1.0\\0\\win32",
"version": "6.1.98.16",
"checksum": "b1212253d0c2b96dbdc6985b93338be288b0c8d827481f9c607dde5bdfdbfc6b",
"filesize": 136008
},
{
"filename": "RICHTX32.OCX",
"type_lib": "{3B7C8863-D78F-101B-B9B5-04021C009402}\\1.2\\0\\win32",
"version": "6.1.98.16",
"checksum": "e777685f35a3c84e996d8090173a1df9b97c9be194ba3660d20d62b7cbe9cf12",
"filesize": 218432
},
{
"filename": "CSWSK32.OCX",
"type_lib": "{33101C00-75C3-11CF-A8A0-444553540000}\\1.0\\0\\win32",
"version": "3.60.0.3650",
"checksum": "cfde61101ce134feade5d75608bd30264b9ef5472e6937fce0627d58d4c16c43",
"filesize": 107560
},
{
"filename": "MSWINSCK.OCX",
"type_lib": "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}\\1.0\\0\\win32",
"version": "6.1.98.17",
"checksum": "abe67b995d2c3f3898a84fe877ea1913658eaacf9841774204353edf5945674c",
"filesize": 126800
},
{
"filename": "MSCOMCTL.OCX",
"type_lib": "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}\\2.1\\0\\win32",
"version": "6.1.98.34",
"checksum": "45b6eef5bbf223cf8ff78f5014b68a72f0bc2cceaed030dece0a1abacf88f1f8",
"filesize": 1070152
},
{
"filename": "COMCTL32.OCX",
"type_lib": "{6B7E6392-850A-101B-AFC0-4210102A8DA7}\\1.3\\0\\win32",
"version": "6.0.98.16",
"checksum": "4f97aa44d3f5ecab907908d44a2cccd73ad67193fc10084ee1ba01577d9ad384",
"filesize": 614992
},
{
"filename": "COMDLG32.OCX",
"type_lib": "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}\\1.2\\0\\win32",
"version": "6.1.98.16",
"checksum": "00b5af20504fa3440ef3f9670a49963622d1a3557090e349f465746213761cef",
"filesize": 155984
},
{
"filename": "CAPTURA.OCX",
"version": "1.0.0.0",
"checksum": "420ade9b75d3f7e7e76d65ac1abff7d6c92881727edcd0f5fda31172808c8add",
"filesize": 18944
},
{
"filename": "MSADODC.OCX",
"type_lib": "{67397AA1-7FB1-11D0-B148-00A0C922E820}\\6.0\\0\\win32",
"version": "6.1.98.16",
"checksum": "bcab3a5650bafc096a97479f3eca26f1a4a153a9bf4cff080b9146e2bfab5cd3",
"filesize": 134976
},
{
"filename": "VBALPROGBAR6.OCX",
"type_lib": "{55473EAC-7715-4257-B5EF-6E14EBD6A5DD}\\1.0\\0\\win32",
"version": "1.0.0.6",
"checksum": "dd8cbb91f9a355e9f7511c47df404b8b53612ff65341e68eff555541cbd20c95",
"filesize": 65536
},
{
"filename": "MCI32.OCX",
"type_lib": "{C1A8AF28-1257-101B-8FB0-0020AF039CA3}\\1.1\\0\\win32",
"version": "6.0.81.69",
"checksum": "07bf28692ac79fd7e7de7cff2291ea945bb5a60d427ae2fd7a19dde738b67438",
"filesize": 198456
},
{
"filename": "DX7VB.DLL",
"type_lib": "{E1211242-8E94-11D1-8808-00C04FC2C602}\\1.0\\0\\win32",
"version": "5.3.2600.5512",
"checksum": "10a75e490fd192533c6907cd8159c4911258cffdfc557dc35d3dd49c0b813f17",
"filesize": 619008
},
{
"filename": "DX8VB.DLL",
"type_lib": "{E1211242-8E94-11D1-8808-00C04FC2C603}\\1.0\\0\\win32",
"version": "5.3.2600.5512",
"checksum": "74ac3a4c95510ad7b9c885edb8630cb2c132128d71b43b3f56567a18a5026747",
"filesize": 1227264
},
{
"filename": "QUARTZ.DLL",
"clsid": "{05589FAF-C356-11CE-BF01-00AA0055595A}\\InprocServer32",
"version": "6.6.7601.18526",
"checksum": "7dba5d646583d8b4170ed7ec204c17e71b8162b72c0a32f2bd9e8d899a692c5a",
"filesize": 1329664
},
{
"filename": "SHDOCVW.DLL",
"clsid": "{EF4D1E1A-1C87-4AA8-8934-E68E4367468D}\\InprocServer32",
"version": "10.0.19041.746",
"checksum": "c2514c508bb6fc1054b51f77d08d2100cd3820ef2862bdf31b2d953de088e419",
"filesize": 245760
},
{
"filename": "OLEAUT32.DLL",
"clsid": "{0000002F-0000-0000-C000-000000000046}\\InprocServer32",
"version": "10.0.19041.804",
"checksum": "035615f58e6adeae27edbc4cc7eb6a9f6ca6133288af9ec4e0e54f5e81b24741",
"filesize": 831024
},
{
"filename": "OLEPRO32.DLL",
"version": "6.1.7601.17514",
"checksum": "c09909b89183b89ba87cac8c5bebd0e995c5cb08cc9b9d1e88352103ee958857",
"filesize": 90112
},
{
"filename": "MSSTDFMT.DLL",
"type_lib": "{6B263850-900B-11D0-9484-00A0C91110ED}\\1.0\\0\\win32",
"version": "6.1.98.39",
"checksum": "74ef23860b9ed15587eae06670e83abac1928b502dad244875713d127d83a1df",
"filesize": 130712
},
{
"filename": "MPR.DLL",
"version": "5.1.2600.2180",
"checksum": "e9205e45cbcbe9e355d497a16a1769cf651cb8cb96a7e4ddb5d0ac0a9bee4689",
"filesize": 59904
},
{
"filename": "MSCOMCTL.DLL",
"version": "10.0.4504.0",
"checksum": "be2885e897470da3778a661158dc21f32a4aada769996abda082cc4bb6030086",
"filesize": 229376
},
{
"filename": "SCRRUN.DLL",
"clsid": "{0CF774D0-F077-11D1-B1BC-00C04F86C324}\\InprocServer32",
"version": "5.812.10586.0",
"checksum": "7852e688f17ed0598ceb00e2d525241e6a2e8d0c035617ff04b3b1c52abd75aa",
"filesize": 165888
},
{
"filename": "UNZIP32.DLL",
"version": "1.1.0.0",
"checksum": "6343b6c89d9dce1dd0c320d68a650ed053e31d3eecea75d376947c4cec222ff6",
"filesize": 143360
}
]
↧
↧

VB6 TileHandling and Unicode-Shapes

June 6, 2022, 1:21 pm
$
0
0
There's a lot of Unicode-Symbols in the upper CodePoint-Ranges, which are suitable for simple Game-Purposes.
- e.g. for Chess-Pieces: https://en.wikipedia.org/wiki/Chess_...2_chess_pieces
- but also for Cards: https://en.wikipedia.org/wiki/Playing_cards_in_Unicode

With proper Unicode-Textoutput-Methods (as e.g. TextOutW, which is used here),
one can use these "complex Shapes in a single Character" instead of Image-Resources.

The whole thing was inspired by this thread: https://www.vbforums.com/showthread....=1#post5569943
(and the questions which followed, which were also about the TileHandling)...

So the Code below shows an "Excel-like" Cell- (or Tile-) addressing,
using a Dictionary behind a cTileArea-Object, to manage each Tile individually.
The addressing-scheme is currently "Bottom-Up" like in Chess (from "a1" to "h8") -
but this can be switched in cTileArea.Init (along with the amount of Tiles), to make it "Top-Down" like in Excel.

An additional cCanvas-Object (bound to a normal VB.PictureBox) provides special Rendering-Support.

Here is, what it produces:
Name: TileHandling.png Views: 63 Size: 122.4 KB

And here is the Project-Code:
TileHandling.zip

Have fun,

Olaf
Attached Images
 
Attached Files
↧

Image (de)compressor

June 12, 2022, 1:31 am
$
0
0
This code should go in a module.
Code:
Public Sub CompressImage(ByRef PixIn() As Long, ByVal Width As Long, ByVal Height As Long, ByVal OutputFileName As String, ByVal ThresholdForCopy As Long)
    Dim Selectors() As Byte
    Dim PackedSelectors() As Byte
    Dim PSelByteCount As Long
    Dim Pix() As Long
    Dim NewColors() As Long
    Dim x As Long
    Dim y As Long
    Dim n As Long
    Dim NewColorCount As Long

   
    ReDim Selectors(Width - 1, Height - 1)
    ReDim Pix(Width - 1, Height - 1)
    ReDim NewColors(Width * Height - 1)
   
    For y = 0 To Height - 1
        For x = 0 To Width - 1
            If (x > 0) And (y > 0) Then Selectors(x, y) = GetSelector(PixIn(x, y), Pix(x - 1, y), Pix(x, y - 1), Pix(x - 1, y - 1), ThresholdForCopy)
            Select Case Selectors(x, y)
                Case 0
                    NewColors(n) = PixIn(x, y)
                    Pix(x, y) = NewColors(n)
                    n = n + 1
                Case 1
                    Pix(x, y) = Pix(x - 1, y)
                Case 2
                    Pix(x, y) = Pix(x, y - 1)
                Case 3
                    Pix(x, y) = Pix(x - 1, y - 1)
            End Select
        Next x
    Next y
    NewColorCount = n
    ReDim Preserve NewColors(NewColorCount - 1)
   
    PSelByteCount = Ceil(Width * Height / 4)
    ReDim PackedSelectors(PSelByteCount - 1)
    n = 0
    For y = 0 To Height - 1
        For x = 0 To Width - 1
            PackedSelectors(n \ 4) = PackedSelectors(n \ 4) + Selectors(x, y) * 4 ^ (n And 3)
            n = n + 1
        Next x
    Next y
   
    Open OutputFileName For Output As #1
    Close #1
   
    Open OutputFileName For Binary As #1
        Put #1, 1, Width
        Put #1, , Height
        Put #1, , PSelByteCount
        Put #1, , NewColorCount
        Put #1, , PackedSelectors()
        Put #1, , NewColors()
    Close #1
End Sub

Public Sub DecompressImage(ByVal InputFilename As String, ByRef Width As Long, ByRef Height As Long, ByRef PixOut() As Long)
    Dim PackedSelectors() As Byte
    Dim PSelByteCount As Long
    Dim Pix() As Long
    Dim NewColors() As Long
    Dim x As Long
    Dim y As Long
    Dim n As Long
    Dim n2 As Long
    Dim NewColorCount As Long
   
    Open InputFilename For Binary Access Read As #1
        Get #1, 1, Width
        Get #1, , Height
        Get #1, , PSelByteCount
        Get #1, , NewColorCount
        ReDim PackedSelectors(PSelByteCount - 1)
        ReDim NewColors(NewColorCount)
        Get #1, , PackedSelectors()
        Get #1, , NewColors()
    Close #1
    ReDim PixOut(Width - 1, Height - 1)
   
   
    For y = 0 To Height - 1
        For x = 0 To Width - 1
            Select Case (PackedSelectors(n \ 4) \ (4 ^ (n And 3))) And 3
                Case 0
                    PixOut(x, y) = NewColors(n2)
                    n2 = n2 + 1
                Case 1
                    PixOut(x, y) = PixOut(x - 1, y)
                Case 2
                    PixOut(x, y) = PixOut(x, y - 1)
                Case 3
                    PixOut(x, y) = PixOut(x - 1, y - 1)
            End Select
            n = n + 1
        Next x
    Next y
   
End Sub


Private Function GetSelector(ByVal PixCurrent As Long, ByVal PixLeft As Long, ByVal PixUp As Long, ByVal PixUpLeft As Long, ByVal Threshold As Long) As Byte
    Dim MinDiff As Long
    Dim DiffLeft As Long
    Dim DiffUp As Long
    Dim DiffUpLeft As Long
   
    DiffLeft = GetPixDiff(PixCurrent, PixLeft)
    DiffUp = GetPixDiff(PixCurrent, PixUp)
    DiffUpLeft = GetPixDiff(PixCurrent, PixUpLeft)
   
    MinDiff = 255 * 3
    If DiffLeft < MinDiff Then MinDiff = DiffLeft
    If DiffUp < MinDiff Then MinDiff = DiffUp
    If DiffUpLeft < MinDiff Then MinDiff = DiffUpLeft
   
    Select Case MinDiff
        Case Is > Threshold
            'do nothing
        Case Is = DiffLeft
            GetSelector = 1
        Case Is = DiffUp
            GetSelector = 2
        Case Is = DiffUpLeft
            GetSelector = 3
    End Select
End Function


Private Function GetPixDiff(ByVal Pix1 As Long, ByVal Pix2 As Long) As Long
    Dim R1 As Long
    Dim G1 As Long
    Dim B1 As Long
    Dim R2 As Long
    Dim G2 As Long
    Dim B2 As Long
   
    R1 = (Pix1 \ &H1) And &HFF
    G1 = (Pix1 \ &H100) And &HFF
    B1 = (Pix1 \ &H10000) And &HFF
    R2 = (Pix2 \ &H1) And &HFF
    G2 = (Pix2 \ &H100) And &HFF
    B2 = (Pix2 \ &H10000) And &HFF
   
    GetPixDiff = Abs(R1 - R2) + Abs(G1 - G2) + Abs(B1 - B2)
End Function




Private Function Ceil(ByVal Value As Double) As Long
    Ceil = -Int(-Value)
End Function
I've tested it and it is fully functional. It compresses an array of pixels (represented as Long values, in the order RGBA as used by VB6, though Point and PSet ignore the A channel) and saves it to a file. The decompress loads a file that's saved in the format that's written by the compressor, and reads its header and compressed image data and reconstructs the image. It is a lossy compression when ThresholdForCopy > 0. The farther above 0 the threshold is, the more lossy the compression is. It's lossless compression when ThresholdForCopy = 0. It uses no compression (just writes raw pixel values) when ThresholdForCopy < 0. It doesn't matter what the value of the negative number is (it can be -1 or -872346). It just needs to be negative to write raw pixel values.
↧
Search

VB6 A simple approach to Lighweight-Classes

June 12, 2022, 3:19 pm
$
0
0
As the title says already - another approach to LW-COM -
hopefully simple(r) to understand, because:
- it doesn't require to implement "all the Methods in the *.bas-Module"
- instead, method-implementation remains in the Class-CodeFile
- only the 3 Members of the IUnknown-interface will be swapped

On 32Bit, the minimal Class-Instance-size is only 8Bytes (half the size of a Variant).

Userdefined Private-Variables (when added to the two default-instance-members),
will increase the mem-usage from these 8Bytes obviously...
Performance (especially on instance-teardown) is as nice as one would expect from an lw-approach...

I've commented quite a bit, so there's more explanations in the code-modules.

Here's the Zip: SimpleLightWeightObjects.zip

Have fun,

Olaf
Attached Files
↧

[VB6] Code snippet: Run unelevated app from elevated app

June 16, 2022, 12:50 am
$
0
0
Surprised I didn't see an example of this, so wanted to post it.

Here's a quick implementation of a method to run unelevated apps from your elevated app by routing it through Explorer, as outlined by Raymond Chen.

Requirements
-oleexp.tlb v5.01 or higher, with included addon mIID.bas (released the same day as this snippet... I had a partial set of the shell automation objects in oleeximp.tlb, not sure why it was complete, or not in oleexp.tlb, so for convenience I put out a quick new version with a complete set in oleexp.tlb. So you only need oleexp.tlb 5.01 (and mIID.bas) if you get the new version. Otherwise that, oleexpimp.tlb, and shell32).

-Windows XP or newer

Code

Code:
Public Sub LaunchUnelevated(sPath As String, Optional sArgs As String = "")
Dim pShWin As ShellWindows
Set pShWin = New ShellWindows

Dim pDispView As oleexp.IDispatch 'VB6 has a built in hidden version that will cause an error if you try to use it. Specify oleexp's unrestricted version.
Dim pServ As IServiceProvider
Dim pSB As IShellBrowser
Dim pDual As IShellFolderViewDual
Dim pView As IShellView

Dim vrEmpty As Variant
Dim hwnd As Long

Set pServ = pShWin.FindWindowSW(CVar(CSIDL_DESKTOP), vrEmpty, SWC_DESKTOP, hwnd, SWFO_NEEDDISPATCH)

pServ.QueryService SID_STopLevelBrowser, IID_IShellBrowser, pSB

pSB.QueryActiveShellView pView

pView.GetItemObject SVGIO_BACKGROUND, IID_IDispatch, pDispView
Set pDual = pDispView
 
Dim pDispShell As IShellDispatch2
Set pDispShell = pDual.Application

If sArgs <> "" Then
    pDispShell.ShellExecute sPath, CVar(sArgs)
Else
    pDispShell.ShellExecute sPath
End If
End Sub
And it's that simple. Just call LaunchUnelevated with a path to the exe.
↧
↧

vb6 Api ReadFile,SaveFile with NtReadFile,NtWriteFile

June 23, 2022, 3:21 am
$
0
0
Code:
Private Declare Function OpenFile& Lib "kernel32" (ByVal FileName As String, ByVal OFs As Long, ByVal Flags As Long)
Private Declare Function NtReadFile& Lib "ntdll" (ByVal Handle As Long, ByVal Events As Long, ByVal APCRoutine As Long, ByVal APCContext As Long, ByVal IoStatus As Long, ByVal Buffer As Long, ByVal Length As Long, Optional ByVal Number As Long, Optional ByVal Keys As Long)
Private Declare Function NtWriteFile& Lib "ntdll" (ByVal Handle As Long, ByVal Events As Long, ByVal APCRoutine As Long, ByVal APCContext As Long, ByVal IoStatus As Long, ByVal Buffer As Long, ByVal Length As Long, Optional ByVal Number As Long, Optional ByVal Keys As Long)
Private Declare Function CloseHandle& Lib "kernel32" (ByVal Handle As Long)

Public Function ReadFile(ByVal FileName As String, ByRef ByteIn() As Byte) As Boolean
Dim Handle&, Block&(1), Struct&(33)
ReDim ByteIn(FileLen(FileName))
Handle = OpenFile(FileName, VarPtr(Struct(0)), 0)
If NtReadFile(Handle, 0, 0, 0, VarPtr(Block(0)), VarPtr(ByteIn(0)), UBound(ByteIn)) = 0 Then ReadFile = True
CloseHandle Handle
End Function
Public Function WriteFile(ByVal FileName As String, ByRef ByteIn() As Byte) As Boolean
Dim Handle&, Block&(1), Struct&(33)
CloseHandle OpenFile(FileName, VarPtr(Struct(0)), 4096)
Handle = OpenFile(FileName, VarPtr(Struct(0)), 1)
If NtWriteFile(Handle, 0, 0, 0, VarPtr(Block(0)), VarPtr(ByteIn(0)), UBound(ByteIn) + 1) = 0 Then WriteFile = True
CloseHandle Handle
End Function

 Function SaveFileEncode(FileName, strFileBody, Optional Charset = "gb2312") As Boolean
  Dim ADO_Stream ' As New ADODB.Stream
        Set ADO_Stream = CreateObject("Adodb.Stream")
        On Error GoTo ferr
    With ADO_Stream
        .Type = 2
        .Mode = 3
        .Charset = Charset
          .Open
        .WriteText strFileBody
        .SaveToFile FileName, 2
    End With
      SaveFileEncode = True
      Exit Function
ferr:
 End Function

Private Sub Form_Load()
SaveFileEncode "test.txt", "testABCD"
Dim Temp() As Byte
Me.Caption = ReadFile("test.txt", Temp)
 
MsgBox StrConv(Temp, vbUnicode)
Erase Temp
'Me.Caption = ReadFile("C:\WINDOWS\notepad.exe", Temp)
Temp = StrConv("testNew", vbFromUnicode)
MsgBox "Length：" & UBound(Temp) + 1
Me.Caption = WriteFile("test2.txt", Temp)

 Erase Temp
Call ReadFile("test2.txt", Temp)
 
MsgBox StrConv(Temp, vbUnicode)

End Sub
↧

RC5 Sqlite Like Adodb.Connection/Adodb.RecordSet(WithOut Reg Com Dll)

June 25, 2022, 6:05 am
$
0
0
Code:
Sub TestSqliteComDll()
    Dim Cnn As cConnection
    Set Cnn = New_cConnection
    MsgBox Cnn.Version
End Sub
Code:
Option Explicit
'免注册加载DLL-
''COM DLL可以放在当前目录或SysWOW64就能引用成功,
'C:\Windows\SysWOW64

'Set cn2 = CreateObjectXX("sqlite3.dll", ClsStr_Obj) '放在系统目录，可以不带路径
'Set cn2 = CreateObjectXX(ThisWorkbook.path & "\sqlite3.dll", ClsStr_Obj)
'DLL放在当前目录，要添加完整路径

Private Type UUID
    d1 As Long
    d2 As Integer
    d3 As Integer
    d4(7) As Byte
End Type

Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As UUID) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal str As Long, id As UUID) As Long

Private Declare Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long

 Function New_cRecordset() As cRecordset
    Set New_cRecordset = CreateObjectXX(App.Path & "\dhRichClient3.dll", _
    "{351A3F14-5448-40A6-8E25-1F55A2CF989D}")
End Function


Function New_cConnection() As cConnection
    Set New_cConnection = CreateObjectXX(App.Path & "\dhRichClient3.dll", _
    "{6B16C696-FB30-42CE-827C-090956209CEC}")
End Function


Function CreateObjectXX(DllFileName As String, sCLSID As String, Optional ForIID_IDispatch As Boolean, Optional H As Long) As Object
'先声明对象真实类型才可以免注册加载COM DLL
    Const sIID_IClassFactory As String = "{00000001-0000-0000-C000-000000000046}"
    Const sIID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
    Const sIID_IUnknown  As String = "{00000000-0000-0000-C000-000000000046}"
    Dim lCLSID As UUID, IID_IClassFactory As UUID, IID_IDispatch As UUID, IID_IUnknown As UUID

    Dim lOle As Object, fo As Object
    Dim FUNC As Long, ret As Variant, ty(2) As Integer, pm(2) As Long, vParams(2) As Variant
   
    IIDFromString StrPtr(sIID_IClassFactory), IID_IClassFactory
    IIDFromString StrPtr(sIID_IDispatch), IID_IDispatch
    IIDFromString StrPtr(sIID_IUnknown), IID_IUnknown
   
    CLSIDFromString StrPtr(sCLSID), lCLSID
    H = LoadLibrary(DllFileName)
    FUNC = GetProcAddress(H, "DllGetClassObject")
   
    ty(0) = vbLong
    ty(1) = vbLong
    ty(2) = vbObject
   
    vParams(0) = VarPtr(lCLSID)
    vParams(1) = VarPtr(IID_IClassFactory)
    vParams(2) = VarPtr(fo)
   
    pm(0) = VarPtr(vParams(0))
    pm(1) = VarPtr(vParams(1))
    pm(2) = VarPtr(vParams(2))
    Dim l As Long
    l = DispCallFunc(0&, FUNC, 4, vbObject, 3, ty(0), pm(0), ret)
   
   
  ' DispCallFunc ObjPtr(fo), 32, 1, vbLong, 0, 0, 0, ret
   

    If fo Is Nothing Then Exit Function
    vParams(0) = 0&
    If ForIID_IDispatch Then
        vParams(1) = VarPtr(IID_IDispatch) '一般的COM DLL可以用这个
    Else
        vParams(1) = VarPtr(IID_IUnknown) ' tlbinf32.dll只能用这个(默认就用这种方法）
    End If
    vParams(2) = VarPtr(lOle)
   
    DispCallFunc ObjPtr(fo), 12&, 4, vbObject, 3, ty(0), pm(0), ret
    Set CreateObjectXX = lOle
    Set fo = Nothing
    Set lOle = Nothing
End Function
↧

GMail Using OAuth 2.0

June 27, 2022, 4:05 pm
$
0
0
Hello friends,
Ive seen several posts recently with concerns about google disabling username/password gmail useage from 'less secure apps'.
Ive been working with OAuth alot in other projects so Im somewhat familiar with using it.
Ive decided to create a small example of how to send email from GMail using OAuth 2.0.
I cobbled this example together over a couple weekends as I had time so my appologies if it isnt as 'consistent' as it could be.
You will need to do some setup work on google before this code will work.
Please read the README file before running the code.
Regards,
Lewis

Name: ss.jpg Views: 61 Size: 40.3 KB
Attached Images
 
Attached Files
↧
Viewing all 1528 articles
Browse latest View live
Search
<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>