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

VB6 - TLSSend Using CNG

November 12, 2015, 9:30 pm
$
0
0
Attached is a program called TLSSend. This Version uses MS CNG (Cryptography Next Generation), and sends email messages to:
1. Your ISP
2. Gmail
3. MS Live
using ports 25, 1025, 465, or 587. Port 25 is the standard SMTP port, port 1025 is the Plain Authentication port offered by some services, port 465 is for the standard "Secure" connection, and port 587 is for the "Secure" connection using STARTTLS. Port 465 negotiates a secure connection directly after the TCP connection is established, whereas port 587 starts the connection in text mode, but negotiates the secure connection before the transmission of the authentication information.

When first run, TLSSend automatically activates the Setup form. There you will find the requirements for your ISP, Gmail, and MS Live(Outlook/Hotmail) accounts. Each one requires the name of the Outbound Server, the account name, the Password, and the ports utilized. Both Gmail and Live do not support non-secure connections, and MS Live does not support port 465. My own ISP accepts connections on all four ports, but unfortunately doesn't support TLS 1.2 on the secure connections. Strange part is that it requires SHA256 for the Hash algorithm when there are about 40% of servers that still use SHA1.

There is currently a problem with Gmail that does not stop it from working. A secure server will forward a Certificate chain that includes the RSA Key used and a Signature. The signature attached to the last Certificate is normally a Hash of the Server (first) Certificate encrypted with the RSA Private key from the last Certificate (Certificate Authority). For reasons unknown, Google uses a Certificate issued by Equifax that contains a 2048 bit/256 byte RSA Public Key, but the attached Signature is 1024 bit/128 byte. A 128 byte Signature cannot be created using a 256 byte Key, and 128 byte Keys have not been in use since the end of 2013. Since TLSSend does not support 128 Byte keys/signatures, it cannot verify the Server Certificate from Google.

J.A. Coutts
Attached Images
 
Attached Files
↧
Search

Directory Tree - Generates a list of subdirectories.

November 14, 2015, 7:45 pm
$
0
0
Directory Tree demonstrates how to list all subdirectories under a directory. Simply specify the "root" directory and output file.

This can be useful, for example, when writing a program that searches for files.
Attached Files
↧
↧

Here's how to make VB6 execute a program and then wait for it to close.

November 15, 2015, 3:41 am
$
0
0
It's a VB6 sub called RunAndWait.
Code:
Private Const SYNCHRONIZE As Long = &H100000

Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long


Public Sub RunAndWait(ByVal FileName As String, Optional ByVal Args As String, Optional ByVal WindowStyle As VbAppWinStyle = vbNormalFocus)
Dim ProcID As Long
Dim hProc As Long
ProcID = Shell("""" & FileName & """ " & Args, WindowStyle)
hProc = OpenProcess(SYNCHRONIZE, 0, ProcID)
WaitForSingleObject hProc, -1
CloseHandle hProc
End Sub
Just paste this code into a module and you will be able to call it from anywhere in your program.
↧

Framework for making plugins

November 15, 2015, 1:39 pm
$
0
0
You know how a lot of software these days use plugins, whether it's a graphics program, or a web browser, that allows additional functionality that was not present in the base program? Well I figured out how to do this in VB6.

Here's 2 templates, one for a plugin host, and one for a plugin. These are commented enough that you will be able to see how to use them. They are intended to be placed in modules (BAS files).

First template is modPluginHost, and should be used when compiling your main program's EXE file.
Code:
Private Const SYNCHRONIZE As Long = &H100000

Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32.dll" () As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Public Type InitStructType
    StructSize As Long
    'Define the structure's elements here.
End Type
Public InitStruct As InitStructType
' This plugin initialization structure will contain
' all data that must be passed from the host to the
' plugin. For example, in an image processing
' plugin, this would contain image dimensions and a
' pointer to pixel data.



Public Function CallPlugin(ByVal PluginFileName As String) As Boolean
' PluginFileName is the EXE file of the plugin.
' It can be a relative or absolute path.

Dim ProcID As Long
Dim hProc As Long

On Error Resume Next
ProcID = Shell("""" & PluginFileName & """ " & CStr(GetCurrentProcessId) & " " & CStr(VarPtr(InitStruct)), vbNormalFocus)
If Err.Number Then Err.Clear
If ProcID = 0 Then Exit Function
hProc = OpenProcess(SYNCHRONIZE, 0, ProcID)
WaitForSingleObject hProc, -1
If hProc = 0 Then Exit Function
CloseHandle hProc
CallPlugin = True
End Function
Second template is modPlugin, and should be used when compiling your plugin's EXE file.
Code:
Private Const GENERIC_READ As Long = &H80000000
Private Const GENERIC_WRITE As Long = &H40000000

Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32.dll" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32.dll" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long

Public Type InitStructType
    StructSize As Long
    'Define the structure's elements here.
End Type
Public InitStruct As InitStructType
' This plugin initialization structure will contain
' all data that must be passed from the host to the
' plugin. For example, in an image processing
' plugin, this would contain image dimensions and a
' pointer to pixel data.

Dim HostProcID As Long



Public Sub InitPlugin()
'This should be the very first thing called in your plugin.
'Preferably, call this in the Form_Load event of your plugin's main form.

Dim CmdLineArgs() As String
Dim HostInitStructAddr As Long
Dim hProc As Long

CmdLineArgs() = Split(Command, " ")
HostProcID = CmdLineArgs(0)
HostInitStructAddr = CmdLineArgs(1)

hProc = OpenProcess(GENERIC_READ, 0, HostProcID)
If hProc = 0 Then End
If ReadProcessMemory(hProc, HostInitStructAddr, InitStruct, 4) <> 0 Then
    CloseHandle hProc
    End
End If
If ReadProcessMemory(hProc, HostInitStructAddr, InitStruct, InitStruct.StructSize) <> 0 Then
    CloseHandle hProc
    End
End If
CloseHandle hProc
End Sub



Public Function ReadDataFromHost(ByVal LocalDataAddr As Long, ByVal HostDataAddr As Long, ByVal DataSize As Long) As Boolean
Dim hProc As Long

hProc = OpenProcess(GENERIC_READ, 0, HostProcID)
If hProc = 0 Then Exit Function
If ReadProcessMemory(hProc, HostDataAddr, ByVal LocalDataAddr, DataSize) <> 0 Then
    CloseHandle hProc
    Exit Function
End If
CloseHandle hProc
ReadDataFromHost = True
End Function



Public Function WriteDataToHost(ByVal LocalDataAddr As Long, ByVal HostDataAddr As Long, ByVal DataSize As Long) As Boolean
Dim hProc As Long

hProc = OpenProcess(GENERIC_WRITE, 0, HostProcID)
If hProc = 0 Then Exit Function
If WriteProcessMemory(hProc, HostDataAddr, ByVal LocalDataAddr, DataSize) <> 0 Then
    CloseHandle hProc
    Exit Function
End If
CloseHandle hProc
WriteDataToHost = True
End Function
Other than defining the elements of the InitStructType user defined type (which should match exactly between the host and the plugin), there's really nothing that needs to be edited in these templates.
↧

VB6 - Grammatical Evolution

November 16, 2015, 2:00 pm
$
0
0
This is a small project inspired by Grammatical Evolution.

It's a Genetic Algorithm that evolves a Program-Code.
(in fact i'd prefer to call it Code-Evolution, since it involves even ROM and uses RAM, and since Grammatical Evolution is something more sophisticated)

The GA individuals-Structure is this:

-Inputs
-Outpus
-RAM
-ROM (Constants)
-Code

The Parts that evolve are ROM and CODE.

Public Sub INIT(PopulationSize As Long, Inputs As Long, Outputs As Long, Rams As Long, Roms As Long, NCodeLines As Long, _
EVOSonsPerc As Double, EVOChildMutationProb As Double, EVOMutationRate As Double)



At the Moment the CODE have this set of instructions:

R = A + B
R = A - B
R = A * B
R = A / B
R = A ^ B
R = IIf(A > B, A, B) Greater
R = IIf(A < B, A, B) Smaller
R = A

JUMP to line Code
Jump if A>B to line Code
Jump if A<B to line Code

Where A,B can be: Input,RAM,ROM
and R can be RAM,Output


One single line of code occupy 7 Values defined so:
1 - Main instruction
2 - Type of A
3 - Address of A (depending on its type)
4 - Type of B
5 - Address of B (depending on its type)
6 - Type of R
7 - Address of R (depending on its type)

(If 1 operand or jump,some of these are not used)



Launch the program and watch moving object learn to stay on "Green Circle"
In Test01 a set of Object move according to their Codes.
They have 2 imputs:
Difference of Angle to GreenCircle
Distance to GreenCircle
2 output:
Speed
Turn Angle



It has been written quickly and still a lot to improve.


By the way, I'd like to share this on Github or GitLab... cause I'd like to have contributors and new test tasks-designer.
I tried both, but both gives me error when I download the code and try to open it with VB6. Can someone tell me why?


If you have improvements or test-tasks designed.. Share!
Attached Files
↧
↧

Figures - experimenting with polygons

November 17, 2015, 7:41 am
$
0
0
Figures is an experiment in generating and animating simple polygons. Instead of using horizontal and vertical coordinates for each element, the program uses the distances (radii?) as measured from the polygon's center. Because these distances are evenly distributed over a full circle, there's no need to define an angle. To, for example, define the following figures just specify:

3 equal "distances" for a triangle, 4 for a square, and 8 for an octagon.

Variable distances inside one polygon (think stars/sprockets) are allowed. There's also a rudimentary function which allows you to append one polygon to another polygon.

"Figures" is an old project which I decided to clean and upload here. It is, however, slow, has some stability issues, and, the terminology used in the code could use cleaning.
Attached Files
↧

please delete

November 17, 2015, 8:18 am
↧

[VB6] Color surface and scatter charts with nice color maps

November 17, 2015, 10:48 am
$
0
0
Dear all,

As heavy user of Excel 2007, I'm happy with the quick analysis available through pivot table. Unfortunately the default layout for the contour graph and the need for a regular grid reduce productivity.
So I created a macro call ColorThirdAxis (available in a separate tab in the example excel file) to improve that status. So the current macro works on surface and wireframe charts and on XYscatter charts. For the contour chart, you'll need to simply pick up a colormap in the user form. Then the macro will color categories following the map (for top view contours the bands will be flattened).
For scatter plots, in addition to the colormap, you'll have to pick a range of values defining the point colors. And you can set manually the bounds of the data range for colormap interpolation.

The picture shows a possible result of the macro on the example file.

I hope you'll find it useful.

Notes:
1. The macro uses JsonBag (search on this forum for it) to read colormaps.
2. Credits for the colormap go to the Palettable Python project.
Attached Images
 
Attached Files
↧
Search

[VB6] PicSave - Simple SavePicture as GIF, PNG, JPEG

October 30, 2015, 11:35 pm
$
0
0
Sometimes you need a better SavePicture() function. Not a lot better, just one that can save in some compressed format instead of just BMP format. Like JPEG usually, or PNG. Well this one does that, and throws in GIF as well though as usual (being based on GDI+) those tend to come out dithered and sort of crap in general.

What we have here is a simple preclared-instance Class with one method: SavePicture().

You give it a StdPiture, a file name (yes, it can save using Unicode paths), which format you want, and for JPEG you can add a "quality" in percent. It saves to disk, not to Byte arrays.

Nothing here people haven't seen before. This is just a "stripped to essentials" rendition of the well worn theme.


It only requires a version of Windows with IE 5 or later. It uses GDI+ but most systems with IE 5 or later cover that as well. In any case it should work on nearly anything you run anymore.

There are no 3rd party DLLs required, and not even any typelibs. Just add PicSave.cls to your Projects.


The attachment contains a simple demo. Its bulk is all source image data.


The StdPicture you pass to it must have a bitmap handle. In practical terms this means you may have to pass it the persistant-image property (.Image) if you have drawn your picture onto a Form, PictureBox, etc. and there is no provision for dealing with metafile vector images.


Notes:

New attachment incorporating feedback from discussion below to address issues encountered when GDI v. 1.1 is in play, running on 64-bit Windows, etc.

Also note that this makes no effort to handle transparency or alpha-channel translucency for GIF or PNG output. It saves simple "whole bitmap" images. If you load a picture with transparency into a StdPicture and save it back using this class the transparency is lost.
Attached Files
↧
↧

Analog Clock example

November 20, 2015, 6:38 am
$
0
0
Analog Clock is a program that demonstrates how to create a user control that displays a clock on a form in Visual Basic. This started as a quick example about rotating graphics I wrote a while ago and I decided to make it into a compact program that should be fairly straightforward and easy to customize.
Attached Files
↧

Sludge Tools - an old but, still interesting, and possibly useful project

November 20, 2015, 7:16 am
$
0
0
Okay, how to start... A couple of years ago I tried to write my own adventure game using Hungry Software's Sludge scripting language. The tools that came with it were pretty good, but I felt it needed a few more features, and so I wrote a few of my own tools in Visual Basic.

Personally, I think the must useful one was "Sludge Screen Region Editor" - a program that generated the Sludge script code that defines "screen regions" (interactive rectangular areas on the screen (in a game made with Sludge script.)) Apparently other people using Sludge felt it was pretty useful too, judging from the responses I got after posting it.

The other tools are, in short:
-A source code viewer which allows the user to browse through stuff such as events, subroutines, and objects as defined in a Sludge script.
-A "calculator" that generates a line of script code that regulates game objects' apparent sizes based on a game screen's "horizon's" position.
-The original TGA loader (a version of which I uploaded to this forum) class is also part of the Screen Region Editor.

Screenshot:
Name: Ssre.jpg Views: 44 Size: 27.9 KB

I'm not sure how useful these tools still are, but I feel they are pretty well written and designed. They could probably be adapted for other purposes as well.
Attached Images
 
Attached Files
↧

[VB6] Code Snippet: Open a folder and select multiple files in Explorer

November 21, 2015, 4:27 pm
$
0
0
So lots of applications these days can open a folder and highlight the target file or files, but it's not something that I've seen done in VB6 for multiple files; I guess because few people are familiar with pidls: you need to get the pidl of the parent folder, than relative pidls for each file you want selected. But after that, all you need is a single line API call to SHOpenFolderAndSelectItems. Using Shell on explorer.exe with /select limits you to one file.

This snippet goes a little further; instead of just asking for a parent folder and files, I've included code that will do the complicated parsing required to accept a list of full file paths, in multiple folders. One window per folder will open, and all files from the input list in that folder will be highlighted.

Requirements
-Windows XP or higher

Code
Code:
Public Type ResultFolder
    sPath As String
    sFiles() As String
End Type
Public Declare Function SHOpenFolderAndSelectItems Lib "shell32" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, ByVal dwFlags As Long) As Long
Public Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
Public Declare Function ILFindLastID Lib "shell32" (ByVal pidl As Long) As Long
Public Declare Sub ILFree Lib "shell32" (ByVal pidl As Long)

Public Sub OpenFolders(sFiles() As String)

If sFiles(0) = "" Then Exit Sub 'caller is responsible for ensuring array has been dim'd and contains valid info

Dim tRes() As ResultFolder
Dim apidl() As Long
Dim ppidl As Long
Dim pidlFQ() As Long
Dim i As Long, j As Long

GetResultsByFolder sFiles, tRes

'Now each entry in tRes is a folder, and its .sFiles member contains every file
'in the original list that is in that folder. So for every folder, we now need to
'create a pidl for the folder itself, and an array of all the relative pidls for the
'files. Two helper APIs replace what used to be tons of pidl-related support
'code before XP. After we've got the pidls, they're handed off to the API
For i = 0 To UBound(tRes)
    ReDim apidl(UBound(tRes(i).sFiles))
    ReDim pidlFQ(UBound(tRes(i).sFiles))
    For j = 0 To UBound(tRes(i).sFiles)
        pidlFQ(j) = ILCreateFromPathW(StrPtr(tRes(i).sFiles(j))) 'ILCreateFromPathW gives us Unicode support
        apidl(j) = ILFindLastID(pidlFQ(j))
    Next
    ppidl = ILCreateFromPathW(StrPtr(tRes(i).sPath))

    Call SHOpenFolderAndSelectItems(ppidl, UBound(apidl) + 1, VarPtr(apidl(0)), 0&)
    'Vista+ has dwFlags to start renaming (single file) or select on desktop; there's no valid flags on XP

    'now we need to free all the pidls we created, otherwise it's a memory leak
    ILFree ppidl
    For j = 0 To UBound(pidlFQ)
        ILFree pidlFQ(j) 'per MSDN, child ids obtained w/ ILFindLastID don't need ILFree, so just free FQ
    Next
Next
       
End Sub

Private Sub GetResultsByFolder(sSelFullPath() As String, tResFolders() As ResultFolder)
Dim i As Long
Dim sPar As String
Dim k As Long, cn As Long, fc As Long
ReDim tResFolders(0)

For i = 0 To UBound(sSelFullPath)
    sPar = Left$(sSelFullPath(i), InStrRev(sSelFullPath(i), "\") - 1)
    k = RFExists(sPar, tResFolders)
    If k >= 0 Then 'there's already a file in this folder, so just add a new file to the folders list
        cn = UBound(tResFolders(k).sFiles)
        cn = cn + 1
        ReDim Preserve tResFolders(k).sFiles(cn)
        tResFolders(k).sFiles(cn) = sSelFullPath(i)
    Else 'create a new folder entry
        ReDim Preserve tResFolders(fc)
        ReDim tResFolders(fc).sFiles(0)
        tResFolders(fc).sPath = sPar
        tResFolders(fc).sFiles(0) = sSelFullPath(i)
        fc = fc + 1
    End If
Next
End Sub

Private Function RFExists(sPath As String, tResFolders() As ResultFolder) As Long
Dim i As Long
For i = 0 To UBound(tResFolders)
    If tResFolders(i).sPath = sPath Then
        RFExists = i
        Exit Function
    End If
Next
RFExists = -1
End Function
↧

Copy to Clipboard as Unicode and Html Form

November 24, 2015, 1:54 pm
$
0
0
Working for M2000 Interpreter I found this https://support.microsoft.com/en-us/kb/274326
For copy text to Html, but without using utf-8 (but works for english because utf-8 has one byte for English language). So I do the job to make this to send text in utf-8 format, so it can be used for export colored text, or in other format, and we can paste this to an office application like Word or in a Blog (in blogspot, as I do for my Intertpeter, M2000)
Put this in a Module and call TestThis from Immediate Mode.
I also include two helpers, the SpellUnicode which get a string and give a string of parameters. These parameters are for ListenUnicode which convert back to unicode string. Is the only way to pass unicode strings in a Module file (without using external file or a resource like .res file).

Enjoy it

Code:
Private Declare Function RegisterClipboardFormat Lib "user32" Alias _
  "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private m_cfHTMLClipFormat As Long
Private Const Utf8CodePage As Long = 65001
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal codepage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar& Lib "kernel32" (ByVal codepage&, ByVal dwFlags&, MultiBytes As Any, ByVal cBytes&, ByVal pWideChars&, ByVal cWideChars&)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' here is the sub for send text to clipboard as unicode and as Html Format -utf8
Public Sub TestThis()
Copy2Clipboard ListenUnicode(915, 953, 974, 961, 947, 959, 962, 32, 922, 945, 961, 961, 940, 962) + vbCrLf + "Greetings from George Karras from West Greece"
End Sub
Public Sub Copy2Clipboard(ByVal unicodetext As String)
Dim ph As String
Clipboard.Clear  ' always
DoEvents
Sleep 10
ph = PrepareHtml(unicodetext) ' here you have to prepare for html
SimpleHtmlData ph
SetTextData 13, unicodetext
End Sub
Function ReplaceStr(sStr As String, dStr As String, fromStr As String) As String
'' Sory but i like this one, with source first
  ReplaceStr = Replace$(fromStr, sStr, dStr)
End Function
Private Function PrepareHtml(neodata As String) As String
Dim A$
' WE DO SOME WORK TO PRESERVE FORMAT
' MAYBE IS NOT COMPLETE BUT IT IS A TRY
A$ = ReplaceStr("</", Chr$(1) + Chr$(2), neodata)
A$ = ReplaceStr("<", Chr$(3), A$)
A$ = ReplaceStr(">", Chr$(4), A$)
A$ = ReplaceStr("  ", Chr$(7) + Chr$(7), A$)
A$ = ReplaceStr(Chr$(7) + " ", Chr$(7) + Chr$(7), A$)
'' here you can process line by line and or embed tags
A$ = "<FONT COLOR=blue>" + A$ + "</FONT>"

A$ = ReplaceStr(Chr$(1) + Chr$(2), "&lt;⁄", A$)
A$ = ReplaceStr(Chr$(3), "&lt;", A$)
A$ = ReplaceStr(Chr$(4), "&gt;", A$)
' SO ALL SPACES ARE NOW NBSP IF ARE IN A SEQUENCE OF TWO OR MORE
A$ = ReplaceStr(Chr$(7), "&nbsp;", A$)

PrepareHtml = Replace(A$, vbCrLf, "<br>")  ' or you can use <p>
End Function

Public Function HTML(sText As String, _
Optional sContextStart As String = "<HTML><BODY>", _
Optional sContextEnd As String = "</BODY></HTML>") As Byte()
' part of this code from an example from Microsfot
    Dim m_sDescription As String
    m_sDescription = "Version:1.0" & vbCrLf & _
    "StartHTML:aaaaaaaaaa" & vbCrLf & _
    "EndHTML:bbbbbbbbbb" & vbCrLf & _
    "StartFragment:cccccccccc" & vbCrLf & _
    "EndFragment:dddddddddd" & vbCrLf
    Dim A() As Byte, b() As Byte, c() As Byte
    A() = Utf16toUtf8(sContextStart & "<!--StartFragment -->")
    b() = Utf16toUtf8(sText)
    c() = Utf16toUtf8("<!--EndFragment -->" & sContextEnd)
    Dim sData As String, mdata As Long, eData As Long, fData As Long
    eData = UBound(A()) - LBound(A()) + 1
    mdata = UBound(b()) - LBound(b()) + 1
    fData = UBound(c()) - LBound(c()) + 1
    m_sDescription = Replace(m_sDescription, "aaaaaaaaaa", Format(Len(m_sDescription), "0000000000"))
    m_sDescription = Replace(m_sDescription, "bbbbbbbbbb", Format(Len(m_sDescription) + eData + mdata + fData, "0000000000"))
    m_sDescription = Replace(m_sDescription, "cccccccccc", Format(Len(m_sDescription) + eData, "0000000000"))
    m_sDescription = Replace(m_sDescription, "dddddddddd", Format(Len(m_sDescription) + eData + mdata, "0000000000"))
    Dim all() As Byte, m() As Byte
    ReDim all(Len(m_sDescription) + eData + mdata + fData)
    m() = Utf16toUtf8(m_sDescription)
    CopyMemory all(0), m(0), Len(m_sDescription)
    CopyMemory all(Len(m_sDescription)), A(0), eData
    CopyMemory all(Len(m_sDescription) + eData), b(0), mdata
    CopyMemory all(Len(m_sDescription) + eData + mdata), c(0), fData
    HTML = all()
End Function
Function RegisterCF() As Long


  'Register the HTML clipboard format
  If (m_cfHTMLClipFormat = 0) Then
      m_cfHTMLClipFormat = RegisterClipboardFormat("HTML Format")
  End If
  RegisterCF = m_cfHTMLClipFormat
 
End Function
Public Function SimpleHtmlData(ByVal sText As String)
    Dim lFormatId As Long, bb() As Byte
    lFormatId = RegisterCF
    If lFormatId <> 0 Then
    If sText = "" Then Exit Function
    bb() = HTML(sText)
    If CBool(OpenClipboard(0)) Then
          Dim hMemHandle As Long, lpData As Long
          hMemHandle = GlobalAlloc(0, UBound(bb()) - LBound(bb()) + 10)
          If CBool(hMemHandle) Then
            lpData = GlobalLock(hMemHandle)
            If lpData <> 0 Then
                CopyMemory ByVal lpData, bb(0), UBound(bb()) - LBound(bb())
                GlobalUnlock hMemHandle
                EmptyClipboard
                SetClipboardData lFormatId, hMemHandle
            End If
          End If
          Call CloseClipboard
      End If
End If
End Function
Private Function SetTextData( _
        ByVal lFormatId As Long, _
        ByVal sText As String _
    ) As Boolean
    If lFormatId = 0 Then Exit Function
    Dim hMem As Long, lPtr As Long
    Dim lSize As Long
        lSize = LenB(sText)
    hMem = GlobalAlloc(0, lSize + 2)
If (hMem > 0) Then
        lPtr = GlobalLock(hMem)
        CopyMemory ByVal lPtr, ByVal StrPtr(sText), lSize + 1
        GlobalUnlock hMem
      If (OpenClipboard(0) <> 0) Then
    SetClipboardData lFormatId, hMem
      CloseClipboard
      Else
      GlobalFree hMem
      End If
    End If
End Function
Public Function Utf16toUtf8(s As String) As Byte()
    ' code from vbforum
    ' UTF-8 returned to VB6 as a byte array (zero based) because it's pretty useless to VB6 as anything else.
    Dim iLen As Long
    Dim bbBuf() As Byte
    '
    iLen = WideCharToMultiByte(Utf8CodePage, 0, StrPtr(s), Len(s), 0, 0, 0, 0)
    ReDim bbBuf(0 To iLen - 1) ' Will be initialized as all &h00.
    iLen = WideCharToMultiByte(Utf8CodePage, 0, StrPtr(s), Len(s), VarPtr(bbBuf(0)), iLen, 0, 0)
    Utf16toUtf8 = bbBuf
End Function
Public Function SpellUnicode(A$)
' use spellunicode to get numbers in Immediate Mode ? SpellUnicode("Γιώργος Καρράς") 'Greek Letters
' and make a ListenUnicode...with numbers for input text
' You can see that if you have Arial Greek
' ? ListenUnicode(915,953,974,961,947,959,962,32,922,945,961,961,940,962)
Dim b$, i As Long
For i = 1 To Len(A$) - 1
b$ = b$ & CStr(AscW(Mid$(A$, i, 1))) & ","
Next i
SpellUnicode = b$ & CStr(AscW(Right$(A$, 1)))
End Function
Public Function ListenUnicode(ParamArray aa() As Variant) As String
Dim all$, i As Long
For i = 0 To UBound(aa)
    all$ = all$ & ChrW(aa(i))
Next i
ListenUnicode = all$
End Function
↧
↧

[vb6]Yet Another CSV Parser

November 26, 2015, 11:21 am
$
0
0
A fairly basic CSV parser, with a bit more user-control and a slight twist: Event driven by Record
The parser does handle quoted field data and delimiters, carriage returns, and other non-printable characters wtihin field data, assuming the field data is properly formatted.

The parser will raise an event for each record it has finished parsing. You would respond to this event to use/format the parsed field data. The event allows aborting further processing if the CSV appears corrupted. The event will inform you if the CSV file appears corrupt.

The class offers two ways of feeding it CSV information but only one method is called.
1) Entire file read into a string
2) Line by line from the CSV file, read from a loop or from a split string

As mentioned, an event is called for each record. This event has 3 states:
1) RecordParsed. A vbNullChar-delimited string is passed which contains the entire record
2) FieldNamesStatic. A vbNullChar-delimeted string containing field names from the CSV's first row of data
3) FieldNamesGeneric. A vbNullChar-delimited string containing default field names for CSVs without a header row
Each event has has three other parameters: HeaderCount, FieldDifferential, and RecordNumber
RecordNumber will be zero if processing field names else incrementing by 1 each time event is called
HeaderCount is the number of fields based from the 1st row of parsed data
FieldDifferential is basically an error if non-zero.
0 indicates that number of fields in the record equal number of field names
Negative indicates number of missing fields in the record. HeaderCount + FieldDifferential = number processed fields
Positive indicates number of extra fields in the record.
If you feel comfortable trying to handle any discrepancies between field count and header count, no need to reply to the event. However, if you want to abort processing any further records, you simply return the Record parameter as a null string.

Let's talk about proper formatting
Delimiters come in various flavors with this class:
:: Record Delimiter defines when a record ends & a new record begins. Hard coded in the class a vbCr and/or vbLf
:: Field Delimiter defines when a field ends & a new field begins. This is user-defined & defaults to a comma
:: Quote/Text Delimiter defines start and end of text where any character (delimiter or not) is not specially handled
:: Escape Delimiter defines characters not specially handled. Escape delimited files are rare
Quote and Escape Delimiters are also used to delimit themselves as non-special characters

1) Every record in a CSV, including any header row, is delimited by a carriage return and/or line feed
-- Only exception is the final record. It does not require a record delimiter

2) Every field within a record must be delimited by a character you specify. This class does not process fixed-length field CSVs
-- Field delimiters never used before the 1st field and never after the final field
-- Any field that contains a null character (ASCII byte 0) will abort the parser

3) Quotes, i.e., ", are defaulted to be handled as text identifiers. This option can be turned off or changed to a different character
-- Quote delimiters allow non-printable characters and other delimiters to be treated as just any other character

4) If any field contains a record and/or field delimiter within the field's data, the delimiters must be identified as non-delimiters
-- Two options are provided in the class: quoted field data and escape characters

Delimiters. Let's say the field delimiter is a comma
:: If any character within a field contains any delimiter, then that delimiter must be escaped
:: Sample field: Hello, my name is LaVolpe
If Quote delimit character is " then should be saved to file as: "Hello, my name is LaVolpe"
If Escape delimit character is \ then should be saved to file as: Hello\, my name is LaVolpe

Delimiting the delimiters. Simple rule, replace each delimiter with a double delimiter
:: Sample field with Quote delimiter: Hello, my name is "LaVolpe"
Saved to file as: "Hello, my name is ""LaVolpe"""
-- if no field delimiter existed, then this works too: My name is ""LaVolpe""
:: Sample field with Escape delimiter: C:\My Documents
Saved to file as: C:\\My Documents
Note that the Quote & Escape delimiters are a tad different.
-- Quote delimiters are doubled only within the field data.
-- If field data has delimiters, then the field data is written to file with a single quote both as a prefix & suffix
-- Quote delimiters are always paired if used as delimiters
-- Any record or field delimiter within a field needs no special handling, when that field on disk begins & ends with a quote delimiter
-- Escape delimiters, if used, are required for every field, record and escape delimiter that exists within a field
-- Escape delimiters have no 'pairing' requirement unless escaping itself
-- Mixing Quote & Escape delimiters is not recommended, though can be used if you want to customize your CSV data
-- Quote and/or Escape delimiter characters must be defined by the user, both are optional


Quick examples of using the class, both for reading line by line & entire file
Code:
Private WithEvents CSVParser As ICSVParser

Private CSVParser_ProcessRecord(ByVal State As ProcessStateEnum, _
                                Record As String, _
                                ByVal FieldDifferential As Long, _
                                ByVal HeaderCount As Long, _
                                ByVal RecordNumber As Long)
        ' process parsed CSV record
        Dim sData() As String
        Select Case State
        Case csvRecordParsed
                If FieldDifferential Then
                        ' handle potentially corrupt CSV
                        ' to abort further processing: Record = vbNullString
                Else
                        sData = Split(Record, vbNullChar)
                        ' process data
                End If
        Case csvFieldNameStatic
                sData = Split(Record, vbNullChar)
                ' process field names
        Case csvFieldNameGeneric
                sData = Split(Record, vbNullChar)
                ' process field names, optionally, using your own names
        End Select
End Sub

Private Sub Command1_Click() ' Full file example
        If CSVParser Is Nothing Then Set CSVParser = New ICSVParser
        Dim fnr As Integer, sFile As string
        fnr = FreeFile()
        Open "C:\Temp\TestCSV.csv" For Binary As #fnr
        sFile = Space$(LOF(fnr))
        Get #fnr, 1, sFile
        Close #fnr
        CSVParser.InitializeParser True
        If CSVParser.ParseRecord(sFile) = False Then
                ' handle informing user of corrupt file
        End If
        If CSVParser.TerminateParser() = False Then
                ' handle informing user of corrupt file, final record
        End If
End Sub

Private Sub Command2_Click() ' Line by line example
        If CSVParser Is Nothing Then Set CSVParser = New ICSVParser
        Dim fnr As Integer, sLine As string
        fnr = FreeFile()
        Open "C:\Temp\TestCSV.csv" For Input As #fnr
        CSVParser.InitializeParser True
        Do Until EOF(fnr) = True
                Line Input #fnr, sLine
                If CSVParser.ParseRecord(sLine) = False Then
                        ' handle informing user of corrupt file
                        Exit Do
                End If
        Loop
        Close #fnr
        If CSVParser.TerminateParser() = False Then
                ' handle informing user of corrupt file, final record
        End If
End Sub
And, just for the heck of it, a real simple example of loading a CSV to a ListView. In the parser's event:
Code:
    Dim sData() As String, lItem As Long
    Select Case State
    Case csvRecordParsed
        If FieldDifferential > 0 Then
            Record = ""
        Else
            sData = Split(Record, vbNullChar)
            With ListView1.ListItems.Add(, , sData(0))
                For lItem = 1 To UBound(sData)
                    .SubItems(lItem) = sData(lItem)
                Next
            End With
        End If
               
    Case csvFieldNamesGeneric, csvFieldNamesStatic
        sData = Split(Record, vbNullChar)
        With ListView1
            .ListItems.Clear
            .ColumnHeaders.Clear
            For lItem = 0 To HeaderCount - 1
                .ColumnHeaders.Add , , sData(lItem)
            Next
        End With
    End Select
Another parser can be found at this link, this site, by a well-respected coder.
The attachment below is a class file, remove the .txt extension after downloading
Attached Files
↧

VB6 - Generate ECC Key DLL

December 9, 2015, 1:08 pm
$
0
0
Attached is a DLL program that generates an ECC (Elliptical Curve Cryptography) Key, and a sample program to utilize it. Each side in the exchange creates a Public/Private key, and sends the Public Key to the other side. Each side then uses its own Private Key, and the Public Key received from the other end to create a common Shared Secret that can be used as a Session Key.

A standard DLL is used because it can combine 12 different API calls into one common routine that can be used by a VB program. For this purpose, I used the Standard DLL AddIn from Dansoft Australia http://www.dansoftaustralia.net/developers/vb.htm

Like some of the BCrypt calls, the DLL will return different information, depending on what information was supplied. If both the Public Key and Private Key are empty, it will return the internal Public\Private Keys and a single byte "0" The Public Key is sent to the other end, and the Private Key is used in the second call. On the second pass, the user supplies the Private Key that it earlier created, and the Public Key that it received from the other end. It should return the 32 byte Shared Secret. If an error occurred, a single byte will be returned with the number of the call that failed.

I transferred the entire byte arrays because they are relatively small, but in theory you should be able to just use a pointer to the first element of the array. Of course, if you do that, you will also have to supply the length of the array.

What I really wanted was the raw shared secret, but Microsoft seems to want to hash it first. I have not found a way to get the raw secret by itself, and I am still looking. If anyone can offer a suggestion, I am certainly willing to listen.

J.A. Coutts
Attached Images
 
Attached Files
↧
Search

GDI+ Workaround: ICONs

December 12, 2015, 11:19 am
$
0
0
Major caveat: The noted limitations apply to at least Vista and lower. Windows 7 and above may have corrected some of these limitations. Since Vista is still an active operating system, you may be interested. Also, the term "icon" used below is interchangeable with "cursor" and vice versa.

First a little background about icons within Windows. The icon structure is fairly straightforward and well documented, so won't spend any serious time on that. What people may not be aware of is how icons/cursors are rendered. Icons are drawn as a result of the combination of the icon color data (considered the XOR bits) and the icon mask (AND bits). With the exception of 32 bit icons, discussed in a bit, there are only 3 scenarios for each icon pixel rendered:

1. Icon pixel is transparent. The icon pixel must be black, the mask pixel must be white (value of 1 in a 1 bit mask)
2. Icon pixel is opaque. The mask pixel must be black (value of 0 in a 1 bit mask)
3. Icon pixel is inverted relative to its pixel color and the destination pixel color. Mask pixel must be white & icon pixel must not be black.

The formula is quite simple: ([destination pixel color] And [mask color value]) Xor [icon color value]
So looking at the 3 scenarios above, the icon pixel rendered in each scenario can be calculated. Just using one color channel for simplicity in the example.

D = destination color. M = mask color. S = icon source color

1. Transparent: M=255, S=0, D=any color. (D And M) Xor S = D
2. Opaque: M=0, S=any color, D=any color. (D And M) Xor S = S
3. Inverted. Icon color cannot be black else icon pixel becomes transparent when mask pixel is white
a) white icon color produces pure inverted color: M=255, S=255, D=222. (D And M) Xor S = 33
b) non-black/white produces relative inversion: M=255, S=111, D=222. (D And M) Xor S = 177

Inverted pixel colors are typically used for 1 bit cursors only. This allows a cursor to invert its color over any background to prevent it from visually disappearing over a background of same color as the cursor. Technically, this is not restricted to 1 bit icons/cursors. However, a 32 bit icon using the alpha channel will never invert pixels because the icon mask (which dictates inversion) is ignored when the alpha channel is used.

So, where does GDI+ break? With icons, nearly everywhere. Here are specific limitations with GDI+

- GDI+ won't load cursors from handle nor file/stream
- All icons. Ignores any inverted pixels and they are treated as transparent. GDI+ has no XOR ability.
- PNG embedded icon. Cannot load it as an icon file/stream
- 1 bit icon: Cannot load it by handle, but can load it by file/stream
- 16,24 bit icon: Cannot load it by file/stream, but can load it by handle
- 32 bit icon. Well, Windows uses the mask only in this case: every icon alpha channel value is zero. Otherwise, the mask will be ignored. GDI+ will not properly render a 32 bit icon when the mask should be ignored. GDI+ never ignores the mask but ignores the alpha channel. Go figure.

Workarounds. Everything except the XOR limitation can be worked around relatively easily; but lots more code.

- 32 bit icons with alpha channel usage. Whether by handle or by file, doesn't matter. Transfer the icon color pixel data + alpha channel to a GDI+ hImage created with GdipCreateBitmapFromScan0 and pixel format declared as ARGB. Use GdipBitmapLockBits to transfer. Rest of comments below exclude 32 bit icons

- Cursors and 1 bit icons loaded by handle. Use GetIconInfo & GetDIBits APIs to convert 1 bit to 32 bit. Use existing mask. Then use CreateIconFromResourceEx to create hIcon, not cursor. Destroy original icon/cursor. Assuming 32 bit icons are processed separately, then since no alpha channel is used here, we can use any bit depth other than 1. Internally, GDI+ converts icons to 32 bit bitmaps.

- 16,24 bit icons loaded from file/stream. You can load these via LoadImage API and then let GDI+ load via handle. Destroy icon.

- PNG encoded icon/cursor loaded from file. PNG-icons loaded by handle are hIcon. If from icon file, the entire PNG-file format starts at the icon offset within the icon file format. Load those PNG bytes at that offset, no other icon header info.

In the next couple of replies, I'll address some workarounds, specifically, regarding loading by handle or stream/file.

See also:
GDI+ Workaround: JPG > Zero-Length App Markers
GDI+ Workaround: TIFF > JPEG-compressed images
GDI+ Workaround: BMP > Alpha Channels + JPG/PNG Encoded
GDI+ Workaround: PNG > adding/removing metadata


A really simple example project is added that can highlight whether or not your system's version of GDI+ is loading icons correctly.
Attached Files
↧

[VB6] Look up Enum value names

December 15, 2015, 7:47 am
$
0
0
We see this question as well as very similar ones every so often:

"I want to be able to have users pick values by name from a list of Enum value names. Is there a way to do this without manually creating my own lists?"

I'm not sure we've seen many good responses to these, and I don't see one here so I thought I'd post one.

The only place your programs might look to find this information is inside type libraries. And we have a nice tool for doing this without a ton of effort.


The TLI

Quoting its help file:

Quote:
The TypeLib Information object library (TLI for short, implemented in TlbInf32.dll) is a set of COM objects designed to make type library browsing functionality easily accessible to both Visual Basic and C++ programmers.
Of course using it can take some study. But there is a wealth of functionality there, probably more than most programmers will ever need.


Requirements

You need the TLI, but since the VB6 IDE uses it you certainly have it. You may or may not have the help file for it, which was once distributed as TlbInf32.exe (a self-extractor). I don't have a current Microsoft link for that file though.

You also need type libraries for the Enums you want to do lookups on. These are often embedded within DLLs and OCXs, or may be in separate TLB files. In many cases it can be more conventient to access these by type library ID (GUID values), version, and locale (since there are such things as localized type libraries).


How To

So here is an example:

Code:
Option Explicit

Private Sub cboAdoTypes_Click()
    With cboAdoTypes
        lblDataType.Caption = CStr(.ItemData(.ListIndex))
        MsgBox .List(.ListIndex) & " = " & lblDataType.Caption
    End With
End Sub

Private Sub cboSysColors_Click()
    With cboSysColors
        BackColor = .ItemData(.ListIndex)
    End With
End Sub

Private Sub Form_Load()
    Const ADO_GUID As String = "{00000205-0000-0010-8000-00AA006D2EA4}"
    Dim DataTypeEnums As TLI.Members
    Dim SystemColorConsts As TLI.Members
    Dim Item As TLI.MemberInfo

    With New TLI.TLIApplication
        With .TypeLibInfoFromRegistry(ADO_GUID, 2, 5, 0).Constants
            Set DataTypeEnums = .NamedItem("DataTypeEnum").Members
        End With
        With .TypeLibInfoFromFile("msvbvm60.dll\3").Constants
            Set SystemColorConsts = .NamedItem("SystemColorConstants").Members
        End With
    End With
    With cboAdoTypes
        For Each Item In DataTypeEnums
            .AddItem Item.Name
            .ItemData(.NewIndex) = Item.Value
        Next
    End With
    With cboSysColors
        For Each Item In SystemColorConsts
            .AddItem Item.Name
            .ItemData(.NewIndex) = Item.Value
        Next
    End With
End Sub

Name: sshot1.png Views: 48 Size: 13.2 KB


Name: sshot2.png Views: 39 Size: 9.1 KB


Name: sshot3.png Views: 40 Size: 19.0 KB
Attached Images
   
Attached Files
↧
↧

FastSort for bytes

December 19, 2015, 9:43 pm
$
0
0
Here's my Histogram based FastSort function for bytes. Unlike normal Sort type algorithms, which require often many passes (the exact number depending on the exact arangement of numbers in the array) over a set of data, while swapping entries in the array, this one takes just 2 passes. The pass to creates the histogram from the input byte array, and the second one reads bytes out of the histogram into the output array. Unfortunately this won't work on Single and Double precision floating point values, as you can't have a histogram array with a fractional index (whole number indices only are allowed), it actually works great on integer data types. The one shown below is intended specifically with the Byte data type, but it should be fairly easy to modify it to work with Integer data type (though with the Long data type there would be a problem unless you limited the range, as it would take 16 gigabytes of ram, and so is not possible to implement in VB6, nor would it work even on most computers, as most computers don't have over 16GB of ram in them, as would be needed to hold both the Windows OS and the huge histogram).

Code:
Private Function FastSort(ByRef ArrayIn() As Byte) As Byte()
Dim ArrayOut() As Byte
Dim Histogram(255) As Long
Dim n As Long
Dim m As Long
Dim m2 As Long

ReDim ArrayOut(UBound(ArrayIn))
For n = 0 To UBound(ArrayIn)
    Histogram(ArrayIn(n)) = Histogram(ArrayIn(n)) + 1
Next n

For n = 0 To 255
    For m = 1 To Histogram(n)
        ArrayOut(m2) = n
        m2 = m2 + 1
    Next m
Next n
FastSort = ArrayOut()
End Function



Update:
I have discovered something very interesting. When used with small sized data sets (such as when sorting to find the median value of a 3x3 array of pixels), the byte-swapping Sort algorithm is actually faster than my histogram based FastSort algorithm.
↧

[VB6] - Store data to EXE.

December 22, 2015, 3:08 pm
$
0
0
Hello everyone!
There are times when you want to save the data after completion of the program, but did not want to have external dependencies, registry entries, etc. However you can store the data in your EXE. Unfortunately, Windows doesn't allow to write into the running EXE (i don't consider NTFS streams), and any attempt of the writing will be rejected with the ERROR_ACCESS_DENIED error. Although if the process is complete it can be performed by another process. Here is the way I decided to choose.
Firstly, you'd run cmd.exe with the suspended state. Further you'd create code that will be injected to it and will change the resources of our EXE. Then you'd run this code. This code waits for termination of our process and then rewrites the needed data (you've passed them to there). Eventually it is terminated.
In order to simplify the code (it only needs single form) i decide to make it in assembler. It is simpler and requires less code (source is included). Because the code is published especially for the review and test, it doesn't perform any synchronizations.
Code:
' Store data to EXE
' © Krivous Anatolii Anatolevich (The trick), 2014
' Writing is performed only after process termination

Option Explicit

Private Type STARTUPINFO
    cb              As Long
    lpReserved      As Long
    lpDesktop      As Long
    lpTitle        As Long
    dwX            As Long
    dwY            As Long
    dwXSize        As Long
    dwYSize        As Long
    dwXCountChars  As Long
    dwYCountChars  As Long
    dwFillAttribute As Long
    dwFlags        As Long
    wShowWindow    As Integer
    cbReserved2    As Integer
    lpReserved2    As Long
    hStdInput      As Long
    hStdOutput      As Long
    hStdError      As Long
End Type

Private Type PROCESS_INFORMATION
    hProcess        As Long
    hThread        As Long
    dwProcessId    As Long
    dwThreadId      As Long
End Type

Private Type ThreadData
    hParent        As Long
    lpFileName      As Long
    lpRsrcName      As Long
    lpData          As Long
    dwDataCount    As Long
    lpWFSO          As Long
    lpCH            As Long
    lpBUR          As Long
    lpUR            As Long
    lpEUR          As Long
    lpEP            As Long
End Type

Private Declare Function CloseHandle Lib "kernel32" ( _
                        ByVal hObject As Long) As Long
Private Declare Function CreateProcess Lib "kernel32" _
                        Alias "CreateProcessW" ( _
                        ByVal lpApplicationName As Long, _
                        ByVal lpCommandLine As Long, _
                        lpProcessAttributes As Any, _
                        lpThreadAttributes As Any, _
                        ByVal bInheritHandles As Long, _
                        ByVal dwCreationFlags As Long, _
                        lpEnvironment As Any, _
                        ByVal lpCurrentDirectory As Long, _
                        lpStartupInfo As STARTUPINFO, _
                        lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function GetModuleHandle Lib "kernel32" _
                        Alias "GetModuleHandleA" ( _
                        ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" ( _
                        ByVal hModule As Long, _
                        ByVal lpProcName As String) As Long
Private Declare Function DuplicateHandle Lib "kernel32" ( _
                        ByVal hSourceProcessHandle As Long, _
                        ByVal hSourceHandle As Long, _
                        ByVal hTargetProcessHandle As Long, _
                        lpTargetHandle As Long, _
                        ByVal dwDesiredAccess As Long, _
                        ByVal bInheritHandle As Long, _
                        ByVal dwOptions As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function VirtualAllocEx Lib "kernel32.dll" ( _
                        ByVal hProcess As Long, _
                        lpAddress As Any, _
                        ByVal dwSize As Long, _
                        ByVal flAllocationType As Long, _
                        ByVal flProtect As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" ( _
                        ByVal hProcess As Long, _
                        ByVal lpBaseAddress As Long, _
                        lpBuffer As Any, _
                        ByVal nSize As Long, _
                        lpNumberOfBytesWritten As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" ( _
                        src As Any, _
                        dst As Any) As Long
Private Declare Function VirtualFreeEx Lib "kernel32.dll" ( _
                        ByVal hProcess As Long, _
                        lpAddress As Any, _
                        ByVal dwSize As Long, _
                        ByVal dwFreeType As Long) As Long
Private Declare Function CreateRemoteThread Lib "kernel32" ( _
                        ByVal hProcess As Long, _
                        lpThreadAttributes As Any, _
                        ByVal dwStackSize As Long, _
                        ByVal lpStartAddress As Long, _
                        lpParameter As Any, _
                        ByVal dwCreationFlags As Long, _
                        lpThreadId As Long) As Long
Private Declare Function FindResource Lib "kernel32" _
                        Alias "FindResourceW" ( _
                        ByVal hInstance As Long, _
                        ByVal lpName As Long, _
                        ByVal lpType As Long) As Long
Private Declare Function LoadResource Lib "kernel32" ( _
                        ByVal hInstance As Long, _
                        ByVal hResInfo As Long) As Long
Private Declare Function LockResource Lib "kernel32" ( _
                        ByVal hResData As Long) As Long
Private Declare Function SizeofResource Lib "kernel32" ( _
                        ByVal hInstance As Long, _
                        ByVal hResInfo As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
                        Alias "RtlMoveMemory" ( _
                        Destination As Any, _
                        Source As Any, _
                        ByVal Length As Long)

Private Const STARTF_USESHOWWINDOW      As Long = &H1
Private Const SW_HIDE                  As Long = 0
Private Const MEM_COMMIT                As Long = &H1000&
Private Const MEM_RESERVE              As Long = &H2000&
Private Const MEM_RELEASE              As Long = &H8000&
Private Const PAGE_EXECUTE_READWRITE    As Long = &H40&
Private Const INFINITE                  As Long = -1&
Private Const MAX_PATH                  As Long = 260
Private Const RT_RCDATA                As Long = 10&
Private Const CREATE_SUSPENDED          As Long = &H4
Private Const DUPLICATE_SAME_ACCESS    As Long = &H2
Private Const ResName                  As String = "TRICKRESOURCE" & vbNullChar    ' Only capital letters

' // Procedure load data from EXE
Private Sub LoadFromEXE()
    Dim hRes As Long, hMem As Long, ptr As Long, l As Long, Msg As String
   
    hRes = FindResource(0, StrPtr(ResName), RT_RCDATA)
   
    If hRes Then
        hMem = LoadResource(0, hRes)
        If hMem Then
            l = SizeofResource(0, hRes)
            If l Then
                ptr = LockResource(hMem)
                GetMem4 ByVal ptr, l
                Msg = Space(l \ 2)
                CopyMemory ByVal StrPtr(Msg), ByVal ptr + 4, l
                txtData.Text = Msg
            End If
        End If
    End If
   
End Sub

' // Procedure store data to EXE
Private Sub StoreToExe()
    Dim hLib As Long
    Dim td As ThreadData, ts As Long, path As String, pi As PROCESS_INFORMATION, si As STARTUPINFO, hProc As Long, lpDat As Long, pt As Long
    Dim Code() As Byte, Data() As Byte, ret As Long, thr As Long, otd As Long
   
    ' // Get the Kernel32 handle
    hLib = GetModuleHandle("kernel32")
    If hLib = 0 Then MsgBox "Error": Exit Sub
   
    ' // Get the functions addresses
    td.lpWFSO = GetProcAddress(hLib, "WaitForSingleObject")
    td.lpCH = GetProcAddress(hLib, "CloseHandle")
    td.lpBUR = GetProcAddress(hLib, "BeginUpdateResourceW")
    td.lpUR = GetProcAddress(hLib, "UpdateResourceW")
    td.lpEUR = GetProcAddress(hLib, "EndUpdateResourceW")
    td.lpEP = GetProcAddress(hLib, "ExitProcess")
   
    path = App.path & "\" & App.EXEName & ".exe" & vbNullChar
   
    ' // Create the machine code
    CreateCode Code
   
    ' // Calculate size of the needed memory
    ts = LenB(path) + LenB(ResName) + (UBound(Code) + 1) + LenB(txtData.Text) + Len(td) + 4
   
    si.cb = Len(si)
    si.dwFlags = STARTF_USESHOWWINDOW
    si.wShowWindow = SW_HIDE
   
    ' // Launch "victim" (CMD.EXE)
    If CreateProcess(StrPtr(Environ("ComSpec")), 0, ByVal 0&, ByVal 0&, False, CREATE_SUSPENDED, ByVal 0, 0, si, pi) = 0 Then
        MsgBox "error": Exit Sub
    End If
   
    ' // Get handle of the our process for CMD process
    hProc = GetCurrentProcess()
    DuplicateHandle hProc, hProc, pi.hProcess, td.hParent, 0, False, DUPLICATE_SAME_ACCESS
   
    td.dwDataCount = LenB(txtData.Text) + 4        ' Размер данных
   
    ' // Allocate memory in the CMD
    lpDat = VirtualAllocEx(pi.hProcess, ByVal 0, ts, MEM_COMMIT Or MEM_RESERVE, PAGE_EXECUTE_READWRITE)
   
    If lpDat = 0 Then
        MsgBox "Error": CloseHandle pi.hThread: CloseHandle pi.hProcess
        VirtualFreeEx pi.hProcess, ByVal lpDat, 0, MEM_RELEASE
        Exit Sub
    End If
   
    ' // Ok, all is ready for the writing to cmd
    ' // Create buffer with data
    ReDim Data(ts - 1)
   
    ' // Copy the file name of our process
    CopyMemory Data(pt), ByVal StrPtr(path), LenB(path)
    td.lpFileName = lpDat + pt: pt = pt + LenB(path)
    ' // Copy the name of the resource
    CopyMemory Data(pt), ByVal StrPtr(ResName), LenB(ResName)
    td.lpRsrcName = lpDat + pt: pt = pt + LenB(ResName)
    ' // Copy the data of the resource
    GetMem4 LenB(txtData.Text), Data(pt)          ' Размер
    CopyMemory Data(pt + 4), ByVal StrPtr(txtData.Text), LenB(txtData.Text)
    td.lpData = lpDat + pt: pt = pt + LenB(txtData.Text) + 4
    ' // Copy the structure to buffer
    CopyMemory Data(pt), td, Len(td): otd = pt: pt = pt + Len(td)
    ' // Copy the code
    CopyMemory Data(pt), Code(0), UBound(Code) + 1
   
    ' // Buffer is ready, inject it to cmd
    If WriteProcessMemory(pi.hProcess, lpDat, Data(0), ts, ret) Then
        If ret <> ts Then
            MsgBox "Error": CloseHandle pi.hThread: CloseHandle pi.hProcess
            VirtualFreeEx pi.hProcess, ByVal lpDat, 0, MEM_RELEASE
            Exit Sub
        End If
        ' // Launch the injected code
        thr = CreateRemoteThread(pi.hProcess, ByVal 0, 0, lpDat + pt, ByVal lpDat + otd, 0, 0)
        If thr = 0 Then
            MsgBox "Error": CloseHandle pi.hThread: CloseHandle pi.hProcess
            VirtualFreeEx pi.hProcess, ByVal lpDat, 0, MEM_RELEASE
            Exit Sub
        End If
    End If
   
    ' // Close handles
    CloseHandle thr
    CloseHandle pi.hThread
    CloseHandle pi.hProcess
   
End Sub

Private Sub CreateCode(Code() As Byte)
    ReDim Code(63)
    Code(0) = &H8B: Code(1) = &H74: Code(2) = &H24: Code(3) = &H4: Code(4) = &H31: Code(5) = &HDB: Code(6) = &H53: Code(7) = &H6A
    Code(8) = &HFF: Code(9) = &HFF: Code(10) = &H36: Code(11) = &HFF: Code(12) = &H56: Code(13) = &H14: Code(14) = &HFF: Code(15) = &H36
    Code(16) = &HFF: Code(17) = &H56: Code(18) = &H18: Code(19) = &H53: Code(20) = &HFF: Code(21) = &H76: Code(22) = &H4: Code(23) = &HFF
    Code(24) = &H56: Code(25) = &H1C: Code(26) = &H89: Code(27) = &H4: Code(28) = &H24: Code(29) = &H85: Code(30) = &HC0: Code(31) = &H74
    Code(32) = &H1B: Code(33) = &HFF: Code(34) = &H76: Code(35) = &H10: Code(36) = &HFF: Code(37) = &H76: Code(38) = &HC: Code(39) = &H53
    Code(40) = &HFF: Code(41) = &H76: Code(42) = &H8: Code(43) = &H6A: Code(44) = &HA: Code(45) = &HFF: Code(46) = &H74: Code(47) = &H24
    Code(48) = &H14: Code(49) = &HFF: Code(50) = &H56: Code(51) = &H20: Code(52) = &H53: Code(53) = &HFF: Code(54) = &H74: Code(55) = &H24
    Code(56) = &H4: Code(57) = &HFF: Code(58) = &H56: Code(59) = &H24: Code(60) = &H53: Code(61) = &HFF: Code(62) = &H56: Code(63) = &H28
End Sub

Private Sub Form_Load()
    LoadFromEXE
End Sub

Private Sub Form_Unload(Cancel As Integer)
    StoreToExe
End Sub

'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ This procedure is running in other process \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

' Similar code in VB6

'Private Sub ThreadProc(dat As ThreadData)
'    Dim hRes As Long
'    ' Wait for the termination of the main process
'    WaitForSingleObject dat.hParent, INFINITE
'    ' Process has ended, close handle
'    CloseHandle dat.hParent
'    ' Get handle of the editing of the resource
'    hRes = BeginUpdateResource(dat.lpFileName, False)
'    If hRes Then
'      ' Wirte the needed data to EXE
'      UpdateResource hRes, RT_RCDATA, dat.lpRsrcName, 0, ByVal dat.lpData, dat.dwDataCount
'      ' Ending of the updating
'      EndUpdateResource hRes, False
'    End if
'      ' Done !!!
'    ExitProcess 0
'End Sub

' Assembly code (NASM)

'[BITS 32]
'; ThreadProc
'mov esi,dword [esp+0x04]; ESI = &dat
'xor ebx,ebx            ; Const 0&
'push ebx                ; Dim hRes As Long
'push 0xFFFFFFFF        ; INFINITE
'push dword [esi+0x00]  ; dat.hParent
'call [esi+0x14]        ; WaitForSingleObject dat.hParent, INFINITE
'push dword [esi+0x00]  ; dat.hParent
'call [esi+0x18]        ; CloseHandle dat.hParent
'push ebx                ; False
'push dword [esi+0x04]  ; dat.lpFileName
'call [esi+0x1c]        ; BeginUpdateResource(dat.lpFileName, False)
'mov [esp],eax          ; hRes = eax
'test eax,eax            ; IF hRes=0
'je ExtProc              ; GoTo ExtProc
'push dword [esi+0x10]  ; dat.dwDataCount
'push dword [esi+0x0c]  ; dat.lpData
'push ebx                ; 0
'push dword [esi+0x08]  ; dat.lpRsrcName
'push 0x0000000a        ; RT_RCDATA
'push dword [esp+0x14]  ; hRes
'call [esi+0x20]        ; UpdateResource hRes, RT_RCDATA, dat.lpRsrcName, 0, ByVal dat.lpData, dat.dwDataCount
'push ebx                ; False
'push dword [esp+0x04]  ; hRes
'call [esi+0x24]        ; EndUpdateResource hRes, False
'ExtProc:
'push ebx                ; 0
'call [esi+0x28]        ; ExitProcess 0
Attached Files
↧

VB6 - Fast Sqr

December 23, 2015, 4:45 am
$
0
0
Internal VB6 Sqr() function is very slow

Here is my FastSqr() function

N>=0

Code:
Public Function FASTsqr(n As Double) As Double
    Dim X      As Double
    Dim oldX    As Double

    If n Then
        'EDIT:
        'X = n * 0.25
        X = n * 0.5
        Do
            oldX = X
            X = (X + (n / X)) * 0.5
        Loop While oldX <> X

        FASTsqr = X
    End If

End Function
↧
Viewing all 1474 articles
Browse latest View live
Search
<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>