please delete
↧
please delete
↧
[VB6] Color surface and scatter charts with nice color maps
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.
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.
↧
↧
[VB6] PicSave - Simple SavePicture as GIF, PNG, JPEG
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.
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.
↧
Analog Clock example
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.
↧
Sludge Tools - an old but, still interesting, and possibly useful project
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: 37
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.
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:
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.
↧
↧
[VB6] Code Snippet: Open a folder and select multiple files in Explorer
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
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↧
Data Insert Oracle Server
Please Help Me To Data Insert Oracle Server Using VB.NET .Just Share Code Structure .Oracle Is My First Time Use .
↧
[vb6] Class to make Image Controls Support PNG, TIF, GIF Animation
Status: Updated 11 Nov 2015 to include support for non-placeable WMFs
We all know VB is old and doesn't support many of the common image formats, specifically: TIF, PNG and alpha-blended icons. The attached class enables VB to support those formats and a bit more. There is no usercontrol involved. Just a bit of subclassing (IDE safe) to enable the images to be rendered with APIs that do support the alpha channel: AlphaBlend and DrawIconEx. The class is not limited to just Image controls, can be applied to most (if not all) of VB's picture, icon, and other image properties.
Image formats supported. The 'includes' below are in addition to what VB supports:
:: BMP. Includes 32bpp alpha and/or premultiplied. Includes those created with v4 & v5 of the bitmap info header
:: GIF. Includes methods to navigate frames
:: JPG. Includes CMYK color space
:: ICO,CUR. Includes 32bpp alpha and/or PNG-encoded Vista-type icons
:: WMF. Includes non-placeable
:: EMF
:: PNG
:: TIF. Both single page & multi-page. Supported compression schemes depend on version of GDI+ installed
See post #8 below for tips regarding design-view usage
The class methods/properties can be categorized as follows:
I. VB Replacement Methods
- LoadPicture: Unicode supported. Has options to keep original image format when loading. This enables you to navigate animated GIF frames and multipage TIFs. Cached data allows you to save that original data to file
- SavePicture: Unicode supported. Has options to always save to bitmap or save original format if it exists
- PictureType: Returns the original image format, i.e., GIF, PNG, TIF, etc, if that format exists
note: LoadPicture & SavePicture both accept byte array as source/destination medium
II. Management Methods
- IsManaged: Return whether the class is rendering the image or VB is
- UnManage: Simply unsubclasses a managed image
- HasOriginalFormat: Return whether or not any Picture is caching original image format data
III. Navigation Methods
- SubImageCount: Returns the number of frames/pages contained within the managed image
- SubImageIndex: Returns the current frame/page displayed by the managed image
- SubImage: Returns a stdPicture object of the requested frame/page
- GetGIFAnimationInfo: Returns an array containing loop count and each frame's display interval for animated GIFs
Quickly. How does this class do it?
1. It creates thunks to subclass the VB picture objects. The source code of the thunks are provided in the package. These thunks draw the image using the APIs AlphaBlend or DrawIconEx. For you ASM gurus out there: I'm a noob with ASM. I'm sure others can rewrite that ASM code to be more efficient.
2. To support AlphaBlend API, images may be converted to a 32bit bitmap having the pixel data premultiplied against the alpha channel. These bitmaps will never display correctly outside of the class. Therefore the class' SavePicture function allows you to create a copy of the bitmap that can be displayed outside of the class. This copy can be passed to the clipboard and/or drag/drop methods of your project.
3. GDI+ is relied upon to parse/load TIF and PNG. It is also used to support JPG in CMYK format, non-placeable WMFs and multi-frame GIF rendering. GDI+ is a requirement for the class. If it fails to load or thunks fail to be created, the class will silently fall back to standard VB methods and VB restrictions.
The transparency displayed by the image control is not faked. It is true transparency and the attached test project should easily prove that. Important to understand. TIF and PNG support is not available at design-time. This is because the class code isn't activated until run-time. Some motivated individuals out there could easily create a windowless usercontrol that hosts an image control (and this class) that could support all formats at design-time. Just a thought and subtle prod.
The class can be expanded by those willing to put in the effort. Ideas would be to incorporate GDI+ high quality scaling, conversion from one image format to another, image effects like rotation, blur, and more. Other image formats can easily be supported from outside the class. If you can parse/render that new format to a 32bpp bitmap, then you can use the class' LoadPicture to display that image. Have fun.
Tip: If modifying the thunks or code, recommend identifying these new versions using a different key. Throughout the code, you can find a couple instances of this text: IPIC+Thunker. Change those instances to reflect something else, i.e., "IPIC+Thunker.v2" so you can distinguish between your versions.
When compiled, VB can behave differently vs when uncompiled. Some differences are subtle, others are not. Here's one that is key for animating GIFs. In the test project posted below, the animation works because VB caches the GIF format for the GIF that was loaded into Image1 during design-time. During run-time that info is still cached by VB so the class can extract the entire GIF. But when you compile the project, the GIF no longer animates. Why? Well, when compiled, the GIF information is lost. VB no longer caches it. This can be proven in a simple test project. Add a image control and button. Add a GIF or JPG to that image control. Add the following code behind the button. Click the button when project is running compiled and uncompiled. Different results. The workaround is simply to save GIFs you want to animate in a resource file and load the GIF from that.
Design-time vs. Run-time screenshot
![Name: Untitled.jpg
Views: 177
Size: 33.2 KB]()
We all know VB is old and doesn't support many of the common image formats, specifically: TIF, PNG and alpha-blended icons. The attached class enables VB to support those formats and a bit more. There is no usercontrol involved. Just a bit of subclassing (IDE safe) to enable the images to be rendered with APIs that do support the alpha channel: AlphaBlend and DrawIconEx. The class is not limited to just Image controls, can be applied to most (if not all) of VB's picture, icon, and other image properties.
Image formats supported. The 'includes' below are in addition to what VB supports:
:: BMP. Includes 32bpp alpha and/or premultiplied. Includes those created with v4 & v5 of the bitmap info header
:: GIF. Includes methods to navigate frames
:: JPG. Includes CMYK color space
:: ICO,CUR. Includes 32bpp alpha and/or PNG-encoded Vista-type icons
:: WMF. Includes non-placeable
:: EMF
:: PNG
:: TIF. Both single page & multi-page. Supported compression schemes depend on version of GDI+ installed
See post #8 below for tips regarding design-view usage
The class methods/properties can be categorized as follows:
I. VB Replacement Methods
- LoadPicture: Unicode supported. Has options to keep original image format when loading. This enables you to navigate animated GIF frames and multipage TIFs. Cached data allows you to save that original data to file
- SavePicture: Unicode supported. Has options to always save to bitmap or save original format if it exists
- PictureType: Returns the original image format, i.e., GIF, PNG, TIF, etc, if that format exists
note: LoadPicture & SavePicture both accept byte array as source/destination medium
II. Management Methods
- IsManaged: Return whether the class is rendering the image or VB is
- UnManage: Simply unsubclasses a managed image
- HasOriginalFormat: Return whether or not any Picture is caching original image format data
III. Navigation Methods
- SubImageCount: Returns the number of frames/pages contained within the managed image
- SubImageIndex: Returns the current frame/page displayed by the managed image
- SubImage: Returns a stdPicture object of the requested frame/page
- GetGIFAnimationInfo: Returns an array containing loop count and each frame's display interval for animated GIFs
Quickly. How does this class do it?
1. It creates thunks to subclass the VB picture objects. The source code of the thunks are provided in the package. These thunks draw the image using the APIs AlphaBlend or DrawIconEx. For you ASM gurus out there: I'm a noob with ASM. I'm sure others can rewrite that ASM code to be more efficient.
2. To support AlphaBlend API, images may be converted to a 32bit bitmap having the pixel data premultiplied against the alpha channel. These bitmaps will never display correctly outside of the class. Therefore the class' SavePicture function allows you to create a copy of the bitmap that can be displayed outside of the class. This copy can be passed to the clipboard and/or drag/drop methods of your project.
3. GDI+ is relied upon to parse/load TIF and PNG. It is also used to support JPG in CMYK format, non-placeable WMFs and multi-frame GIF rendering. GDI+ is a requirement for the class. If it fails to load or thunks fail to be created, the class will silently fall back to standard VB methods and VB restrictions.
The transparency displayed by the image control is not faked. It is true transparency and the attached test project should easily prove that. Important to understand. TIF and PNG support is not available at design-time. This is because the class code isn't activated until run-time. Some motivated individuals out there could easily create a windowless usercontrol that hosts an image control (and this class) that could support all formats at design-time. Just a thought and subtle prod.
The class can be expanded by those willing to put in the effort. Ideas would be to incorporate GDI+ high quality scaling, conversion from one image format to another, image effects like rotation, blur, and more. Other image formats can easily be supported from outside the class. If you can parse/render that new format to a 32bpp bitmap, then you can use the class' LoadPicture to display that image. Have fun.
Tip: If modifying the thunks or code, recommend identifying these new versions using a different key. Throughout the code, you can find a couple instances of this text: IPIC+Thunker. Change those instances to reflect something else, i.e., "IPIC+Thunker.v2" so you can distinguish between your versions.
When compiled, VB can behave differently vs when uncompiled. Some differences are subtle, others are not. Here's one that is key for animating GIFs. In the test project posted below, the animation works because VB caches the GIF format for the GIF that was loaded into Image1 during design-time. During run-time that info is still cached by VB so the class can extract the entire GIF. But when you compile the project, the GIF no longer animates. Why? Well, when compiled, the GIF information is lost. VB no longer caches it. This can be proven in a simple test project. Add a image control and button. Add a GIF or JPG to that image control. Add the following code behind the button. Click the button when project is running compiled and uncompiled. Different results. The workaround is simply to save GIFs you want to animate in a resource file and load the GIF from that.
Code:
Dim IPic As IPicture
Set IPic = Image1.Picture
MsgBox CStr(IPic.KeepOriginalFormat)↧
Copy to Clipboard as Unicode and Html Form
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
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), "<⁄", A$)
A$ = ReplaceStr(Chr$(3), "<", A$)
A$ = ReplaceStr(Chr$(4), ">", A$)
' SO ALL SPACES ARE NOW NBSP IF ARE IN A SEQUENCE OF TWO OR MORE
A$ = ReplaceStr(Chr$(7), " ", 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
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.
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
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
Delimiting the delimiters. Simple rule, replace each delimiter with a double delimiter
:: Sample field with Quote delimiter: Hello, my name is "LaVolpe"
-- Quote delimiters are doubled only within the field data. The field data is written to file with a single quote both as a prefix & suffix
-- 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
-- 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
And, just for the heck of it, a real simple example of loading a CSV to a ListView. In the parser's event:
The attachment is a class file, remove the .txt extension after downloading
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.Negative indicates number of missing fields in the record. HeaderCount + FieldDifferential = number processed fields
Positive indicates number of extra fields in the record.
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
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
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"""
:: Sample field with Escape delimiter: C:\My DocumentsSaved 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. The field data is written to file with a single quote both as a prefix & suffix
-- 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
-- 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 SubCode:
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↧
VB6 - Generate ECC Key DLL
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
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
↧
GDI+ Workaround: ICONs
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.
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.
↧
[VB6] Look up Enum value names
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:
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:
![Name: sshot1.png
Views: 44
Size: 13.2 KB]()
![Name: sshot2.png
Views: 35
Size: 9.1 KB]()
![Name: sshot3.png
Views: 36
Size: 19.0 KB]()
"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.
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↧
↧
FastSort for bytes
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).
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.
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 FunctionUpdate:
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.
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↧
VB6 - Fast Sqr
Internal VB6 Sqr() function is very slow
Here is my FastSqr() function
N>=0
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↧
VB6 Simple FTP-Client (PASV-mode, based on Winsock.ocx)
As the title says -
not much to comment - other than that it's a quite old code-base
(though slightly revised now - and still working with most FTP-Servers).
Source-Code: FTP-revised2.zip
ScreenShot:
![]()
Have fun with it,
Olaf
not much to comment - other than that it's a quite old code-base
(though slightly revised now - and still working with most FTP-Servers).
Source-Code: FTP-revised2.zip
ScreenShot:
Have fun with it,
Olaf
↧
↧
[VB6] - Wave steganography.
Today i want to talk about the cryptography. I've made the example of using the special cryptography - the steganography. This method hides the fact of encryption of the data. There are lot of kinds of the steganography. Today i'll talk about LSB-method when data is hided into the least significant bits of the audio file. It looks as though you are exchanged a audio files, but really you send a secret data. People who don't know about this method they will not even suspect about secret data. In some cases it can be very useful.
How does it work?
A WAVE-PCM file (without a compressions) contains sound data. Really the sound is an analog event, i.e. continuous. In order to convert it to digital form you should quantize it with lossy. This process is characterized by two parameters: bitness and sample per second. "Bitness" affects to how many levels can it contains in each sample. "Sample per second" affects to how many frequencies do you can hear:
In this case we are interested only the bitness of an audio. It can be 32, 24, 16, .... bits per each sample. Main idea of steganography (in this case) is rewrite the least significant bits to our data. The more you overwrite bits the greater the distortion.
This picture explains it graphically:
As you can see, it stores all hidden data to certain bits in the audio data (in this picture 4 bits to each sample). Also note that for storing the data you need to use the bigger file size than the source file. For instance, if you use 3 bit for the decoding the result file will have the size that is 16/3 times greater than source. I've said 16 because i use the 16 bps wave file in my example.
In the attached example i also save the original file name. In general, format of the data is described in the picture:
When the packing occurs it gets each byte from the source file. Then the subroutine extracts the necessary bits from the source file and clears corresponding bits in the audio data. Further the subroutine sets bits using bitwise-OR operator. For extracting the necessary bits it uses the masks and the shifts. The mask leaves necessary bits and the shift places them to the beginning of the byte.
Unpacking works vice versa. It extracts bits from audio data and builds file using corresponding bits.
Hope the review will be useful.
Thanks for attention.
Regards,
Кривоус Анатолий.
↧
BSTR2LPSTR and LPSTR2BSTR conversions for VB6
The problem with a number of API functions is that they return strings as LPSTR. An LPSTR is a pointer to a string in memory that is terminated with null (0x00 byte), and the strings themselves are in an ANSI format, not UNICODE. And the string length isn't stored anywhere. Meanwhile in VB6, its strings are of the BSTR type. These are pointers to UNICODE strings, and while these are terminated with a unicode null (0x0000 word), they also have a byte count in the 4 bytes before the start of the string. Note that this does not include the 2 byte null at the end.
To convert between LPSTR and BSTR, I've created these 2 functions. Put the below code into a module in VB6.
To test out these functions, put the below code into your Form1, and make sure the AutoRedraw property is set to True for Form1, then run the program.
If it is working correctly on your computer, the sentence "This is a test." should appear 3 times on the form, and then the numbers 15, 256, and 15 should appear. The 2 15s are the sizes of the original BSTR string, and BSTR string that was created from the LPSTR string that was created from the original BSTR string. The 256 is the size of the block of memory in which the LPSTR was stored. The block of memory in which the string that pointed to by the LPSTR is stored, must be no smaller than the length of the string, but it can be larger than that length without a problem (as this program demonstrates).
To convert between LPSTR and BSTR, I've created these 2 functions. Put the below code into a module in VB6.
Code:
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Public Sub BSTR2LPSTR(ByVal BSTR As String, ByVal LPSTR As Long)
Dim STR() As Byte
STR() = StrConv(BSTR & vbNullChar, vbFromUnicode)
CopyMemory ByVal LPSTR, STR(0), UBound(STR) + 1
End Sub
Public Function LPSTR2BSTR(ByVal LPSTR As Long, Optional ByVal NullSearchDist As Long = 256) As String
Dim STR() As Byte
Dim NullOffset As Long
Dim StrLen As Long
ReDim STR(NullSearchDist - 1)
CopyMemory STR(0), ByVal LPSTR, NullSearchDist
NullOffset = InStrB(1, STR, vbNullChar) - 1
Select Case NullOffset
Case -1
StrLen = NullSearchDist
Case 0
StrLen = 1
Case Else
StrLen = NullOffset
End Select
ReDim Preserve STR(StrLen - 1)
LPSTR2BSTR = StrConv(STR, vbUnicode)
End FunctionTo test out these functions, put the below code into your Form1, and make sure the AutoRedraw property is set to True for Form1, then run the program.
Code:
Private Sub Form_Load()
Dim a As String
Dim b() As Byte
Dim ptrb As Long
Dim c As String
Dim n As Long
ReDim b(255)
ptrb = VarPtr(b(0))
a = "This is a test."
BSTR2LPSTR a, ptrb
c = LPSTR2BSTR(ptrb)
Print a
For n = 0 To 255
If b(n) = 0 Then Exit For
Print Chr$(b(n));
Next n
Print ""
Print c
Print Len(a)
Print UBound(b) + 1
Print Len(c)
End Sub↧
[vb6] PropertyBag, Persisting, Cloning for UserControls
With VB, we have the use of the PropertyBag object. It is used in usercontrols to persist settings and can be used in public classes (within DLL,OCX projects) that have the Persistable property set to true.
What is shown below is nothing new, but maybe just a different way of doing it, from a UserControl perspective.
The usercontrol, and maybe some classes that you create, have a ReadProperties and WriteProperties event. These events are called when the object is being created (InitProperties,ReadProperties) and destroyed/saved (WriteProperties).
In your usercontrol project, you may have several classes also. Some of these classes have data that needs to be saved to the usercontrol. When the usercontrol is loaded, the class is created and that data loaded into the class. By using a property bag, whether your class has the Persistable property set to true or not, you can persist the data. Additionally, the user can have the option to "export" the class data so they can save it where/when they wish. The user could also "import" the data into the class from a previously saved state.
In my hypothetical usercontrol (UCWidget), I have several classes, some of which the user can create, modify, then assign to UCWidget via properties. One such hypothetical class is IAttributes. The IAttributes class is accessed via UCWidget.Attributes property directly during runtime and indirectly during design-time via the property page.
The IAttributes class, along with all classes to be persisted, within the UCWidget, project has an Export and Import sub. That sub is either Public or Friend declared. Public versions allow importing/exporting by both the UCWidget control and/or the user. The Friend declared versions only allow the UCWidget to do the import/export. The functions look like this:
A user, during runtime, can import/export via a property bag:
Likewise, the UCWidget control itself can serialize IAttributes during its Read/WriteProperties event:
The same approach can be used to clone anything in your usercontrol project. For example, cloning an IAttributes class and assigning it to a different UCWidget control.
We can even clone the entire UCWidget to another UCWidget control. But we'd first want to expose the Read/WriteProperties events via a public Export/Import subroutine:
What is shown below is nothing new, but maybe just a different way of doing it, from a UserControl perspective.
The usercontrol, and maybe some classes that you create, have a ReadProperties and WriteProperties event. These events are called when the object is being created (InitProperties,ReadProperties) and destroyed/saved (WriteProperties).
In your usercontrol project, you may have several classes also. Some of these classes have data that needs to be saved to the usercontrol. When the usercontrol is loaded, the class is created and that data loaded into the class. By using a property bag, whether your class has the Persistable property set to true or not, you can persist the data. Additionally, the user can have the option to "export" the class data so they can save it where/when they wish. The user could also "import" the data into the class from a previously saved state.
In my hypothetical usercontrol (UCWidget), I have several classes, some of which the user can create, modify, then assign to UCWidget via properties. One such hypothetical class is IAttributes. The IAttributes class is accessed via UCWidget.Attributes property directly during runtime and indirectly during design-time via the property page.
The IAttributes class, along with all classes to be persisted, within the UCWidget, project has an Export and Import sub. That sub is either Public or Friend declared. Public versions allow importing/exporting by both the UCWidget control and/or the user. The Friend declared versions only allow the UCWidget to do the import/export. The functions look like this:
Code:
Public Sub Export(PropBag As PropertyBag)
If PropBag Is Nothing Then Set PropBag = New PropertyBag
' save all class settings to the property bag, exactly same as a usercontrol's WriteProperties event
End Sub
Public Sub Import(PropBag As PropertyBag)
If PropBag Is Nothing Then
' optional: reset all properties to default, exactly same as a usercontrol's InitProperties event
Else
' read all class settings from the property bag, exactly same as a usercontrol's ReadProperties event
End If
End SubCode:
' export example
Dim myBag As PropertyBag
UCWidget1.Attributes.Export myBag ' export the IAttributes class data
' save myBag.Contents to file. Contents can be assigned to a byte array if desired
' import example
Dim myBag As PropertyBag
' read previously saved data to array: byteData() As Byte
Set myBag = New PropertyBag
myBag.Contents = byteData(): Erase byteData()
UCWidget1.Attributes.Import myBag ' import data into the IAttributes classCode:
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Dim pBag As PropertyBag
m_Attributes.Export pBag ' m_Attributes is the UCWidget's class instance of IAttributes
PropBag.Write "Attrs", pBag.Contents
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Dim pBag As PropertyBag
Set pBag = New PropertyBag
pBag.Contents = PropBag.ReadProperty("Attrs")
m_Attributes.Import pBag ' m_Attributes is the UCWidget's class instance of IAttributes
' m_Attributes set to new instance during UserControl_Initialize
End SubCode:
Dim pBag As PropertyBag
UCWidgetA.Attributes.Export pBag
UCWidgetB.Attributes.Import pBagCode:
Public Sub Export(PropBag As PropertyBag)
If PropBag Is Nothing Then Set PropBag = New PropertyBag
' save all class settings to the property bag, exactly same as a usercontrol's WriteProperties event
End Sub
Public Sub Import(PropBag As PropertyBag)
' create any classes/references needed for this object (code usually found in the UserControl_Initialize event)
If PropBag Is Nothing Then
' reset all properties to default, exactly same as a usercontrol's InitProperties event
Else
' read all class settings from the property bag, exactly same as a usercontrol's ReadProperties event
End If
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call Me.Export(PropBag) ' redirect so we don't need double the code
End Sub
Private Sub UserControl_InitProperties()
Call Me.Import(Nothing) ' redirect so we don't need double the code
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Call Me.Import(PropBag) ' redirect so we don't need double the code
End Sub↧