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

TextBox SpellCheck

$
0
0
It is a class module to apply a spell checker to a TextBox or RichTextBox, it does it through the SpellCheckerFactorys interface, it is available from Windows 8 and later.

Although with some controls like the InkEdit and the RichTextbox (Richedit50W), with just a couple of lines of code you can already apply the spell checker, but in the case of the TextBox (Edit) you have to do a complete job like the one shown it was made in the class module to work the same way. It is worth clarifying that in the case of the RichTextBox when it is formatted, the behavior may not be the desired one, since the red error lines may be slightly out of phase if the font changes.

As you can see in the image, in the contextual menu it applies the correction options and other functionalities such as: skip, delete words, add to the dictionary and autocorrect, the latter consists of automatically changing the word for another as soon as possible. is detected

It doesn't require any dependencies, just Windows 8 and later.

References:
https://www.vbforums.com/showthread....ly-a-few-lines
https://www.vbforums.com/showthread....ows-SpellCheck

Name:  spellcheck.jpg
Views: 34
Size:  68.5 KB


DOWNLOAD:
SpellCheck.zip
Attached Images
 
Attached Files

VB6 ImageCaching and -Animation (using a single Resource-File for storage)

$
0
0
Just a Demo which applies the cGDIPlusCache-Class (as intended, as a Drop-In-Module).

The original CodeBank-entry for cGDIPlusCache is here: https://www.vbforums.com/showthread....-cls-revisited

cGDIPlusCache (as included in this Demo) was enhanced about two new Methods:
  • SaveCacheToImgStore(StoreFileName As String)
  • ReadCacheFromImgStore(StoreFileName As String)


When run in IDE-Mode, the Demo will populate the GC-CacheObject directly from a \Res\-Subfolder -
(via GC-Add... Methods which in this case load PNGs, JPGs or GIFs directly from the FileSystem)

When the MainForm unloads (in IDE-Mode), then one of the new Methods is used:
  • GC.SaveCacheToImgStore App.Path & "\ImageCache.gc"


So that, when the Demo runs compiled, it will ignore the Files in the \Res\-Subfolder (so no need to deploy it) -
and instead loads the GC-Objects Cache-Content from a single File via:
  • GC.ReadCacheFromImgStore App.Path & "\ImageCache.gc"


The whole User-Code (aside from the dropped-in cGDIPlusCache.cls-File) -
sits in a single Form (with only about 25 Lines).

That's enough to ensure a Checker-BackGround and two Animations (one from a GIF, another one from a "PNG-stripe").
Name:  ImageCaching.png
Views: 41
Size:  15.5 KB

Ok, here is the Zip: ImageCaching.zip

Have fun,

Olaf
Attached Images
 
Attached Files

[VB6] Crossword Puzzle Constructor

$
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: 35
Size:  52.3 KB
Attached Images
 
Attached Files

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

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

ReDimPreserve Two dimension array

$
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)

$
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)




SimpleSock Update

$
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

$
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 RC5/RC6 SubclassWrapper

Hope this test code is useful to some people.

Environment variable dumper

$
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)

$
0
0
Calendar to which we can add events, this can be used for many things such as showing staff vacations, collection events, shifts, time activities or graphically showing date intervals.

The control has support for drag & drop of events, such as being able to modify its date range with the mouse, if we press the Ctrl key and do drag & drop it duplicates this event.

Then the data entry part is in charge of the programmer, in the examples added sample unass form, what I did not do was create a series of events, but it is possible if you have a little patience, any doubt about the latter I can give a guide on how to do it.

Inside the examples in the “Advance” folder you will find an example linking the calendar to a SQLite database, in the forum version I will use the RC6 engine and in my website J3cnn.dll

The calendar events are not handled by index but by keys, internally they are sorted by date and in this way the index is lost (I didn't like how I approached it at first).

The control does not have any dependencies, even the icons are painted with lines.

The scrollbar wheel works correctly when it is compiled, I did it this way since I did not use Safe subclass, to avoid headaches when programming I leave it like this, compiled the same thing works correctly for the MouseLeave event (since mouseleave is not active some tooltips can are activated). If someone needs it to work in the ide they can remove the "If App.LogMode Then".

To close I know that there are many things that are pending, I would like you to comment if something should be implemented or corrected, also if you see any errors; So it's easier for me that way. In the first days of uploading, I will surely be updating it frequently as they inform me or find details.



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

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





Download:
ucControlCalendar-RC6.zip
thanks @SearchingDataOnly for the conversion

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

Here is a quick detail of its functions and properties:
AddEvents : Main function to add events to the calendar, parameters required; subject
(descriptive title), start date and time, end date and time and color of the event, the rest of
the parameters are optional, return value an event key.
CenterCalenarInNow : Moves the scroll to the current time.
Clear : Remove all events.
DateValue : Assigns or returns the current date of the calendar.
DayHaveEvents : Returns True/False if there are events on a specific day.
DropDownColor : When there are many events in a day and in the Month view mode there
are more than can be shown, a dropdown bar is shown which we can change the color with
this property.
EventsCount : Number of events added.
EventsRoundCorner : Boolean property to show or not show rounded corners in events
and buttons.
FirstDayOfWeek : Here we can assign which day we want to be displayed as the first day
of the week, by default it uses the system day.
GetAllEvents : Gets a collection of the keys of the added events.
GetEventData : Obtains the data of an event, its first parameter is the key of the event
which we can obtain with GetAllEvents or by some event, the rest of the parameters are
return values.
GetEventsFromDay : Returns a collection of keys of the events of a specific day,
GetSelectionRangeDate: Function to obtain the selected date range.
HeaderColor : Color of the header and part of the theme.
HideEvent : Hides the event, useful for filtering.
LinesColor : Color of the lines.
Redraw : Enables or disables calendar repainting, this serves to speed up the loading of
events.
RemoveEvent : Removes an event.
Refresh : Refreshes the calendar redraw.
SelectedEvent : Returns the selected event.
SelectionColor : Color of the selection.
SetStrLanguage : Here we can pass the translation of the words used.
ShowToolTipEvents: If you want to show or not the tooltip window, it can be replaced by a
custom one with more detailed information. See the EventMouseEnter and
EventMouseLeave events.
Update : It is more complete than refresh, it reorders the events by date and alphabetically,
recalculates the position and finally repaints everything.
UpdateEventData : Function to update the data of an event. The key of the event that we
want to modify must be passed.
UserCanChangeDate : Enable or disable the user to be able to change the current
calendar page.
UserCanChangeEvents : Enables or disables whether the user can change events (by
stretching or dragging).
UserCanChangeViewMode: Hide all the buttons at the top of the right side. In this way the
user cannot change the view mode or the programmer takes control of which view he
wants to show.
UserCanScrollMonth : In month view mode, you can scroll infinitely if you need to change
pages, only if this option is enabled.
ViewMode : Change by code in the view mode (Day, Week, Month, Year)

Events:

DateBackColor : When this event is triggered, we can choose the background color of the
cell based on the date or time, as well as its HatchStyle.
DateChange : When the user changes the calendar page this event is fired.
DragNewEvent : When the user has the Control key pressed and drags & drops, the event
is duplicated, that is, a new event is added by the user, with this event we are informed and
thus we can save it in the database or as it is be driving.
DropDownViewMore: Event when the view more button is pressed, this button is in the
"Months" view, it appears when there are many events in a day and they do not enter the
cell, pressing this will change to view mode = "Day", We can cancel this and show a
custom window with the events of the day, we can retrieve the events of the day with
GetEventsFromDay.
EventChangeDate : This event fires when the user drags & drops or resizes the event with
the mouse. it is useful for storing the new dates in the database.
EventMouseEnter : When the mouse enters an event.
EventMouseLeave : When the mouse leaves over the event.
EventClick : Click on an event.
PreDateChange: Before the user pages to another date, here we can cancel it.
PreEventChangeDate : Before the user changes the data of an event with the drag & drop
or the mouse, this event is very useful to prevent dragging events on certain dates or times
in which we do not want an event to be added
Attached Images
  
Attached Files

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

$
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.


Small update 23 May 2022-Fixed small error in setting 1 initial value in fmInput.frm in BinaryMagic.vbp:

Line 70 was
Code:

cboxEditGenFiles.Value = IIf(.GetINIKey(i, "EditGenFiles") = 1, vbChecked, vbUnchecked)
is now
Code:

If StrComp(.GetINIKey(i, "EditGenFiles"), "1", vbBinaryCompare) = 0 Then cboxEditGenFiles.Value = vbChecked
It's a value from an INI file so it should be a text comparison not a numerical comparison.

So either make the small edit or re-download the file "BinaryMagic.xip". Thanks to DaveDavis for catching this.

Also, since using this utility is a multi-step process involving generating some code and pasting it into your own code, I encourage you to download the documentation. My description above says what it can do but it doesn't tell you how to do it. I think it is all very straightfoward but the documentation will really help a lot.
Attached Files

Luhn checksum algorithm

$
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

$
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

$
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: 60
Size:  122.4 KB

And here is the Project-Code:
TileHandling.zip

Have fun,

Olaf
Attached Images
 
Attached Files

Image (de)compressor

$
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.

VB6 A simple approach to Lighweight-Classes

$
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

$
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

$
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)

$
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

Viewing all 1487 articles
Browse latest View live


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