Let me first state: I did not write this code. I simply made two usercontrols with the code and later combined them together . So there is a little duplication here and there (messy I know) , but hopefully it is still useful.
↧
SunRise SunSet and Moon Phases
↧
"Alpha wipe" image transition
A photo transition effect that wipes a new image over an old image working from left to right. Easily modified to wipe right to left, top to bottom, or bottom to top.
Unzip into a directory.
Copy two JPEG images into the Project folder as Back.jpg and Front.jpg, both images having the same dimensions.
I suggest larger than 300x300 but smaller than your primary monitor since this demo does not attempt to scale them. The Form will be resized to fit these images. To best see the effect the two images should be quite different.
Then just run it. Front will be "wiped" over Back, then they will be swapped and the process repeats.
Unzip into a directory.
Copy two JPEG images into the Project folder as Back.jpg and Front.jpg, both images having the same dimensions.
I suggest larger than 300x300 but smaller than your primary monitor since this demo does not attempt to scale them. The Form will be resized to fit these images. To best see the effect the two images should be quite different.
Then just run it. Front will be "wiped" over Back, then they will be swapped and the process repeats.
↧
↧
Here's how to execute any arbitrary x86 machine code from a VB6 program.
Just paste this code in Form1, and make sure Auto Redraw is enabled for the form. I've commented this code so you can see how it works at a glance.
When you run it, this is what you should see if it's working correctly.
Attachment 182347
The hexadecimal code in this program, I got by doing the following. I first used YASM to assemble this assembly code (but NASM would have worked as well).
I then used HxD hex editor to get the hexadecimal representations of the machine code bytes. This allowed me to embed the x86 machine code as a hexadecimal string directly inside my VB6 program's source code. This eliminates the need for my program to load a function from a separate file to execute it (whether a DLL or a raw file with with nothing but the raw machine code). It also eliminates the need to place a dummy function in the source code and then hack the exe in a hex editor after it's compiled to add the intended code into the compiled executable at the location where the dummy function was.
This allows adding functionality into a VB6 program that VB6 can't do directly (like the x86 SHR instruction which is a right shift that ignores the sign of the value, as if it was an unsigned value, even though VB6 considers it to be a signed value), without requiring external files, something I didn't think VB6 could previously do, because it doesn't support static linking of LIB and OBJ files exported from C or ASM compilers. Even if you intercept VB6's call to the linker link.exe and tell it to link a LIB or OBJ file, there's no way to write a program that makes use of such statically linked code, because the VB6 IDE gives an error if you try compile a program that calls a function that is not available at design-time (such as a function in the VB6 code itself or a DLL function that's declared). The technique I showed in this post provides a workaround for that, in effect giving you a way (albeit a complicated way) of statically linking a function into your program, by using hexadecimal encoded x86 instructions, instead of a LIB or OBJ file.
Obviously there's limits to this, as such code has no way to look at the import table of your EXE and call a Windows API function, so this x86 machine code cannot make any calls to functions in a DLL file. However, it does give you access to a host of useful functions found at the low level of assembly code, that you can't get in VB6 (unsigned bit shifts, unsigned 2-byte and 4-byte integer arithmetic, bit rotations, 2-argument version of atan, etc).
Code:
'Repurpose the CallWindowProcA function to call a generic function with the same prototype (4 Long args, and a Long retval).
Private Declare Function CallFunc Lib "user32.dll" Alias "CallWindowProcA" (ByVal FuncPtr As Long, ByVal Arg1 As Long, ByVal Arg2 As Long, ByVal Arg3 As Long, ByVal Arg4 As Long) As Long
Dim CodeSHR As String
Private Sub Form_Load()
Dim HexSHR As String
Dim n As Long
Dim val As Long
'Hexadecimal representation of raw x86 machine code for a function that performs SHR. This is a logical (not arithmetic) shift.
HexSHR = "8B4424048A4C2408D3E8C21000"
'Convert the hex string to raw bytes of executable code.
For n = 1 To Len(HexSHR) - 1 Step 2
CodeSHR = CodeSHR & ChrB("&h" & Mid(HexSHR, n, 2))
Next n
'Perform a test where it performs 32 different shifts (no shift, up to 31 bits shifted) on the hex value &hFFFFFFFF.
For n = 0 To 31
Print Hex$(SHR(&HFFFFFFFF, n))
Next n
End Sub
'This function calls the CallFunc function (which is actually just CallWindowProcA renamed), which calls the function stored in the CodeSHR byte string.
Private Function SHR(ByVal Value As Long, ByVal ShiftAmount As Byte) As Long
SHR = CallFunc(StrPtr(CodeSHR), Value, ShiftAmount, 0, 0)
End FunctionAttachment 182347
The hexadecimal code in this program, I got by doing the following. I first used YASM to assemble this assembly code (but NASM would have worked as well).
Code:
BITS 32
mov eax,[esp+4]
mov cl,[esp+8]
shr eax,cl
ret 16This allows adding functionality into a VB6 program that VB6 can't do directly (like the x86 SHR instruction which is a right shift that ignores the sign of the value, as if it was an unsigned value, even though VB6 considers it to be a signed value), without requiring external files, something I didn't think VB6 could previously do, because it doesn't support static linking of LIB and OBJ files exported from C or ASM compilers. Even if you intercept VB6's call to the linker link.exe and tell it to link a LIB or OBJ file, there's no way to write a program that makes use of such statically linked code, because the VB6 IDE gives an error if you try compile a program that calls a function that is not available at design-time (such as a function in the VB6 code itself or a DLL function that's declared). The technique I showed in this post provides a workaround for that, in effect giving you a way (albeit a complicated way) of statically linking a function into your program, by using hexadecimal encoded x86 instructions, instead of a LIB or OBJ file.
Obviously there's limits to this, as such code has no way to look at the import table of your EXE and call a Windows API function, so this x86 machine code cannot make any calls to functions in a DLL file. However, it does give you access to a host of useful functions found at the low level of assembly code, that you can't get in VB6 (unsigned bit shifts, unsigned 2-byte and 4-byte integer arithmetic, bit rotations, 2-argument version of atan, etc).
↧
Simple Image Manipulation App (Flip, Rotate, Crop)
This is a simple image manipulation app with the following features:
Examples:
![Name: flip.jpg
Views: 86
Size: 29.2 KB]()
![Name: crop.jpg
Views: 85
Size: 28.6 KB]()
I wanted to learn more about Cairo graphics in RC6 by putting together a fully functional (albeit small) application. I haven't used RC6 Widgets for this project though, just vanilla VB6 forms & controls.
KNOWN BUGS:
Saving a cropped & rotated image will likely crop at the wrong location. Still trying to figure out why, and wouldn't mind some help with this part :) It might be nice if CCairoSurface had a Crop(X1, Y1, X2, Y2) method that would return a new CCairoSurface cropped out of the full-sized surface.
OTHER NOTES:
I'm not convinced I've gone about the Cairo stuff optimally - if Olaf or any other Cairo-knowledgable folks would be kind enough to review the code and make suggestions, it would be much appreciated.
Source Code (Requires RC6):
RC6CairoImageEditor.zip
Hope you enjoy the demo, and maybe even learn something from it.
- Load an image (Press L)
- Horizontal flipping (Press H)
- Vertical flipping (Press V)
- Rotation by pressing R (90 degree clockwise rotation) or SHIFT+R (90 degree counter-clockwise rotation)
- Cropping (click & drag mouse to define a crop rectangle)
- File navigation (press SPACE to load the next image in the active folder, press BACKSPACE to load the previous image in the folder).
- Save modified image (Press S)
Examples:
I wanted to learn more about Cairo graphics in RC6 by putting together a fully functional (albeit small) application. I haven't used RC6 Widgets for this project though, just vanilla VB6 forms & controls.
KNOWN BUGS:
Saving a cropped & rotated image will likely crop at the wrong location. Still trying to figure out why, and wouldn't mind some help with this part :) It might be nice if CCairoSurface had a Crop(X1, Y1, X2, Y2) method that would return a new CCairoSurface cropped out of the full-sized surface.
OTHER NOTES:
I'm not convinced I've gone about the Cairo stuff optimally - if Olaf or any other Cairo-knowledgable folks would be kind enough to review the code and make suggestions, it would be much appreciated.
Source Code (Requires RC6):
RC6CairoImageEditor.zip
Hope you enjoy the demo, and maybe even learn something from it.
↧
Executing assembly language functions in VB6 using DispCallFunc.
Yes, I know this has been done to death on these forums but one more couldn't hurt. :bigyello:
This is yet another sample showing how to call function pointers in VB6. In this sample I wrote 3 functions in assembly language, assembled them to x86 machine code and directly execute them from normal byte arrays. This method uses the DispCallFunc API to call them through function pointers.
The 3 assembly demo functions are as follows: One that adds two Longs and returns the result. One that takes an array of Longs, sums them and returns the result. The last one is a sub string function that works like Mid$. These functions were written by me purely for demonstration purposes. I'm far from being an assembly language expert so don't expect them to be top notch, super performant examples of good assembly code.
All the assembly functions observe the standard calling convention.
Additional Credits
The author of this article for showing me how to use DispCallFunc correctly.
The trick
For suggesting the DispCallFunc API which I didn't know about.
Olaf Schmidt
For providing information about a bug I encountered with Variants and the VT_BYREF flag.
Additional Links
The thread where this began. The OP in this thread also demonstrates a method of calling function pointers using CallWindowProc.
A more detailed and robust version of the DispCallFunc method by Olaf Schmidt. His version can also make cdecl calls.
Some additional information on this topic by Olaf Schmidt.
This is yet another sample showing how to call function pointers in VB6. In this sample I wrote 3 functions in assembly language, assembled them to x86 machine code and directly execute them from normal byte arrays. This method uses the DispCallFunc API to call them through function pointers.
The 3 assembly demo functions are as follows: One that adds two Longs and returns the result. One that takes an array of Longs, sums them and returns the result. The last one is a sub string function that works like Mid$. These functions were written by me purely for demonstration purposes. I'm far from being an assembly language expert so don't expect them to be top notch, super performant examples of good assembly code.
All the assembly functions observe the standard calling convention.
Additional Credits
The author of this article for showing me how to use DispCallFunc correctly.
The trick
For suggesting the DispCallFunc API which I didn't know about.
Olaf Schmidt
For providing information about a bug I encountered with Variants and the VT_BYREF flag.
Additional Links
The thread where this began. The OP in this thread also demonstrates a method of calling function pointers using CallWindowProc.
A more detailed and robust version of the DispCallFunc method by Olaf Schmidt. His version can also make cdecl calls.
Some additional information on this topic by Olaf Schmidt.
↧
↧
How to statically link a LIB or OBJ file in VB6!
There is a kinda hacky way to do this actually! I realized that there's no way to statically link the code so that it can be called like a normal function, as VB6 IDE won't even try to compile something if the function is not specifically defined in the code (unlike C or C++ where it the compilation goes fine, and then the linker needs to figure out if that function exists in any external OBJ, LIB, or DLL files referenced in the linker's command line). In VB6 the IDE will immediately give an error in this situation when you click the "Make Project1.exe" menu item in the File menu. But there is a way to call DLL functions using Declare statements. I know that when using a declare statement, compilation will work fine, and then you will get a runtime error if the DLL isn't found when you try to run the program.
So I figured that since this delays the point at which the function needs to be available, maybe I could actually export the function from the EXE, as if it were a DLL (as both are PE files, so theoretically EXEs support an export table, just like DLLs), and then import it back in the same EXE for executing it (though technically it's not importing it the standard way via an import table, as it actually is creating pieces of code that call LoadLibrary and GetProcAddress internally followed by jumping to the address it gets from GetProcAddress, so even the linker doesn't need to process this, as it won't be creating an import table).
It turns out, that worked! For testing it, I used the same ASM function I used in https://www.vbforums.com/showthread....-a-VB6-program but this time tweaked the ASM code slightly so the resulting object file would contain the info needed to get the linker to first link the OBJ into the EXE, and then export the function from the EXE. Normally the linker needs an /EXPORT command line argument to export a function, but an object file can also contain an export directive so that the linker will automatically export the desired function. This latter technique is the one I used. That way, I only needed to add one thing to the VB6 linker command line, not 2 things, to get it to work. No need for the /EXPORT command line argument, just the path to the OBJ file that was generated from the NASM assembler.
Note that for this trick to work, you need to rename the VB6 linker to something else, and then create your own program called link.exe that lets you edit the command line before calling the actual linker (under its new name). This way when you click "Make Project1.exe" it actually calls your proxy first, which gives you control of the linker command line, before passing that now-edited command line to the actual linker.
Here's the code for my VB6 program.
Here's the ASM code I used.
The BITS 32 statement sets it to 32bit mode (NASM outputs 16bit code by default).
The GLOBAL SHR statement tells NASM to set a bit associated with the function SHR in the OBJ file, that tells any linker reading the OBJ file that the function can be used by other functions outside of that specific OBJ file (it's kinda like the Public keyword in VB6). The EXPORT SHR statement adds the function SHR to an export table in the OBJ file. Both the GLOBAL and EXPORT statements are needed to generate an OBJ file that when read by the VB6 linker the function will actually be added to the EXE file's export table. Same trick should work with a static LIB file, which is just a file that contains one or more OBJ files.
When all of this is done correctly, the function's machine code actually is added to the EXE file's code section directly (not contained in a hexadecimal string), that can then be executed in the same way that VB6 executes DLL functions, but since the code is in the EXE file itself, it doesn't require the presence of an external file like with an actual DLL file. This eliminates the need for using CallWindowProc or other function-calling functions, and also eliminates the need to have a dedicated function to convert hexadecimal string to raw bytes, and also eliminates the need to have a bunch of extra strings or byte array to hold the converted bytes. The code for the function instead is linked directly into the EXE file, along side all the code of the main program.
Please note that because this technique requires external software (the NASM assembler, and a proxy linker for VB6 that intercepts the command line for the VB6 linker), the code I have here is NOT usable as-is (unlike most of the code in the codebank). You can't just copy it all straight into your VB6 IDE and run it for immediate results. You'll need to first get a copy of NASM and assemble the ASM code in this post into an OBJ file, as well as write your own proxy linker program.
Note that when using NASM.exe, its default output is raw machine code (aka a "flat binary" file), not any kind of object file. You'll need to use the command line args "-f win32" to make it generate a 32bit Windows COFF object file as its output. That's what the VB6 linker expects for its input.
Yes, I tested everything in I wrote in this post, and it does work.
So I figured that since this delays the point at which the function needs to be available, maybe I could actually export the function from the EXE, as if it were a DLL (as both are PE files, so theoretically EXEs support an export table, just like DLLs), and then import it back in the same EXE for executing it (though technically it's not importing it the standard way via an import table, as it actually is creating pieces of code that call LoadLibrary and GetProcAddress internally followed by jumping to the address it gets from GetProcAddress, so even the linker doesn't need to process this, as it won't be creating an import table).
It turns out, that worked! For testing it, I used the same ASM function I used in https://www.vbforums.com/showthread....-a-VB6-program but this time tweaked the ASM code slightly so the resulting object file would contain the info needed to get the linker to first link the OBJ into the EXE, and then export the function from the EXE. Normally the linker needs an /EXPORT command line argument to export a function, but an object file can also contain an export directive so that the linker will automatically export the desired function. This latter technique is the one I used. That way, I only needed to add one thing to the VB6 linker command line, not 2 things, to get it to work. No need for the /EXPORT command line argument, just the path to the OBJ file that was generated from the NASM assembler.
Note that for this trick to work, you need to rename the VB6 linker to something else, and then create your own program called link.exe that lets you edit the command line before calling the actual linker (under its new name). This way when you click "Make Project1.exe" it actually calls your proxy first, which gives you control of the linker command line, before passing that now-edited command line to the actual linker.
Here's the code for my VB6 program.
Code:
'Import the function from the EXE file itself. This only works if the EXE exports it, which requires
'a proxy linker to replace the normal linker (with the normal linker renamed and called from the
'proxy), to give you access to the command line arguments. In this example you will need to make
'sure that it links shr.obj into the EXE file.
'Also the object file must have been made from some external source that supports the technique you
'wish to use. In this case, I used NASM to make a function called SHR which uses the x86 instruction
'shr. NASM assembled the assembly code into an object file, which (with a proxy linker to edit VB6's
'linker command line) will be linked into the EXE file, and since the assembly code stated that the
'function is exported, the resulting EXE file will export the function, and the below Declare will
'import it back into the same EXE. Not an ideal way to do static linking, but this trick is the only
'way to do it in VB6 using actual object files (should also work with LIBs that have multiple object
'files in them).
Private Declare Function SHR Lib "Project1.exe" (ByVal Value As Long, ByVal ShiftAmount As Byte) As Long
Private Sub Form_Load()
Dim n As Long
'Perform a test where it performs 32 different shifts (no shift, up to 31 bits shifted) on the hex value &hFFFFFFFF.
'Note that with the static linking technique, this will ONLY work in the compiled EXE file, not in
'the VB6 IDE, as static linking only occurs when generating the EXE file, not when running in the
'VB6 IDE.
For n = 0 To 31
Print Hex$(SHR(&HFFFFFFFF, n))
Next n
End SubCode:
BITS 32
GLOBAL SHR
EXPORT SHR
SECTION .text
SHR:
mov eax,[esp+4]
mov cl,[esp+8]
shr eax,cl
ret 8The GLOBAL SHR statement tells NASM to set a bit associated with the function SHR in the OBJ file, that tells any linker reading the OBJ file that the function can be used by other functions outside of that specific OBJ file (it's kinda like the Public keyword in VB6). The EXPORT SHR statement adds the function SHR to an export table in the OBJ file. Both the GLOBAL and EXPORT statements are needed to generate an OBJ file that when read by the VB6 linker the function will actually be added to the EXE file's export table. Same trick should work with a static LIB file, which is just a file that contains one or more OBJ files.
When all of this is done correctly, the function's machine code actually is added to the EXE file's code section directly (not contained in a hexadecimal string), that can then be executed in the same way that VB6 executes DLL functions, but since the code is in the EXE file itself, it doesn't require the presence of an external file like with an actual DLL file. This eliminates the need for using CallWindowProc or other function-calling functions, and also eliminates the need to have a dedicated function to convert hexadecimal string to raw bytes, and also eliminates the need to have a bunch of extra strings or byte array to hold the converted bytes. The code for the function instead is linked directly into the EXE file, along side all the code of the main program.
Please note that because this technique requires external software (the NASM assembler, and a proxy linker for VB6 that intercepts the command line for the VB6 linker), the code I have here is NOT usable as-is (unlike most of the code in the codebank). You can't just copy it all straight into your VB6 IDE and run it for immediate results. You'll need to first get a copy of NASM and assemble the ASM code in this post into an OBJ file, as well as write your own proxy linker program.
Note that when using NASM.exe, its default output is raw machine code (aka a "flat binary" file), not any kind of object file. You'll need to use the command line args "-f win32" to make it generate a 32bit Windows COFF object file as its output. That's what the VB6 linker expects for its input.
Yes, I tested everything in I wrote in this post, and it does work.
↧
Draw on StdPicture objects
I'm not sure why you might need this, but this example shows how you can draw onto a StdPicture (type of bitmap only). Works whether currently assigned to a control or freestanding, such as loaded via LoadPicture().
The demo uses GDI calls by using the IPicture interface's SelectPicture() method to open/close the picture for drawing operations.
This demo doesn't show it, but it can also be used to draw to the persistent bitmap (Image property) of a Form, UserControl, or PictureBox while AutoRedraw = False. However it does show drawing to an Image control's Picture property.
Once again: these can't be icons or metafiles, only bitmaps.
The demo uses GDI calls by using the IPicture interface's SelectPicture() method to open/close the picture for drawing operations.
This demo doesn't show it, but it can also be used to draw to the persistent bitmap (Image property) of a Form, UserControl, or PictureBox while AutoRedraw = False. However it does show drawing to an Image control's Picture property.
Once again: these can't be icons or metafiles, only bitmaps.
↧
ucGridPlus
A new UserControl or ocx (for those who want to compile it), as its name implies, is a Grid. Although there are already some Grids and very good by the way, in this case I tried to find a more modern side, I had never used this control so I went based on the different options that are on the web, both those of vb6 (LynxGrid, IGrid, VBFlexGrid) such as those for web use for example ComponentOne and DevExpress. This control took me a long time since there are many lines of code, as always I have not made any help file, but within the examples you will find some very functional examples in real time. Being a control with many options, surely many things have escaped me, which I will be able to add or correct if they let me know, something that I could not do in this grid was to implement the MergedCell functionality (combined cells), but the rest I think is almost everything.
One problem that I found late was that for aesthetic reasons I used another usercontrol "ucScrollBar" as I had already done in the ucList, but I had not noticed that if the project name is changed the ucScrollBar loses the reference and becomes a PictureBox To prevent this from happening, it is necessary to open the ucGridPlus with the notepad and change "Project1" to the name of the project in which it is going to be used, at the moment I did not find a better solution.
The control can load images in many forms and formats both ColImgListAddImage and HeaderImgListAddImage can load the image from array of bits, file, url, base64 url, hbitmap, hIcon and stream; The images can be treated as vectors where we can assign the color according to the forecolor of the cell or we can put common images, it also has a "radius" property to give a circular shape or with rounded tips.
In the first example you will find some graphs, Progress and ranking that are shown in each row, in those examples I used an external module to use a CustomDraw, this with the appropriate knowledge you can do infinite things. It is not part of the grid itself, in this way it is easier to do things according to each one's needs.
In the case of the controls, it is the same, they are not part of the grid, the ucGridPlus is a container, where we can put Combobox, Datepiker among others and with some properties of this we can place said controls on the cell simulating that they are part of she.
The grid has the possibility of adding events to the images and text of the cell, in this way some nice effects can be achieved as you will see in the examples.
It is necessary to have the "Segoe MDL2 Assets" font installed in windows 10, it is already by default, it was used for some icons.
For compiled version (OCX) use the UniTextBox user control to accept unicode characters in edit mode.
To close I want to clarify that this is at the moment something like a beta and until it is not used and errors are found I will not be able to detect them, I know that many things were left in the pipeline but for now I ran out of energy.
![Name: ucGridPlus11.jpg
Views: 45
Size: 38.2 KB]()
![Name: ucGridPlus3.jpg
Views: 45
Size: 49.4 KB]()
![Name: ucGridPlus0.jpg
Views: 44
Size: 42.4 KB]()
![Name: ucGridPlus5.jpg
Views: 44
Size: 34.1 KB]()
DOWNLOAD USERCONTROL AND EXAMPLES
ucGridPlus.zip
FOR DOWNLOAD COMPILE VERSION(OCX) AND MORE SCREENSHOTS
http://leandroascierto.com/blog/gridplus/
One problem that I found late was that for aesthetic reasons I used another usercontrol "ucScrollBar" as I had already done in the ucList, but I had not noticed that if the project name is changed the ucScrollBar loses the reference and becomes a PictureBox To prevent this from happening, it is necessary to open the ucGridPlus with the notepad and change "Project1" to the name of the project in which it is going to be used, at the moment I did not find a better solution.
The control can load images in many forms and formats both ColImgListAddImage and HeaderImgListAddImage can load the image from array of bits, file, url, base64 url, hbitmap, hIcon and stream; The images can be treated as vectors where we can assign the color according to the forecolor of the cell or we can put common images, it also has a "radius" property to give a circular shape or with rounded tips.
In the first example you will find some graphs, Progress and ranking that are shown in each row, in those examples I used an external module to use a CustomDraw, this with the appropriate knowledge you can do infinite things. It is not part of the grid itself, in this way it is easier to do things according to each one's needs.
In the case of the controls, it is the same, they are not part of the grid, the ucGridPlus is a container, where we can put Combobox, Datepiker among others and with some properties of this we can place said controls on the cell simulating that they are part of she.
The grid has the possibility of adding events to the images and text of the cell, in this way some nice effects can be achieved as you will see in the examples.
It is necessary to have the "Segoe MDL2 Assets" font installed in windows 10, it is already by default, it was used for some icons.
For compiled version (OCX) use the UniTextBox user control to accept unicode characters in edit mode.
To close I want to clarify that this is at the moment something like a beta and until it is not used and errors are found I will not be able to detect them, I know that many things were left in the pipeline but for now I ran out of energy.
DOWNLOAD USERCONTROL AND EXAMPLES
ucGridPlus.zip
FOR DOWNLOAD COMPILE VERSION(OCX) AND MORE SCREENSHOTS
http://leandroascierto.com/blog/gridplus/
↧
Interesting VB6Admin for database management
I found this interesting code on Github of a tool for managing database.
It is coded in VB6.
https://github.com/pyhoon/vbadmin-vb6
It is developed by a coder called: Poon Yip Hoon (Aeric)
It is coded in VB6.
https://github.com/pyhoon/vbadmin-vb6
It is developed by a coder called: Poon Yip Hoon (Aeric)
↧
↧
Get Audio Type: Get Image Type
Here are a couple of routines for finding the Audio and Image type. I don't claim they are exhaustive as they were written for my needs. I hope someone finds them useful.
Code:
Private Function GetAudioType(sFileName As String) As String
Dim FF As Integer, s As String
s = Space$(420)
FF = FreeFile
Open sFileName For Binary As FF
Get #FF, 1, s
Close FF
Select Case True
Case Mid$(s, 413, 4) = "alac": GetAudioType = "Alac" 'This must come before 'aac'
Case Left$(s, 4) = "ÿñP", InStr(17, s, "mp4"): GetAudioType = "aac"
Case Mid$(s, 9, 4) = "AIFF": GetAudioType = "Aiff"
Case Left$(s, 4) = "fLaC": GetAudioType = "Flac"
Case Left$(s, 3) = "MAC": GetAudioType = "Monkey"
Case Left$(s, 2) = "ÿû", Left$(s, 3) = "ID3": GetAudioType = "mp3"
Case Left$(s, 3) = "MPC": GetAudioType = "Musepack"
Case InStr(1, s, "OPUS", 1): GetAudioType = "Opus"
Case InStr(1, s, "VORBIS", 1): GetAudioType = "Vorbis"
Case Left$(s, 4) = "RIFF": GetAudioType = "Wav"
Case Left$(s, 4) = "wvpk": GetAudioType = "Wavpack"
Case Left$(s, 7) = "0&²ufÏ": GetAudioType = "Wma"
Case Else: GetAudioType = "Unknown"
End Select
End FunctionCode:
Private Function GetImageType(sFileName As String) As String
Dim FF As Integer, s As String
s = Space$(12)
FF = FreeFile
Open sFileName For Binary As FF
Get #FF, 1, s
Close FF
Select Case True
Case Left$(s, 4) = Chr$(0) & Chr$(0) & Chr$(1) & Chr$(0): GetImageType = "ICO"
Case Left$(s, 4) = "PNG": GetImageType = "PNG"
Case Left$(s, 4) = "ÿØÿà": GetImageType = "JPG"
Case Left$(s, 2) = "BM": GetImageType = "BMP"
Case Left$(s, 3) = "GIF": GetImageType = "GIF"
Case Left$(s, 3) = "II*": GetImageType = "TIFF"
Case Mid$(s, 9, 4) = "WEBP": GetImageType = "WEBP"
Case Mid$(s, 5, 8) = "ftypmif1", Mid$(s, 5, 8) = "ftypheic": GetImageType = "HEIF"
Case Else: GetImageType = "UNKNOWN"
End Select
End Function↧
clsFTP for vb6
Code:
Option Explicit
Dim bSuccess As Boolean
Dim sError As String
Dim WithEvents cFTP As clsFTP
Private Sub cFTP_FileTransferProgress(ByVal ForUpload As Boolean, lCurrentBytes As Long, lTotalBytes As Long)
Debug.Print IIf(ForUpload, "UPLOAD", "DownLoad") & ",NowSize:" & lCurrentBytes & " of (" & lTotalBytes; ")" & Format(lCurrentBytes / lTotalBytes, "0.0%")
End Sub
Private Sub Form_Load()
Set cFTP = New clsFTP
With cFTP
If .OpenConnection("ip","user","pass") Then ' ==> this line is hilited in RED
'Upload File:
'------------
bSuccess = .FTPUploadFile("d:\test1.xls", "FTP/test1_new.xls")
'Download File:
'--------------
bSuccess = .FTPDownloadFile("d:\test1_download.xls", "FTP/test1D.xls")
If bSuccess = False Then
sError = .SimpleLastErrorMessage
Else
sError = "Success"
End If
.CloseConnection
Else
.CloseConnection
sError = .SimpleLastErrorMessage
End If
End With
End SubCode:
Option Explicit
Const INTERNET_FLAG_PASSIVE = &H8000000 ' 被动模式
Const INTERNET_FLAG_PORT = &O0 ' 主动模式
' ------------------------------------------------------------------------------------------------------------------------------
' This class is based on the SimpleFTP VB example by Microsoft.
' It was extended by Michael Glaser to be class based and support buffer
' based uploads and downloads with a progress event.
'
' If you found this code useful and would like to support the author, please
' visit the eD.I.Y. Software website at http://www.ediy.co.nz to see if the
' products we have available would be useful to you or your customers.
'
' Please credit me if you use this code in your applications.
'
' If you have any questions or possible improvements to this code, email me: mike@ediy.co.nz
'
' For help on any of the class API functions, an excellent reference is available here:
' http://msdn.microsoft.com/library/default.asp?url=/workshop/networking/wininet/reference/win32_ref_entry.asp
' ------------------------------------------------------------------------------------------------------------------------------
Private Const MAX_PATH = 260
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const NO_ERROR = 0
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
Private Const FILE_ATTRIBUTE_OFFLINE = &H1000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const ERROR_NO_MORE_FILES = 18
Private Const INTERNET_AUTODIAL_FORCE_ONLINE = 1
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_INVALID_PORT_NUMBER = 0
Private Const INTERNET_SERVICE_FTP = 1
Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const FTP_TRANSFER_TYPE_BINARY = &H2
Public Enum eFTPTransferTypes
FTP_ASCII = FTP_TRANSFER_TYPE_ASCII
FTP_BINARY = FTP_TRANSFER_TYPE_BINARY
End Enum
Private Const rDayZeroBias As Double = 109205# ' Abs(CDbl(#01-01-1601#))
Private Const rMillisecondPerDay As Double = 10000000# * 60# * 60# * 24# / 10000#
Private Const BUFFERSIZE = 255
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As Currency
ftLastAccessTime As Currency
ftLastWriteTime As Currency
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
' -- private functions
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As Any, lpLocalFileTime As Any) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Private Declare Function FTPGetFile Lib "wininet.dll" Alias "FtpGetFileA" (ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias "FtpRenameFileA" (ByVal hFtpSession As Long, ByVal lpszOldName As String, ByVal lpszNewName As String) As Boolean
Private Declare Function FtpCreateDirectory Lib "wininet.dll" Alias "FtpCreateDirectoryA" (ByVal hFtpSession As Long, ByVal lpszName As String) As Boolean
Private Declare Function FtpRemoveDirectory Lib "wininet.dll" Alias "FtpRemoveDirectoryA" (ByVal hFtpSession As Long, ByVal lpszName As String) As Boolean
Private Declare Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, ByVal lpszFileName As String) As Boolean
Private Declare Function FtpOpenFile Lib "wininet.dll" Alias "FtpOpenFileA" (ByVal hFtpSession As Long, ByVal sBuff As String, ByVal Access As Long, ByVal Flags As Long, ByVal Context As Long) As Long
Private Declare Function FTPPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, ByVal lpszRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String, lpdwCurrentDirectory As Long) As Boolean
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpLibFileName As String) As Long
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Private Declare Function InternetWriteFile Lib "wininet.dll" (ByVal hFile As Long, ByRef sBuffer As Byte, ByVal lNumBytesToWrite As Long, dwNumberOfBytesWritten As Long) As Integer
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByRef sBuffer As Byte, ByVal lNumBytesToRead As Long, dwNumberOfBytesRead As Long) As Integer
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Long
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" (ByRef lpdwError As Long, ByVal lpszErrorBuffer As String, ByRef lpdwErrorBufferLength As Long) As Boolean
Private Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
' -- Private Variables
Private hOpen As Long
Private hConnection As Long
Private hFile As Long
Private dwType As Long
Private dwSeman As Long
Private szErrorMessage As String, szSimpleErrorMessage As String
'Private mDirCol As New cDirList
Public Event FileTransferProgress(ByVal ForUpload As Boolean, lCurrentBytes As Long, lTotalBytes As Long)
Dim ForUpload As Boolean
'Property Get Directory() As cDirList
' Set Directory = mDirCol
'End Property
Property Get LastErrorMessage() As String
LastErrorMessage = szErrorMessage
End Property
Property Get SimpleLastErrorMessage() As String
SimpleLastErrorMessage = szSimpleErrorMessage
End Property
Public Function OpenConnection(sServer As String, sUser As String, sPassword As String) As Boolean
If hConnection <> 0 Then
InternetCloseHandle hConnection
End If
If CBool(InternetAutodial(INTERNET_AUTODIAL_FORCE_ONLINE, 0)) Then
hOpen = InternetOpen("eDIY FTP Client", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
If hOpen = 0 Then
ErrorOut Err.LastDllError, "InternetOpen"
End If
'InternetSetStatusCallback hOpen, AddressOf FTPCallBack
hConnection = InternetConnect(hOpen, sServer, INTERNET_INVALID_PORT_NUMBER, sUser, sPassword, INTERNET_SERVICE_FTP, dwSeman, 0)
If hConnection = 0 Then
ErrorOut Err.LastDllError, "InternetConnect"
OpenConnection = False
Exit Function
Else
'InternetSetStatusCallback hConnection, AddressOf FTPCallBack
OpenConnection = True
End If
Else
OpenConnection = False
End If
End Function
Public Sub CloseConnection()
If hConnection Then
InternetCloseHandle hConnection
End If
hConnection = 0
If hOpen Then
InternetCloseHandle hOpen
End If
hOpen = 0
End Sub
Public Function SimpleFTPPutFile(sLocal As String, sRemote As String) As Boolean
If (FTPPutFile(hConnection, sLocal, sRemote, dwType, 0) = False) Then
ErrorOut Err.LastDllError, "SimpleFtpPutFile"
SimpleFTPPutFile = False
Exit Function
Else
SimpleFTPPutFile = True
End If
End Function
Public Function RenameFTPFile(sExisting As String, sNewName As String) As Boolean
If (FtpRenameFile(hConnection, sExisting, sNewName) = False) Then
ErrorOut Err.LastDllError, "RenameFTPFile"
RenameFTPFile = False
Exit Function
Else
RenameFTPFile = True
End If
End Function
Public Function CreateFTPDirectory(sDirectory As String) As Boolean
If (FtpCreateDirectory(hConnection, sDirectory) = False) Then
ErrorOut Err.LastDllError, "CreateFTPDirectory"
CreateFTPDirectory = False
Exit Function
Else
CreateFTPDirectory = True
End If
End Function
Public Function RemoveFTPDirectory(sDirectory As String) As Boolean
If (FtpRemoveDirectory(hConnection, sDirectory) = False) Then
ErrorOut Err.LastDllError, "RemoveFTPDirectory"
RemoveFTPDirectory = False
Exit Function
Else
RemoveFTPDirectory = True
End If
End Function
Public Function DeleteFTPFile(sRemote As String) As Boolean
If (FtpDeleteFile(hConnection, sRemote) = False) Then
ErrorOut Err.LastDllError, "DeleteFTPFile"
DeleteFTPFile = False
Exit Function
Else
DeleteFTPFile = True
End If
End Function
Public Function FTPUploadFile(sLocal As String, sRemote As String) As Boolean
ForUpload = True
Dim Data(BUFFERSIZE - 1) As Byte
Dim Written As Long
Dim Size As Long
Dim Sum As Long
Dim lBlock As Long
Dim f As Integer
Sum = 0
lBlock = 0
sLocal = Trim$(sLocal)
sRemote = Trim$(sRemote)
f = FreeFile()
On Error GoTo EH
If CBool(LenB(sLocal)) And CBool(LenB(sRemote)) Then
hFile = FtpOpenFile(hConnection, sRemote, GENERIC_WRITE, dwType, 0)
If hFile = 0 Then
ErrorOut Err.LastDllError, "FtpOpenFile:PutFile"
FTPUploadFile = False
Exit Function
End If
Open sLocal For Binary Access Read As #f
Size = LOF(1)
For lBlock = 1 To Size \ BUFFERSIZE
Get #f, , Data
If (InternetWriteFile(hFile, Data(0), BUFFERSIZE, Written) = 0) Then
ErrorOut Err.LastDllError, "InternetWriteFile"
GoTo EH
End If
DoEvents
Sum = Sum + BUFFERSIZE
RaiseEvent FileTransferProgress(ForUpload, Sum, Size)
Next lBlock
'check for leftovers
If Size Mod BUFFERSIZE <> 0 Then
Get #f, , Data
If (InternetWriteFile(hFile, Data(0), Size Mod BUFFERSIZE, Written) = 0) Then
ErrorOut Err.LastDllError, "InternetWriteFile2"
GoTo EH
End If
End If
Sum = Size
Close #f
RaiseEvent FileTransferProgress(ForUpload, Sum, Size)
InternetCloseHandle hFile
FTPUploadFile = True
End If
Exit Function
EH:
FTPUploadFile = False
Close #f
End Function
Public Function FTPDownloadFile(sLocal As String, sRemote As String) As Boolean
ForUpload = False
Dim Data(BUFFERSIZE - 1) As Byte ' array of 100 elements 0 to 99
Dim Written As Long
Dim Size As Long
Dim Sum As Long
Dim lBlock As Long
Dim f As Integer
FTPDownloadFile = False
Sum = 0
lBlock = 0
f = FreeFile()
sLocal = Trim$(sLocal)
sRemote = Trim$(sRemote)
If CBool(LenB(sLocal)) And CBool(LenB(sRemote)) Then
Size = GetFTPFileSize(sRemote)
If Size > 0 Then
hFile = FtpOpenFile(hConnection, sRemote, GENERIC_READ, dwType, 0)
If hFile = 0 Then
ErrorOut Err.LastDllError, "FtpOpenFile:GetFile"
Exit Function
End If
Open sLocal For Binary Access Write As #f
Seek #f, 1
Sum = 1
For lBlock = 1 To Size \ BUFFERSIZE
If (InternetReadFile(hFile, Data(0), BUFFERSIZE, Written) = 0) Then
ErrorOut Err.LastDllError, "InternetReadFile"
GoTo EH
End If
Put #f, , Data
DoEvents
Sum = Sum + BUFFERSIZE
RaiseEvent FileTransferProgress(ForUpload, Sum, Size)
Next lBlock
'Check for leftovers
If Size Mod BUFFERSIZE <> 0 Then
ReDim Data2((Size Mod BUFFERSIZE) - 1) As Byte
If (InternetReadFile(hFile, Data2(0), Size Mod BUFFERSIZE, Written) = 0) Then
ErrorOut Err.LastDllError, "InternetReadFile2"
GoTo EH
End If
End If
Put #f, , Data2
Close #f
Sum = Size
RaiseEvent FileTransferProgress(ForUpload, Sum, Size)
InternetCloseHandle hFile
FTPDownloadFile = True
Else
ErrorOut -1, "FTPDownloadFile", "FTP File Doesn't Exist"
End If
End If
Exit Function
EH:
Close #f
End Function
Public Function SimpleFTPGetFile(sLocal As String, sRemote As String) As Boolean
' add INTERNET_FLAG_NO_CACHE_WRITE to avoid local caching 0x04000000 (hex)
If (FTPGetFile(hConnection, sRemote, sLocal, False, FILE_ATTRIBUTE_NORMAL, dwType Or INTERNET_FLAG_RELOAD, 0) = False) Then
ErrorOut Err.LastDllError, "SimpleFtpGetFile"
SimpleFTPGetFile = False
Exit Function
Else
SimpleFTPGetFile = True
End If
End Function
Public Property Get FTPDirectory() As String
Dim szDir As String
szDir = String(1024, Chr$(0))
If (FtpGetCurrentDirectory(hConnection, szDir, 1024) = False) Then
ErrorOut Err.LastDllError, "FtpGetCurrentDirectory"
Exit Property
Else
FTPDirectory = Left(szDir, InStr(1, szDir, String(1, 0), vbBinaryCompare) - 1)
End If
End Property
Public Property Let FTPDirectory(sDir As String)
If (FtpSetCurrentDirectory(hConnection, sDir) = False) Then
ErrorOut Err.LastDllError, "FtpSetCurrentDirectory"
End If
End Property
Public Function GetFTPFileSize(sFile As String) As Long
Dim szDir As String
Dim hFind As Long
Dim nLastError As Long
Dim pData As WIN32_FIND_DATA
hFind = FtpFindFirstFile(hConnection, Replace(sFile, " ", "?"), pData, 0, 0)
nLastError = Err.LastDllError
If hFind = 0 Then
If (nLastError = ERROR_NO_MORE_FILES) Then
GetFTPFileSize = -1 ' File not found
Else
GetFTPFileSize = -2 ' Other error
ErrorOut Err.LastDllError, "FtpFindFirstFile"
End If
Exit Function
End If
GetFTPFileSize = pData.nFileSizeLow
InternetCloseHandle hFind
End Function
'Public Function GetDirectoryListing(sFilter As String) As cDirList
' Dim szDir As String
' Dim hFind As Long
' Dim nLastError As Long
' Dim dError As Long
' Dim ptr As Long
' Dim pData As WIN32_FIND_DATA
' Dim sFilename As String
'
' Set mDirCol = Nothing
' hFind = FtpFindFirstFile(hConnection, sFilter, pData, 0, 0)
' nLastError = Err.LastDllError
' If hFind = 0 Then
' If (nLastError <> ERROR_NO_MORE_FILES) Then
' ErrorOut Err.LastDllError, "FtpFindFirstFile"
' End If
' Exit Function
' End If
'
' dError = NO_ERROR
' Dim bRet As Boolean
'
' sFilename = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
' mDirCol.Add pData.dwFileAttributes, Win32ToVbTime(pData.ftCreationTime), Win32ToVbTime(pData.ftLastAccessTime), Win32ToVbTime(pData.ftLastWriteTime), pData.nFileSizeLow, sFilename
' Do
' pData.cFileName = String(MAX_PATH, 0)
' bRet = InternetFindNextFile(hFind, pData)
' If Not bRet Then
' dError = Err.LastDllError
' If dError = ERROR_NO_MORE_FILES Then
' Exit Do
' Else
' ErrorOut Err.LastDllError, "InternetFindNextFile"
' InternetCloseHandle (hFind)
' Exit Function
' End If
' Else
' sFilename = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
' mDirCol.Add pData.dwFileAttributes, Win32ToVbTime(pData.ftCreationTime), Win32ToVbTime(pData.ftLastAccessTime), Win32ToVbTime(pData.ftLastWriteTime), pData.nFileSizeLow, sFilename
' End If
' Loop
'
' Set GetDirectoryListing = mDirCol
' InternetCloseHandle (hFind)
'End Function
Public Sub SetTransferType(ByVal vType As eFTPTransferTypes)
dwType = vType
End Sub
Public Sub SetMode(ByVal bActive As Boolean)
If bActive Then
dwSeman = 0
' INTERNET_FLAG_PORT = &O0 ' 主动模式
'MsgBox &O0
Else
dwSeman = INTERNET_FLAG_PASSIVE
End If
End Sub
' -- Private Functions
Private Sub ErrorOut(ByVal dwError As Long, ByVal szFunc As String, _
Optional ByVal sCustError As String)
Dim dwRet As Long
Dim dwTemp As Long
Dim szString As String * 2048
Dim i As Integer
If dwError <> -1 Then
dwRet = FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, _
GetModuleHandle("wininet.dll"), dwError, 0, _
szString, 256, 0)
Else
szString = sCustError
End If
i = InStr(1, szString, vbNullChar)
If i Then
szString = Left$(szString, i - 1)
End If
i = InStr(1, szString, vbNewLine)
If i Then
szString = Replace$(szString, vbNewLine, vbNullString)
End If
szErrorMessage = szFunc & "() Error - Code: " & dwError & " Message: " & Trim$(szString)
szSimpleErrorMessage = Trim$(szString)
If dwError = 12003 Then
'Extended error information was returned
dwRet = InternetGetLastResponseInfo(dwTemp, szString, 2048)
szErrorMessage = szString
End If
End Sub
'Private Function Win32ToVbTime(ft As Currency) As Date
'Dim ftl As Currency
'' Call API to convert from UTC time to local time
'If FileTimeToLocalFileTime(ft, ftl) Then
' ' Local time is nanoseconds since 01-01-1601
' ' In Currency that comes out as milliseconds
' ' Divide by milliseconds per day to get days since 1601
' ' Subtract days from 1601 to 1899 to get VB Date equivalent
' Win32ToVbTime = CDate((ftl / rMillisecondPerDay) - rDayZeroBias)
'Else
' MsgBox Err.LastDllError
'End If
'End Function
Private Sub Class_Initialize()
SetTransferType FTP_ASCII 'FTP_BINARY
SetMode True
hOpen = 0
hConnection = 0
End Sub
Private Sub Class_Terminate()
CloseConnection
End Sub
' -- If anyone can get the wininet.dll to call the FTPCallback function for
' -- status updates (in a public module), please email mike@ediy.co.nz.
'Public Declare Function InternetSetStatusCallback Lib "wininet.dll" (ByVal hInternetSession As Long, ByVal lpfnCallBack As Long) As Long
'
'Public Function FTPCallBack(ByVal hInternet As Long, ByVal dwContext As Long, ByVal dwInternetStatus As Long, ByVal lpvStatusInformation As Long, ByVal dwStatusInformationLength As Long) As Long
' Debug.Print "Status: " & dwInternetStatus
'End Function
'
'Public Const INTERNET_STATUS_RESOLVING_NAME = 10
'Public Const INTERNET_STATUS_NAME_RESOLVED = 11
'Public Const INTERNET_STATUS_CONNECTING_TO_SERVER = 20
'Public Const INTERNET_STATUS_CONNECTED_TO_SERVER = 21
'Public Const INTERNET_STATUS_SENDING_REQUEST = 30
'Public Const INTERNET_STATUS_REQUEST_SENT = 31
'Public Const INTERNET_STATUS_RECEIVING_RESPONSE = 40
'Public Const INTERNET_STATUS_RESPONSE_RECEIVED = 41
'Public Const INTERNET_STATUS_CTL_RESPONSE_RECEIVED = 42
'Public Const INTERNET_STATUS_PREFETCH = 43
'Public Const INTERNET_STATUS_CLOSING_CONNECTION = 50
'Public Const INTERNET_STATUS_CONNECTION_CLOSED = 51
'Public Const INTERNET_STATUS_HANDLE_CREATED = 60
'Public Const INTERNET_STATUS_HANDLE_CLOSING = 70
'Public Const INTERNET_STATUS_REQUEST_COMPLETE = 100
'Public Const INTERNET_STATUS_REDIRECT = 110
'Public Const INTERNET_STATUS_INTERMEDIATE_RESPONSE = 120
'Public Const INTERNET_STATUS_STATE_CHANGE = 200https://forums.devx.com/showthread.p...n-Visual-basic
and I optimized the transfer progress function
↧
Managing Firewall Rules via INetFwPolicy2
Below provided several examples how to work with INetFwPolicy2 interface to setup Windows Firewall for your application.
You'll have to connect type library via Project - References - NetFW.TLB
You'll have to connect type library via Project - References - NetFW.TLB
Code:
Option Explicit
Private Sub Form_Load()
'Adding program to list of allowed applications (inbound & outbound)
Firewall_AddAllowedProgram "app", "c:\path\app.exe"
'Checking if program is allowed
Debug.Print Firewall_IsAllowedProgram("c:\path\app.exe")
'Disabling firewall rule by program path
Firewall_DisableProgram "c:\path\app.exe"
'Removing firewall rule by name
Firewall_RemoveRuleName "app"
End Sub
Public Function Firewall_AddAllowedProgram(RuleName As String, ProgramPath As String) As Boolean
On Error GoTo ErrH
Dim pFwNetFwPolicy2 As New NetFwPolicy2
Dim pFwRules As INetFwRules
Dim pFwRule As NetFwRule
Set pFwRules = pFwNetFwPolicy2.Rules
Firewall_RemoveRuleName RuleName
Firewall_DisableProgram ProgramPath
Set pFwRule = New NetFwRule
With pFwRule
.Action = NET_FW_ACTION_ALLOW
.ApplicationName = ProgramPath
.Direction = NET_FW_RULE_DIR_OUT
.Enabled = True
.InterfaceTypes = "All"
.LocalAddresses = "*"
.Name = RuleName
.Profiles = NET_FW_PROFILE2_ALL
.Protocol = NET_FW_IP_PROTOCOL_ANY
.RemoteAddresses = "*"
End With
pFwRules.Add pFwRule
Set pFwRule = New NetFwRule
With pFwRule
.Action = NET_FW_ACTION_ALLOW
.ApplicationName = ProgramPath
.Direction = NET_FW_RULE_DIR_IN
.Enabled = True
.InterfaceTypes = "All"
.LocalAddresses = "*"
.Name = RuleName
.Profiles = NET_FW_PROFILE2_ALL
.Protocol = NET_FW_IP_PROTOCOL_ANY
.RemoteAddresses = "*"
End With
pFwRules.Add pFwRule
Set pFwNetFwPolicy2 = Nothing
Firewall_AddAllowedProgram = True
Exit Function
ErrH:
Debug.Print "ERROR: in " & "Firewall_AddAllowedProgram" & ". Err # " & Err.Number & " (" & Err.LastDllError & ") - " & Err.Description
End Function
Public Function Firewall_RemoveRuleName(RuleName As String) As Boolean
On Error GoTo ErrH
Dim pFwNetFwPolicy2 As New NetFwPolicy2
Dim pFwRules As INetFwRules
Set pFwRules = pFwNetFwPolicy2.Rules
pFwRules.Remove RuleName
pFwRules.Remove RuleName
Set pFwNetFwPolicy2 = Nothing
Firewall_RemoveRuleName = True
Exit Function
ErrH:
Debug.Print "ERROR: in " & "Firewall_RemoveRuleName" & ". Err # " & Err.Number & " (" & Err.LastDllError & ") - " & Err.Description
End Function
Public Function Firewall_DisableProgram(sPath As String) As Boolean
On Error GoTo ErrH
Dim pFwNetFwPolicy2 As New NetFwPolicy2
Dim pFwRules As INetFwRules
Dim pFwRule As NetFwRule
Set pFwRules = pFwNetFwPolicy2.Rules
For Each pFwRule In pFwRules
With pFwRule
If StrComp(.ApplicationName, sPath, 1) = 0 Then
.Enabled = False
End If
End With
Next
Set pFwNetFwPolicy2 = Nothing
Firewall_DisableProgram = True
Exit Function
ErrH:
Debug.Print "ERROR: in " & "Firewall_DisableProgram" & ". Err # " & Err.Number & " (" & Err.LastDllError & ") - " & Err.Description
End Function
Public Function Firewall_IsAllowedProgram(sPath As String) As Boolean
On Error GoTo ErrH
Dim pFwNetFwPolicy2 As New NetFwPolicy2
Dim pFwRules As INetFwRules
Dim pFwRule As NetFwRule
Set pFwRules = pFwNetFwPolicy2.Rules
For Each pFwRule In pFwRules
With pFwRule
If StrComp(.ApplicationName, sPath, 1) = 0 Then
If .Enabled And .Action = NET_FW_ACTION_ALLOW Then
Firewall_IsAllowedProgram = True
Exit For
End If
End If
End With
Next
Set pFwNetFwPolicy2 = Nothing
Exit Function
ErrH:
Debug.Print "ERROR: in " & "Firewall_IsAllowedProgram" & ". Err # " & Err.Number & " (" & Err.LastDllError & ") - " & Err.Description
End Function
↧
Calculator Simple usercontrol
I was just messing around with some old code and came up with this calculator control. Check it out and see how it works. I used the shape control and labels for the buttons.
↧
↧
GetProcessFileName by pid
Code:
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Const MAX_PATH As Integer = 260
'====================结构体声明===================
Private Type PROCESSENTRY32
dwsize As Long '结构大小
cntUsage As Long '自身引用记数
th32ProcessID As Long '此进程ID
th32DefaultHeapID As Long '进程默认堆ID
th32ModuleID As Long '进程模块ID。DLL是模块ID与进程ID相同
cntThreads As Long '开启的线程计数
th32ParentProcessID As Long '父进程ID
pcPriClassBase As Long '线程优先权
dwFlags As Long 'preserve
szExeFile As String * MAX_PATH 'full name
End Type
Public Declare Function Module32First Lib "kernel32" (ByVal hSnapshot As Long, lppe As MODULEENTRY32) As Long
Public Declare Function Module32Next Lib "kernel32" (ByVal hSnapshot As Long, lppe As MODULEENTRY32) As Long '
Public Const TH32CS_SNAPmodule As Long = &H8
Public Type MODULEENTRY32
dwsize As Long
th32ModuleID As Long
th32ProcessID As Long
GlblcntUsage As Long
ProccntUsage As Long
modBaseAddr As Byte
modBaseSize As Long
hModule As Long
szModule As String * 256
szExePath As String * 1024
End Type
Public Function GetProcessFileName(ByVal PID As Long) As String '小写
Dim hSnapshot As Long, Result As Long
Dim curProcName As String
Dim Process As PROCESSENTRY32
hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
If hSnapshot = 0 Then Exit Function
Process.dwsize = Len(Process)
Result = ProcessFirst(hSnapshot, Process)
Do While Result <> 0
If Process.th32ProcessID = PID Then
curProcName = Process.szExeFile
curProcName = Left$(curProcName, InStr(curProcName, Chr$(0)) - 1)
Exit Do
End If
Result = ProcessNext(hSnapshot, Process)
Loop
GetProcessFileName = LCase(curProcName)
Call CloseHandle(hSnapshot)
End Function↧
Pratt parsers and the building blocks of a scripting language.
This sample application is an implementation of a Pratt parser written in pure VB6 code. It demonstrates the use of the Parser to validate syntax and construct an expression tree from a text expression. Now I want to preface this by saying that if your intention is to simply evaluate expressions, then this is not what you would use. There are far simpler and faster methods for evaluating expressions. For example:-
Code:
Option Explicit
Public Function Eval(ByVal Expr As String)
Dim L As String, R As String
Do While HandleParentheses(Expr): Loop
If 0 Then
ElseIf Spl(Expr, "Or", L, R) Then: Eval = Eval(L) Or Eval(R)
ElseIf Spl(Expr, "And", L, R) Then: Eval = Eval(L) And Eval(R)
ElseIf Spl(Expr, ">=", L, R) Then: Eval = Eval(L) >= Eval(R)
ElseIf Spl(Expr, "<=", L, R) Then: Eval = Eval(L) <= Eval(R)
ElseIf Spl(Expr, "=", L, R) Then: Eval = Eval(L) = Eval(R)
ElseIf Spl(Expr, ">", L, R) Then: Eval = Eval(L) > Eval(R)
ElseIf Spl(Expr, "<", L, R) Then: Eval = Eval(L) < Eval(R)
ElseIf Spl(Expr, "Like", L, R) Then: Eval = Eval(L) Like Eval(R)
ElseIf Spl(Expr, "&", L, R) Then: Eval = Eval(L) & Eval(R)
ElseIf Spl(Expr, "-", L, R) Then: Eval = Eval(L) - Eval(R)
ElseIf Spl(Expr, "+", L, R) Then: Eval = Eval(L) + Eval(R)
ElseIf Spl(Expr, "Mod", L, R) Then: Eval = Eval(L) Mod Eval(R)
ElseIf Spl(Expr, "\", L, R) Then: Eval = Eval(L) \ Eval(R)
ElseIf Spl(Expr, "*", L, R) Then: Eval = Eval(L) * Eval(R)
ElseIf Spl(Expr, "/", L, R) Then: Eval = Eval(L) / Eval(R)
ElseIf Spl(Expr, "^", L, R) Then: Eval = Eval(L) ^ Eval(R)
ElseIf Trim(Expr) >= "A" Then: Eval = Fnc(Expr)
ElseIf Len(Expr) Then: Eval = IIf(InStr(Expr, "'"), _
Replace(Trim(Expr), "'", ""), Val(Expr))
End If
End Function
Private Function HandleParentheses(Expr As String) As Boolean
Dim P As Long, i As Long, C As Long
P = InStr(Expr, "(")
If P Then HandleParentheses = True Else Exit Function
For i = P To Len(Expr)
If Mid(Expr, i, 1) = "(" Then C = C + 1
If Mid(Expr, i, 1) = ")" Then C = C - 1
If C = 0 Then Exit For
Next i
Expr = Left(Expr, P - 1) & Str(Eval(Mid(Expr, P + 1, i - P - 1))) & Mid(Expr, i + 1)
End Function
Private Function Spl(Expr As String, Op$, L$, R$) As Boolean
Dim P As Long
P = InStrRev(Expr, Op, , 1)
If P Then Spl = True Else Exit Function
If P < InStrRev(Expr, "'") And InStr("*-", Op) Then P = InStrRev(Expr, "'", P) - 1
R = Mid(Expr, P + Len(Op))
L = Trim(Left$(Expr, IIf(P > 0, P - 1, 0)))
Select Case Right(L, 1)
Case "", "+", "*", "/", "A" To "z": Spl = False
Case "-": R = "-" & R
End Select
End Function
Private Function Fnc(Expr As String)
Expr = LCase(Trim(Expr))
Select Case Left(Expr, 3)
Case "abs": Fnc = Abs(Val(Mid$(Expr, 4)))
Case "sin": Fnc = Sin(Val(Mid$(Expr, 4)))
Case "cos": Fnc = Cos(Val(Mid$(Expr, 4)))
Case "atn": Fnc = Atn(Val(Mid$(Expr, 4)))
Case "log": Fnc = Log(Val(Mid$(Expr, 4)))
Case "exp": Fnc = Exp(Val(Mid$(Expr, 4)))
'etc...
End Select
End FunctionThis is not what Pratt parsers are about. You could use them to evaluate expressions but that is like killing a mosquito with a nuke.
So what is a Pratt parser?
A Pratt parser belongs to a family of left to right recursive parsing algorithms called shift reduce parsers. Olaf's algorithm is also a kind of shift reduce parser though I have no idea what his one is called. These parsers specialize in parsing expressions and programming language grammars by breaking down or reducing the input into a series of simpler elements. The Pratt parser in particular was invented by a man named Vaughan Pratt. It is particularly specialized in allowing programmers to very easily control operator precedence in whatever scripting or programming language they are creating. It is extremely easy to implement and the algorithm itself can be modeled quite easily to be modular to the point where you can design the parser once and just plug in classes to it to extend whatever language it is you're writing. This is what makes Pratt parsers so appealing.
The typical approach for writing a scripting language is to use parser generators because programming language grammars can be quite complicated and it can be very tricky to get them right if they are written by hand. However, there are algorithms suited to hand written parsers. The one most often recommended is recursive descent parsing which is very easy to write by hand. However, it is extremely difficult to control operator precedence with a recursive descent parser if you're writing it by hand. This is where you want a Pratt parser because like a recursive descent parser, it is also suitable for hand written parsers and what's more, you can combine it with a recursive descent parser to parse elements of a language that don't require taking operator precedence into account. For example, If...Then statements or While loops.
So what is this project about?
It started as a simple implementation of a Pratt parser capable of parsing simple expressions into expression trees. I got carried away and went a bit beyond that. The core of it is a Pratt parser that converts an expression into an expression tree which can then be evaluated to produce a result. There are two methods of evaluation, a simpler method which involves simply traversing the tree to calculate the result. The more complicated method involves traversing the tree to produce a series of instructions that when executed will produce the result. In other words, what I made is a very basic compiler.
The instructions are meant for a virtual machine not unlike VB6's own P-code engine or Java's bytecode virtual machine. In this case the virtual machine is one of my own invention. It is far simpler than a real world virtual machine and it is no where near as fast. It also has a far simpler instruction set with no support for jumping which means it cannot support looping or conditional branching. It is not meant to be a fully fledged and capable virtual machine to be used in real world scenarios. It is meant to demonstrate the some of the important principles behind virtual CPUs and should be taken as such.
This demo is capable of parsing highly complex expressions which includes being able to handle multiple variables, deeply nested function calls, and it can detect any and all syntax errors and report them. All of these abilities can be used as a very solid foundation for building a scripting language. All it would take to implement a scripting language is adding parslets to the core Pratt parser to parse assignment statements, If...Then statements, loops like For..Next or Do..While loops, Goto statement and whatever else there is. Conditional jump instructions would also need to be added to the virtual machine to support most of these. I intend to release a more sophisticated version with all of this but this would be done in VB.Net.
So what kind of input can this parser evaluate?
I will give a sample list of some of the more complicated expressions it can parse but before I do that I want to give a clear list of the functions implemented in this project. They are as follows:-
- Sin
- Cos
- Tan
- Sqr
- Round
- Abs
- Max
- Min
- Avg
- Random
Here are examples of use of the functions:-
Sin(0.7) : Sine of 0.7
Cos(0.7) : Cosine of 0.7
Tan(0.7) : Tangent of 0.7
Sqr(16) : Square root of 16
Round(3.4) : Will round to 3.0
Abs(-90) : Absolute value of -90 which is 90
Max(7,10,23,100) : Returns the largest value which is 100. This function can take 0 to unlimited arguments
Min(7,10,23,100) : Returns the smallest value which is 7. This function can take 0 to unlimited arguments.
Avg(7,10,23,100) : Returns the average of all the numbers. This function can take 0 to unlimited arguments.
Random(10,20) : Returns a random number between 10 and 20 inclusive of both 10 and 20.
Here are some examples of expressions that can be parsed:-
- sqr(Random(100,500))
- sqr(sqr(sqr(sqr(sqr(10000)))))
- min(10,89,max(9,2,3,12,sqr(round(22.5))),45)
- round(abs(-200+-544)/19)
It also supports implicit multiplication with variables or bracketed sub expressions. For example 2a+3a+3b or 3(90+2*3).
There are many more samples in the project itself. Also note that some of you might find a mismatch between what your calculator or the VB6 debug window produces and what my program produces for the result of certain expressions. The standard operators addition, subtraction, division and multiplication all the have precedence relationships you'd expect and using only those operators, you should get the same results regardless of where you calculated the result. However, there might be some differences when it comes to other operators. The MOD operator for instance, I gave it the same precedence as multiplication and division. The exponent operator(^) has the highest precedence, even higher than the unary minus operator (-). Also, it is right associative. These things mean that -2^3 is evaluated as -(2^3) and 2^3^4 would be evaluated as 2^(3^4). These may differ from how other evaluators like Excel or VB6 would evaluate them. But this is extremely easy to change. It would only take the changing of one or two values to give them whatever precedence and associativity you want. The Pratt parser was invented for this very reason of controlling operator precedence easily in hand written parsers.
Final thoughts
I'm very new to this kind of thing so do not take me for an expert on this subject. Rather, what I want you to take away from this is that writing a programming or scripting language is very approachable and if I can get this far towards it then anyone can do it. I'm no one special.
I will do a full blown scripting language implementation in the future in pure VB.Net code and if the gods are willing to grant me the insight, that one would even be able to compile into x86 native code and not just into a instructions for virtual machine. I look forward to doing that one.
Lastly, here is a little video of me demonstrating this app by plugging a few expressions into it:-
Anyways, good day to you all.
↧
Label Printer
I was given several boxes of 8.8cm X 2.4cm tractor fed labels. Not having tracker feed on my printer , I cut and taped a strip of labels to an 8X10 sheet of card stock and made this app to print on them. I can print multi labels or if only a single label , I can tell it what label position to print. Its only three lines per label, but the font size ,color and font are selectable. Its not perfect and you will need to make adjustments for your needs. Labels can also be loaded and saved.< Enjoy>
↧
Pattern Brush Fill
Not much here, just an example that creates a very simple bar chart about "pie" (thus the silly name "Pie graph" in the Caption).
Shows the use of bitmap images for tiled fills when drawing. Nothing extra needed, it's all VB6 and a few GDI calls.
![Name: sshot.png
Views: 31
Size: 2.3 KB]()
Note the use of SetBrushOrgEx() to align the pattern for each use. You can comment out that call to see why it can be useful.
Shows the use of bitmap images for tiled fills when drawing. Nothing extra needed, it's all VB6 and a few GDI calls.
Note the use of SetBrushOrgEx() to align the pattern for each use. You can comment out that call to see why it can be useful.
↧
↧
My Simple Marquee
I know this has been done several times before , but wanted to share my version of it. It's resizable and colors can be changed. I wanted the speed to be smoother but this was the best I could come up with.(maybe using bitblt would work better?) Anyway, have fun with it.
↧
VB6 modArrInfo (Array-introspection without Error-Handlers)
Since there's so many often badly written (or incomplete) Array-check-routines floating around,
here's a Drop-In-Module (you might name it e.g. modArrInfo.bas).
With that, you can then perform complete Array-instrospection, like shown in the Test-Formcode below:
Ok, and here the Code for the Drop-In-Module
Have fun with it (plus safer ArrayHandling) ;)
Olaf
here's a Drop-In-Module (you might name it e.g. modArrInfo.bas).
With that, you can then perform complete Array-instrospection, like shown in the Test-Formcode below:
Code:
Option Explicit
Private Sub Form_Load()
Dim Arr() As String
Arr = Split("") 'check with an intialized, but not yet redimmed Array (comment out to test an un-initialized case)
'ReDim Arr(1 To 5, 0 To 0) 'to re-check the calls below with a 2D-redimmed array
Debug.Print "TypeName:", " "; TypeName(Arr)
Debug.Print "ArrPtrSym:", ArrPtrSym(Arr)
Debug.Print "ArrPtrSaf:", ArrPtrSaf(Arr)
Debug.Print "ArrPtrDat:", ArrPtrDat(Arr)
Debug.Print "ArrDimens:", ArrDimens(Arr)
Debug.Print "ArrLBound:", ArrLBound(Arr)
Debug.Print "ArrUBound:", ArrUBound(Arr)
Debug.Print "ArrLength:", ArrLength(Arr) '<- this is the recommended call, when you check for the necessity of redimensioning
Debug.Print "ArrElemSz:", ArrElemSz(Arr)
Debug.Print "ArrMemory:", ArrMemory(Arr); ", ...and the Struct itself:"; ArrMemory(Arr, True) - ArrMemory(Arr)
End SubCode:
Option Explicit 'SafeArray-Helpers O. Schmidt
'UDT-Arrays have to use the following call for symbol-ptr retrieval
'(one should pass the return-value of this function, and not the UDT-array directly)
Public Declare Function ArrPtrUdt& Lib "msvbvm60" Alias "VarPtr" (Arr() As Any)
Private Declare Function ArrPtr& Lib "msvbvm60" Alias "__vbaRefVarAry" (Arr)
Private Declare Function DeRef& Lib "msvbvm60" Alias "GetMem4" (ByVal pSrc&, pRes&)
Private Declare Function SafeArrayGetDim% Lib "oleaut32" (ByVal pSA&)
Private Declare Function SafeArrayGetElemsize% Lib "oleaut32" (ByVal pSA&)
Private Declare Function SafeArrayGetLBound& Lib "oleaut32" (ByVal pSA&, ByVal nDim%, pRes&)
Private Declare Function SafeArrayGetUBound& Lib "oleaut32" (ByVal pSA&, ByVal nDim%, pRes&)
Private Declare Function SafeArrayAccessData& Lib "oleaut32" (ByVal pSA&, pData&)
Private Declare Function SafeArrayUnaccessData& Lib "oleaut32" (ByVal pSA&)
'All of the functions below will throw no Errors when used with normal-Arrays (which can be passed directly)
'The same routine-behaviour is ensured also with UDT-Arrays, but then with one caveat:
'You need one additional, indirect FuncCall (using the API-call which was defined Public above)
'Example: Dim Points() As PointAPI
' If ArrLength(ArrPtrUdt(Points)) Then 'the UDT-Arr is already redimmed
Function ArrPtrSym(Arr) As Long 'returns the Symbol-Ptr of the Arr-Variable (0 when not initialized)
If IsArray(Arr) Then ArrPtrSym = ArrPtr(Arr) Else ArrPtrSym = Arr
End Function
Function ArrPtrSaf(Arr) As Long 'returns a Ptr to the SafeArray-Struct (0 when not initialized)
If IsArray(Arr) Then DeRef ArrPtrSym(Arr), ArrPtrSaf Else DeRef Arr, ArrPtrSaf
End Function
Function ArrPtrDat(Arr) As Long 'returns a Ptr to the begin of the underlying data (0 when not initialized)
SafeArrayAccessData ArrPtrSaf(Arr), ArrPtrDat: SafeArrayUnaccessData ArrPtrSaf(Arr)
End Function
Function ArrDimens(Arr) As Long 'returns the Arr-Dimensions (0 when not initialized)
ArrDimens = SafeArrayGetDim(ArrPtrSaf(Arr))
End Function
Function ArrElemSz(Arr) As Long 'returns the size of an Array-Element in Bytes (0 when not initialized)
ArrElemSz = SafeArrayGetElemsize(ArrPtrSaf(Arr))
End Function
Function ArrLBound(Arr, Optional ByVal DimIdx As Long = 1) As Long
SafeArrayGetLBound ArrPtrSaf(Arr), DimIdx, ArrLBound
End Function
Function ArrUBound(Arr, Optional ByVal DimIdx As Long = 1) As Long
If ArrPtrSaf(Arr) Then SafeArrayGetUBound ArrPtrSaf(Arr), DimIdx, ArrUBound Else ArrUBound = -1
End Function
Function ArrLength(Arr, Optional ByVal DimIdx As Long = 1) As Long 'returns the amount of Array-Slots (for a given dimension)
ArrLength = ArrUBound(Arr, DimIdx) - ArrLBound(Arr, DimIdx) + 1
End Function
'returns the memory-size in Bytes, the Data-Allocation of the array currently occupies
'(optionally adds the mem-size of the SafeArray-Struct itself)
Function ArrMemory(Arr, Optional ByVal IncludeStructSize As Boolean) As Long
Dim i As Long
For i = 1 To ArrDimens(Arr): ArrMemory = IIf(ArrMemory, ArrMemory, 1) * ArrLength(Arr, i): Next
ArrMemory = ArrMemory * ArrElemSz(Arr)
If IncludeStructSize Then If ArrPtrSaf(Arr) Then ArrMemory = ArrMemory + ArrDimens(Arr) * 8 + 16
End FunctionOlaf
↧
Color Pickers six different styles
There are six small color programs here , all user controls, dealing with color selection. See if any are any help for you. The color names was written by Robert Rayment (one of my favorite programmers form PSC), I just made a control out of it.
↧