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

VB6 - Remember App window Position and Size

$
0
0
Attached is a demo of saving and restoring an application position and size. Rather than hijacking Elroy's thread, I decided to create a new one. This code is further simplified from the code that I supplied there, in that it eliminates the need for the SysInfo control and doesn't account for the Taskbar. It also demonstrates how the onboard controls are adjusted when the form size is adjusted. This is a fairly simple demonstration, and more complex forms will take quite a bit more work. The "EXIT" button is there simply to allow the form to be unloaded when the right side is off the screen. The "InitFlg" in the "Resize" event simply prevents the controls from being adjusted on the intial activation.

The InkEdit control used as "Text1" should allow for the use of Unicode characters.

J.A. Coutts
Attached Images
 
Attached Files

[VB6] Neural Network

$
0
0
Since a neural network is missing in the codebank
here is my version:

It's very simple.

It initializes with "CREATE"
Code:

  NN.CREATE Array (2, 2, 1), 0.25, 4
-Where Array indicates the NN topology
Array (N of Inputs, Hidden layer neurons, ..., Hidden layer neurons, N of outputs)
-The second term is the Learning Rate.
-The third is the initial range of connections. (this value, together with the Learning Rate is very important and can drastically change the learning outcomes)

To get the output just call RUN with an array of inputs as arguments,
Return the Outputs Array

For learning (which is supervided) just call TRAIN.
The arguments are an array of Inputs and an array of expected Outputs
The learning process is done by backpropagation, the code is taken (and modified) by an article by Paras Chopra.

Neurons Index "Zero" [0] of each Layer is used for Bias. It is always 1 (The Biases are the weights of connections from 0-indexs neurons to next layer neurons) [Still not sure this way is correct tough]

Inputs and outputs range is from -1 to 1
the Activation function used is TANH.

Probably I'll put it on Github.

Enjoy

And, as always, anyone has ideas to improve it, is welcome
Attached Files

PNG (specifically 32-bit RGBA type PNG) Editing Tool

$
0
0
Hi All,

This was a request and I thought it would be fun. It turned out to be quite the learning experience.

Basically, I've developed a tool for editing the Gamma, Brightness, or Contrast of a 32-bit RGBA type PNG image. Sorry, but it's specifically limited to that type of an image file.

Here's a screen-shot of the main form:
Name:  PngMain.jpg
Views: 96
Size:  22.5 KB

Basically, when you open a PNG file, it loads it (via GDI+), displays it on a form, splits it into four channels (Red, Green, Blue, & Alpha), displays each of these on separate forms, and then displays one last form that shows modifications to the image. Here's a reduced screen-shot of how it looks:

Name:  PngFull.png
Views: 88
Size:  118.9 KB

A couple of caveats: I do use SaveSettings to save a few things to the registry. I know that some people are concerned about this. Therefore, if you're running in the IDE, upon normal exit, I ask if you'd like to delete all of these settings.

Also, to try and keep things speedy, I startup the GDI+ upon opening the app, and don't shut it down until you're exiting. I didn't have any problems with the IDE stop button, but I'm not totally clear on whether or not an IDE stop is totally safe here. I'm hoping that the worst case is a memory leak (that's cleared up when you exit the IDE).

The entire project is in the attachment to this post. A PNG file has also been supplied for you to play with (same one shown).

Now, I'd also like to take this opportunity to outline how I did things. Basically (because I want to handle PNG files with an active Alpha channel), I used the GDI+ to load the image. And then I immediately use the GDI+ to show this original image. Next, I get the image's RgbQuad() data, and then split that into its separate channels, creating separate arrays for Red, Green, Blue, & Alpha. And then I use the regular GDI32's SetDIBits to show these channels on the separate forms. And then, I take the four RgbQuad() channel arrays, re-combine them, and then show them on a Modifications form (using GDI+ and the still open hBitmap to do this).

Just as an FYI, the individual RgbQuad() channel arrays have no Alpha in them (it's always zero). The original image's Alpha channel is copied into the Red, Green, & Blue channels of the Alpha's RgbQuad() array, effectively creating a gray-scale image to show the Alpha channel.

I also "save in memory" all kinds of information (thinking that this would keep things speedy). Therefore, this thing is not memory efficient. Here's a list of what I maintain in memory:

  1. I keep the original file open (hBitmat) with the GDI+.
  2. I keep the original RgbQuad().
  3. I keep each channel's original RgbQuad() (four of them).
  4. I keep each channel's modified RgbQuad() (four of them).
  5. I keep a modified RgbQuad() of the full modified image.


Some of the things I learned during all of this:

  • When leaving a PNG file open (active hBitmap) with GDI+, somehow, GDI+ keeps its hooks into that file until you execute a GdipDisposeImage (or something similar).

  • These PNG files can have a DPI scaling factor embedded in them that makes using GdipDrawImage a bit dubious. If you want to "think" in pixels, this will get fouled up. To "think" in pixels, you must use GdipDrawImageRectI.

  • The GDI+ seems to prefer scanning images from top-down, whereas the GDI32 prefers seeing them as bottom-up. That just caused me to jump through a few hoops to tell the GDI+ that I want them bottom-up so that I'm not constantly flipping them.

  • As I got into it, it dawned on me that the order in which Gamma, Brightness, & Contrast are applied might matter. The approach I took was to always go back to the original image when making changes (and hence saving all those RgbQuad() arrays). Always going back to the original allows me to return to that original while editing, if I so desire. Rather than get overly complicated, I just decided on a Gamma(first), Brightness(second), & Contrast(last) approach to applying things.

  • I also learned that Contrast can be complicated. There are several theories/ideas on how this should be done. I'm not entirely happy with my approach, but it works. I save the mean value (as a Single) of each of the channels upon load. And then, pixels are either stretched away from (or pushed toward) this mean to achieve contrast changes. Other approaches would be to go toward or away from 128 (middle value). Yet another approach would be to calculate the mean each time (thereby accounting for brightness and gamma changes) but this could have speed consequences.

  • I also learned that, with larger images, my approach can bog down. At first, I was showing all changes "in real time" on each click of a control. However, it quickly became apparent that this wasn't going to work. Therefore, I implemented a timer that fires every 200ms. If a bIsModDirty flag is true and if the mouse button isn't down, it calculates and shows the changes. This allows the interface to work much more smoothly, although you don't see changes until you release the mouse button.


And, here's a list of things I may want to consider for the future:

  • Possibly exploring (learning more about) how to use the GDI+ to do my Gamma, Brightness, Contrast changes. I feel certain it's capable of this, and it may make the entire project more memory efficient, and possibly more speedy as well.

  • Possibly learn how to read a TGA (Targa) file as well. This was actually part of the original request, but I had to start somewhere. If I do this, I'd probably want my SaveAs... to be able to convert between the two.

  • Think more about the order in which the effects are applied (especially since I'm always going back to the original). I might let that be user-specified, just to see what difference it makes.

  • Possibly consider additional effects (soften, sharpen, etc.).


I've done my level-headed best to keep this code as organized as possible. However, I do use somewhat deeply nested UDTs to keep track of everything. However, for a somewhat seasoned VB6 programmer, that shouldn't be a huge deal.

If you're interested in studying this code for purposes of how to manipulate images, the place to start is the code in frmMain. And then, you'll want to get into the modPng code, and then the modGdip code. I've tried to make the modGdip code as generic as possible (i.e., not really tied to the specifics of this project). The code in modPng is rather specific to this project. You'll see all the stuff that's maintained in memory in the ThePng UDT variable that's in the modPng file. There's also a touch of GDI32 stuff in the modPng file.

Version 1.03 (original release)

Enjoy,
Elroy

p.s. Please stay focused and please don't be upset if I don't respond to all of these, but critiques and suggestions for improvement are welcomed and encouraged.
Attached Images
  
Attached Files

[vb6] GDI+ Image Attributes Intro & Usage

$
0
0
Thought it would be worthwhile sharing some information regarding GDI+ and its Image Attributes object. Specifically, we are going to discuss the color matrix. This is a 5x5 matrix/grid, variable type: Single.

GDI+ uses this matrix to change image color values, on-the-fly. This prevents you from having to manipulate and change individual color values by hand. Since the matrix is basically a batch, of sorts, of formulas applied to each pixel value, there is little that cannot be done and limited only by imagination or creativity.

The project included below is provided to get your feet wet. There exists on many sites sample matrices you can use to achieve many different color transformations. Wouldn't be a bad idea to start collecting these and storing away for future use. This project, though truly a demo, offers a method to save and load your personal collections of matrices (assuming they were saved while using the demo).

The project is also designed to punch in any matrix values you want and see the results with a click of a button. Like what you see after your changes? Save the matrix or copy the matrix to the clipboard and paste into your project.

I've included a sample PNG in the file, but the project allows you to select images from your computer. I'm sure some of you will ask questions, but let's not discuss modifying the demo project... let's talk about GDI+ image attributes.

This is a good link to read a bit more about GDI+ color matrices. The link starts at page 7 at that site, be sure to browse some of the other pages too.

Screenshot below is a more complex matrix. Most matrices are just 3-5 non-zero entries.

Name:  Untitled.png
Views: 41
Size:  49.7 KB

Note for non-US locales, use US decimals. The project expects that format in the textboxes.
Attached Images
 
Attached Files

VB6 - Sort Routine

$
0
0
Shown here is a sort routine that utilizes the built in Command Line sort function. Outside of this routine, a file is loaded into a Textbox and the file name is saved in "m_Filename". The user is first asked where in each line the sort is to start. I use this routine to sort log files, which often begin with a time stamp. The file is appended chronologically, so it is already sorted by time. For example:

00:03:14 Request from 74.125.80.70 for TXT-record for _adsp._domainkey.yellowhead.com.
00:03:15 Sending reply to 74.125.80.70 about TXT-record for _adsp._domainkey.yellowhead.com.:
00:03:16 -> Header: Name does not exist!

I am only interested in the "Request" part of it, so I would start at position 25. I can then easily delete the unwanted portions.

The sorted file is temporarily stored in the users "Temp" directory. You will probably find lots of junk in that directory, as many programs are not very good at cleaning up after themselves. We will attempt not to be one of those, and "Kill" off the file after we are done with it.

The heart of the routine is the "Shell" function. In that I use the seldom used "Environ" function to recover the "COMSPEC" string from the Environment. Environment variables will vary with the individual computer, and can be viewed from the Command Prompt with the "Set" command. To this I add "/c" to concatenate, the "type" command, the file name to sort, the pipe option (|), the "sort" command, and the name of the file to direct the output to. I also add a "vbHide" option, since we are not interested in displaying the results in a Command Prompt window.

We then enter a loop waiting for the directory to be updated. To prevent getting stuck in an endless loop, a counter is implemented. Since file I/O is a buffered operation, an additional 100 ms delay is added to allow for the write operation to complete. The "Loadfile" routine loads the newly sorted file back into the Textbox. We use another 100 ms delay to allow that operation to complete before we delete the temporary file. We then restore the App.Path and the original file name.
Code:

Private Sub mnuSort_Click()
    Dim sTmp As String
    Dim lCntr As Long
    Dim SortStart As Long
    Dim SortCmd As String
    If Len(m_Filename) = 0 Then
        MsgBox "Text must be saved as a file before it can be sorted!", vbExclamation
        Exit Sub
    End If
    SortStart = InputBox("Enter character count to start at - ", "Start", 0)
    If SortStart = 0 Then
        SortCmd = "|sort>tmpsort.txt" 'Default starts at beginning of line
    Else
        SortCmd = "|sort /+" & CStr(SortStart) & ">tmpsort.txt"
    End If
    ChDir TmpPath 'Sorted file is output to temp path
    sTmp = m_Filename 'Save current file location
    Debug.Print Timer
    Call Shell(Environ("COMSPEC") & " /c type " & m_Filename & SortCmd, vbHide)
    m_Filename = "tmpsort.txt" 'Change filename to sorted file
    Do Until Dir(m_Filename) = m_Filename 'Wait for directory to be updated
        DoEvents
        Sleep 10
        lCntr = lCntr + 1
        If lCntr > 100 Then GoTo SortErr
    Loop
    Debug.Print lCntr
    Sleep 100 'Wait an additional 100 ms for file write to complete
    Debug.Print Timer
    LoadFile 'Load sorted file to Textbox
    Sleep 100 'Wait an additional 100 ms for sorted file to load
    Kill m_Filename
    Debug.Print Timer
    m_Filename = sTmp 'Restore original filename
    ChDir App.Path 'Restore Application path
    m_Flg1 = True 'Set change flag
    Exit Sub
SortErr:
    MsgBox "Sort Timed out!"
End Sub

Private Const MAX_PATH = 260
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Function GetTmpPath() As String
    Dim sFolder As String ' Name of the folder
    Dim lRet As Long ' Return Value
    sFolder = String(MAX_PATH, 0)
    lRet = GetTempPath(MAX_PATH, sFolder)
    If lRet <> 0 Then
        GetTmpPath = Left(sFolder, InStr(sFolder, Chr(0)) - 1)
    Else
        GetTmpPath = vbNullString
    End If
End Function

I have found this routine to be a lot faster than any algorithm I could put together in VB6, especially for large text files. For the most part it is an in-memory sort, but for very large files it will temporarily store the first run to the disk before attempting the second run. An example of how to use this routine will be forthcoming in the near future.

J.A. Coutts

PNG/TGA (specifically 32-bpp type files) Editing Tool

$
0
0
Note, this project uses mscomctl.ocx version 2.2. If you have an older version, the project may not load correctly for you. To fix this problem, you will need to update your mscomctl.ocx. Here's a link to a post by LaVolpe that explains the issue more fully, and provides links for the updates. Also, mscomct2.ocx version 2.0 is used for the status bar. If you have an older version of that, you may need to update it as well (or remove the status bar, which wouldn't be difficult).

Version 1.03 (original release, attached to this OP)
Version 1.04 released in post #16
Version 1.05 released in post #17
Version 1.06 released in post #18

Hi All,

This was a request and I thought it would be fun. It turned out to be quite the learning experience.

Basically, I've developed a tool for editing the Gamma, Brightness, or Contrast of a 32-bit RGBA type PNG or TGA image. Sorry, but it's specifically limited to that type of an image file.

Here's a screen-shot of the main form:
Name:  PngMain.jpg
Views: 218
Size:  22.5 KB

Basically, when you open a PNG file, it loads it (via GDI+), displays it on a form, splits it into four channels (Red, Green, Blue, & Alpha), displays each of these on separate forms, and then displays one last form that shows modifications to the image. Here's a reduced screen-shot of how it looks:

Name:  PngTga.png
Views: 20
Size:  116.2 KB

A couple of caveats: I do use SaveSettings to save a few things to the registry. I know that some people are concerned about this. Therefore, if you're running in the IDE, upon normal exit, I ask if you'd like to delete all of these settings.

Also, to try and keep things speedy, I startup the GDI+ upon opening the app, and don't shut it down until you're exiting. I didn't have any problems with the IDE stop button, but I'm not totally clear on whether or not an IDE stop is totally safe here. I'm hoping that the worst case is a memory leak (that's cleared up when you exit the IDE).

The entire project is in the attachment to this post. A PNG file has also been supplied for you to play with (same one shown).

Now, I'd also like to take this opportunity to outline how I did things. Basically (because I want to handle PNG files with an active Alpha channel), I used the GDI+ to load the image. And then I immediately use the GDI+ to show this original image. Next, I get the image's RgbQuad() data, and then split that into its separate channels, creating separate arrays for Red, Green, Blue, & Alpha. And then I use the regular GDI32's SetDIBits to show these channels on the separate forms. And then, I take the four RgbQuad() channel arrays, re-combine them, and then show them on a Modifications form (using GDI+ and the still open hBitmap to do this).

Just as an FYI, the individual RgbQuad() channel arrays have no Alpha in them (it's always zero). The original image's Alpha channel is copied into the Red, Green, & Blue channels of the Alpha's RgbQuad() array, effectively creating a gray-scale image to show the Alpha channel.

I also "save in memory" all kinds of information (thinking that this would keep things speedy). Therefore, this thing is not memory efficient. Here's a list of what I maintain in memory:

  1. I keep the original file open (hBitmat) with the GDI+.
  2. I keep the original RgbQuad().
  3. I keep each channel's original RgbQuad() (four of them).
  4. I keep each channel's modified RgbQuad() (four of them).
  5. I keep a modified RgbQuad() of the full modified image.


Some of the things I learned during all of this:

  • When leaving a PNG file open (active hBitmap) with GDI+, somehow, GDI+ keeps its hooks into that file until you execute a GdipDisposeImage (or something similar).

  • These PNG files can have a DPI scaling factor embedded in them that makes using GdipDrawImage a bit dubious. If you want to "think" in pixels, this will get fouled up. To "think" in pixels, you must use GdipDrawImageRectI.

  • The GDI+ seems to prefer scanning images from top-down, whereas the GDI32 prefers seeing them as bottom-up. That just caused me to jump through a few hoops to tell the GDI+ that I want them bottom-up so that I'm not constantly flipping them.

  • As I got into it, it dawned on me that the order in which Gamma, Brightness, & Contrast are applied might matter. The approach I took was to always go back to the original image when making changes (and hence saving all those RgbQuad() arrays). Always going back to the original allows me to return to that original while editing, if I so desire. Rather than get overly complicated, I just decided on a Gamma(first), Brightness(second), & Contrast(last) approach to applying things.

  • I also learned that Contrast can be complicated. There are several theories/ideas on how this should be done. I'm not entirely happy with my approach, but it works. I save the mean value (as a Single) of each of the channels upon load. And then, pixels are either stretched away from (or pushed toward) this mean to achieve contrast changes. Other approaches would be to go toward or away from 128 (middle value). Yet another approach would be to calculate the mean each time (thereby accounting for brightness and gamma changes) but this could have speed consequences.

  • I also learned that, with larger images, my approach can bog down. At first, I was showing all changes "in real time" on each click of a control. However, it quickly became apparent that this wasn't going to work. Therefore, I implemented a timer that fires every 200ms. If a bIsModDirty flag is true and if the mouse button isn't down, it calculates and shows the changes. This allows the interface to work much more smoothly, although you don't see changes until you release the mouse button.


And, here's a list of things I may want to consider for the future:

  • Possibly exploring (learning more about) how to use the GDI+ to do my Gamma, Brightness, Contrast changes. I feel certain it's capable of this, and it may make the entire project more memory efficient, and possibly more speedy as well.

  • Possibly learn how to read a TGA (Targa) file as well. This was actually part of the original request, but I had to start somewhere. If I do this, I'd probably want my SaveAs... to be able to convert between the two.

  • Think more about the order in which the effects are applied (especially since I'm always going back to the original). I might let that be user-specified, just to see what difference it makes.

  • Possibly consider additional effects (soften, sharpen, etc.).


I've done my level-headed best to keep this code as organized as possible. However, I do use somewhat deeply nested UDTs to keep track of everything. However, for a somewhat seasoned VB6 programmer, that shouldn't be a huge deal.

If you're interested in studying this code for purposes of how to manipulate images, the place to start is the code in frmMain. And then, you'll want to get into the modPng code, and then the modGdip code. I've tried to make the modGdip code as generic as possible (i.e., not really tied to the specifics of this project). The code in modPng is rather specific to this project. You'll see all the stuff that's maintained in memory in the ThePng UDT variable that's in the modPng file. There's also a touch of GDI32 stuff in the modPng file.

Enjoy,
Elroy

p.s. Please stay focused and please don't be upset if I don't respond to all of these, but critiques and suggestions for improvement are welcomed and encouraged.
Attached Images
  
Attached Files

Standard API Color Picker

$
0
0
It's strange that this doesn't have more of a presence on these forums than it does, but hey ho.

Attached is the my ChooseColorAPI wrapper that I've just polished up. Here are its features:
  • It just always opens allowing you to select custom colors.
  • You can save the user-specified custom colors if you so choose (your application specific).
  • It has the ability of allowing you to specify your own dialog title.
  • You can double-click on the colors and they will auto-select and be returned to you.

Beyond that, it's pretty much the standard ChooseColorAPI function.

More could be done with this thing, but this is precisely what I needed, and I thought I'd share.

Here's code for a standard BAS module (everything needed, just focus on the ShowColorDialog procedure):

Code:


Option Explicit
'
' These are used to get information about how the dialog went.
Public ColorDialogSuccessful As Boolean
Public ColorDialogColor As Long
'
Private Type ChooseColorType
    lStructSize        As Long
    hWndOwner          As Long
    hInstance          As Long
    rgbResult          As Long
    lpCustColors      As Long
    flags              As Long
    lCustData          As Long
    lpfnHook          As Long
    lpTemplateName    As String
End Type
Private Enum ChooseColorFlagsEnum
    CC_RGBINIT = &H1                  ' Make the color specified by rgbResult be the initially selected color.
    CC_FULLOPEN = &H2                ' Automatically display the Define Custom Colors half of the dialog box.
    CC_PREVENTFULLOPEN = &H4          ' Disable the button that displays the Define Custom Colors half of the dialog box.
    CC_SHOWHELP = &H8                ' Display the Help button.
    CC_ENABLEHOOK = &H10              ' Use the hook function specified by lpfnHook to process the Choose Color box's messages.
    CC_ENABLETEMPLATE = &H20          ' Use the dialog box template identified by hInstance and lpTemplateName.
    CC_ENABLETEMPLATEHANDLE = &H40    ' Use the preloaded dialog box template identified by hInstance, ignoring lpTemplateName.
    CC_SOLIDCOLOR = &H80              ' Only allow the user to select solid colors. If the user attempts to select a non-solid color, convert it to the closest solid color.
    CC_ANYCOLOR = &H100              ' Allow the user to select any color.
End Enum
#If False Then ' Intellisense fix.
    Public CC_RGBINIT, CC_FULLOPEN, CC_PREVENTFULLOPEN, CC_SHOWHELP, CC_ENABLEHOOK, CC_ENABLETEMPLATE, CC_ENABLETEMPLATEHANDLE, CC_SOLIDCOLOR, CC_ANYCOLOR
#End If
Private Type KeyboardInput        '
    dwType As Long                ' Set to INPUT_KEYBOARD.
    wVK As Integer                ' shift, ctrl, menukey, or the key itself.
    wScan As Integer              ' Not being used.
    dwFlags As Long              '            HARDWAREINPUT hi;
    dwTime As Long                ' Not being used.
    dwExtraInfo As Long          ' Not being used.
    dwPadding As Currency        ' Not being used.
End Type
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Const WM_LBUTTONDBLCLK As Long = 515&
Private Const WM_SHOWWINDOW    As Long = 24&
Private Const WM_SETTEXT      As Long = &HC&
Private Const INPUT_KEYBOARD  As Long = 1&
Private Const KEYEVENTF_KEYUP  As Long = 2&
Private Const KEYEVENTF_KEYDOWN As Long = 0&
'
Private muEvents(1) As KeyboardInput    ' Just used to emulate "Enter" key.
Private pt32 As POINTAPI
Private msColorTitle As String
'
Private Declare Function ChooseColorAPI Lib "comdlg32" Alias "ChooseColorA" (pChoosecolor As ChooseColorType) As Long
Private Declare Function SendInput Lib "user32" (ByVal nInputs As Long, pInputs As Any, ByVal cbSize As Long) As Long
Private Declare Function SetFocusTo Lib "user32" Alias "SetFocus" (Optional ByVal hWnd As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ChildWindowFromPointEx Lib "user32" (ByVal hWnd As Long, ByVal xPoint As Long, ByVal yPoint As Long, ByVal uFlags As Long) As Long
Private Declare Function SendMessageWLong Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'

Public Function ShowColorDialog(hWndOwner As Long, Optional NewColor As Long, Optional Title As String = "Select Color", Optional CustomColorsHex As String) As Boolean
    ' You can optionally use ColorDialogSuccessful & ColorDialogColor or the return of ShowColorDialog and NewColor.  They will be the same.
    '
    ' CustomColorHex is a comma separated hex string of 16 custom colors.  It's best to just let the user specify these, starting out with all black.
    ' If this CustomColorHex string doesn't separate into precisely 16 values, it's ignored, resulting with all black custom colors.
    ' The string is returned, and it's up to you to save it if you wish to save your user-specified custom colors.
    ' These will be specific to this program, because this is your CustomColorsHex string.
    '
    Dim uChooseColor As ChooseColorType
    Dim CustomColors(15) As Long
    Dim sArray() As String
    Dim i As Long
    '
    msColorTitle = Title
    '
    ' Setup custom colors.
    sArray = Split(CustomColorsHex, ",")
    If UBound(sArray) = 15 Then
        For i = 0 To 15
            CustomColors(i) = Val("&h" & sArray(i))
        Next i
    End If
    '
    uChooseColor.hWndOwner = hWndOwner
    uChooseColor.lpCustColors = VarPtr(CustomColors(0))
    uChooseColor.flags = CC_ENABLEHOOK Or CC_FULLOPEN
    uChooseColor.hInstance = App.hInstance
    uChooseColor.lStructSize = LenB(uChooseColor)
    uChooseColor.lpfnHook = ProcedureAddress(AddressOf ColorHookProc)
    '
    ColorDialogSuccessful = False
    If ChooseColorAPI(uChooseColor) = 0 Then
        Exit Function
    End If
    If uChooseColor.rgbResult > &HFFFFFF Then Exit Function
    '
    ColorDialogColor = uChooseColor.rgbResult
    NewColor = uChooseColor.rgbResult
    ColorDialogSuccessful = True
    ShowColorDialog = True
    '
    ' Return custom colors.
    ReDim sArray(15)
    For i = 0 To 15
        sArray(i) = Hex$(CustomColors(i))
    Next i
    CustomColorsHex = Join(sArray, ",")
End Function

Private Function ColorHookProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If uMsg = WM_SHOWWINDOW Then
        SetWindowText hWnd, msColorTitle
        ColorHookProc = 1&
    End If
    '
    If uMsg = WM_LBUTTONDBLCLK Then
        '
        ' If we're on a hWnd with text, we probably should ignore the double-click.
        GetCursorPos pt32
        ScreenToClient hWnd, pt32
        '
        If WindowText(ChildWindowFromPointEx(hWnd, pt32.X, pt32.Y, 0&)) = vbNullString Then
            ' For some reason, this SetFocus is necessary for the dialog to receive keyboard input under certain circumstances.
            SetFocusTo hWnd
            ' Build EnterKeyDown & EnterKeyDown events.
            muEvents(0).wVK = vbKeyReturn: muEvents(0).dwFlags = KEYEVENTF_KEYDOWN: muEvents(0).dwType = INPUT_KEYBOARD
            muEvents(1).wVK = vbKeyReturn: muEvents(1).dwFlags = KEYEVENTF_KEYUP:  muEvents(1).dwType = INPUT_KEYBOARD
            ' Put it on buffer.
            SendInput 2&, muEvents(0), Len(muEvents(0))
            ColorHookProc = 1&
        End If
    End If
End Function

Private Function ProcedureAddress(AddressOf_TheProc As Long)
    ProcedureAddress = AddressOf_TheProc
End Function

Private Function WindowText(hWnd As Long) As String
    WindowText = Space$(GetWindowTextLength(hWnd) + 1)
    WindowText = Left$(WindowText, GetWindowText(hWnd, WindowText, Len(WindowText)))
End Function

Public Sub SetWindowText(hWnd As Long, sText As String)
    SendMessageWLong hWnd, WM_SETTEXT, 0&, StrPtr(sText)
End Sub


And, if you wish to just test/play, here's a bit of code for a Form1:

Code:


Option Explicit
'
Dim msOurCustomColors As String
'

Private Sub Form_Click()
    ShowColorDialog Me.hWnd, , "Pick a color for background", msOurCustomColors
    If ColorDialogSuccessful Then Me.BackColor = ColorDialogColor
End Sub

Enjoy,
Elroy

[VB6] BatchRtb 2

$
0
0
Since I am almost 100% retired now and doing a lot less VB6 programming I have been looking for things in my toolkit that might be worth sharing with the remaining VB6 community.

I have done a big rewrite of my BatchRtb Class. Here is the main ReadMe:

Code:

========
BatchRtb Version 2.0
========

BatchRtb is a VB6 class for working with RTF data in batch programs.

Instead of a RichTextBox control it creates an invisible RichEdit
control and exposes its Text Object Model (TOM) ITextDocument
interface.  A few additional methods and properties are provided for
opening, saving, and clearing RTF data.

Open and save operations accept:

    o A file name.
    o A Byte array.
    o An IStream object.
    o A ShStream object (another provided class also used internally).
    o An ADODB.Stream object.

These should all contain raw RTF data.


Notes:

    Edanmo's olelib.tlb is required for compiling, but is of course
    not needed at run time and does not need to be deployed.  A recent
    copy has been included.

    If necessary you could even create and compile an ActiveX DLL
    Project exposing the BatchRtb class and perhaps the ShStream class.
    Then this can be used from VBScript in WSH scripts, IIS ASP
    scripts, etc. (anywhere a 32-bit ActiveX DLL can be used).

    Several demo/test Projects using BatchRtb are included.


Some uses:

    o Command line programs.  Local, via PsExec.exe, etc.
    o Batch unattended scheduled tasks.
    o Services.
    o Or anywhere that you don't have a Form or UserControl you can
      site a RichTextBox or InkEdit control on.

This isn't for everyone. Few people are doing Service development, ASP scripting, etc. Most don't even have a clue how to use a CLI (cmd.exe) window, let alone schedule a non-interactive batch task using Task Scheduler any more.

But this code may contain techniques you could employ in your own programs.


BatchRtb 2.0 has been tested on Windows 10 Fall Creator's Update but not on anything else yet. It should work on anything from Windows Vista on up. I'm not sure it could be made to work on Win9x but I think it could be reworked to run on NT 4.0 on up by rewriting the ShStream class - as long as a recent version of ADO (2.5 or later) is installed. The ADO requirement could also be stripped out if necessary.

I haven't done exhaustive testing so bugs may remain in this release. But the attachment contains a number of test case Projects that exercise most of its operations.
Attached Files

VB6 - Multiline Textbox Printer

$
0
0
I had previously used a RichTextBox and the SelPrint routine, but I discovered that routine would not work with an InkEdit Control. With the help of jpbro, we put together a routine for the InkEdit Control (located in the parent forum). But that routine does not work with a Textbox, and I could not find anything online to fit the bill. So I came up with the routine attached.

This routine has experienced very little testing because my development computer does not currently have access to an actual printer. Bug reports would be appreciated.

J.A. Coutts
Attached Files

VB6 - Text Editor

$
0
0
I found a need for addtional functions that NotePad did not provide, so I came up with my own Text Editor. It has most of the functions of NotePad with a couple of extra ones.
Code:

File                Edit                Format                Search
-New                -Undo                -Word Wrap        -Find
-Open                -Cut                -Sort                -Find Next
-Save                -Copy                -Font
-Save as        -Paste
-Print                -Delete
-Exit                -Replace
                -Select All

The noticeable extra is the Sort function, which is covered in a previous post. The other extra is the ability to replace character ranges per line in addition to search and replace specific text. This is accomplished by replacing the double characters CrLf with a single character Cr, using a Split function to separate individual lines into a string array, looping through each line to replace the selected character range, and reassembling the complete string with the Join function. For large text files, search and Replace All by text will be slow, whereas Replace All by character count will be fast by comparison.

The print function has taken some time to put together, as printing from a Text Box is not straight forward, and it has experienced limited testing due to lack of an available printer. It also has been covered in a previous post.

The Line/Col function that comes with Text Editor is not considered an option, as in NotePad. Unlike NotePad, it is available in either Wrap or Unwrap modes, and is only activated by mouse click. If it is important to you, you are welcome to add activation by cursor keys.

Originally I used the API to perform the Edit functions since the VB functions were limited to 64K. But then I discovered that the keyboard functions are not limited to 64K, and perform most of those tasks quite well and with good speed. So it made a lot of sense to use the keyboard functions instead.

Like NotePad, Text Editor provides an adjustable window that remembers it's location and size.

The surprising part of this effort is that with the additional functionality provided, the executable is 1/3 the size of Notepad. I have added functions that meet my current needs, and other users may have specific functions that can be added to meet their needs.

J.A. Coutts
Attached Images
  
Attached Files

Fast Call COM object (activex.dll) ,Run Windows API

$
0
0
How to test the method of the COM object (activex.dll) in real time and run the windows api?
【Organizing, testing the project, and uploading examples after completion】

Method 1: Use VBS to create new objects or call the API library to call the WINDOWS function library
Method 2: Use VB6's Add-in plug-in method to dynamically create a project, create an object variable, and run
Method 3: The createobject ("excel.application") method creates a new Excel vba module, automatically adds code, and runs

It would be nice if each file could have a manual like PHP online tutorial.
Each process method and function can be directly tested without running into EXE.
Each method and function are listed in the manual, and you can run the test with one click to see the effect.

It's like there are tens of thousands of windows api, such as findwindow, messageboxa.
Make a table, write a description of the parameter types required by each API, add some test data, and you can run it directly to see the effect.
To achieve the same EXCEL formula, run windows api, Activex.Class1.Method (parameter 1, parameter 2) as a formula and run it immediately.

PHP Tutorial | Rookie Tutorial
https://www.runoob.com/php/php-tutorial.html
Rookie Tutorial Online Editor
https://www.runoob.com/try/runcode.p...intro&type=php
----------------
<! DOCTYPE html>
<html>
<body>

<? php
echo "Hello World!";
?>

</ body>
</ html>

There is a button "click to run code" on the page
-------------

Vb6 OpenOffice sdk(com.sun.star.ServiceManager)

$
0
0
need install jdk first

OpenOffice_sdk http://www.openoffice.org/api/basic/...l/tutorial.pdf
JDK1.8
32bit jdk https://www.7down.com/soft/267473.html
OpenOffice4.1.7 https://www.openoffice.org/download/

HKEY_CLASSES_ROOT\com.sun.star.ServiceManager
CLSID:{82154420-0FBF-11d4-8313-005004526AB4}
C:\Program Files (x86)\OpenOffice 4\program\soffice.exe -nodefault -nologo

Code:

Option Explicit

Private Sub Command1_Click()
NewExcelWord
'good_新建一个Excel和Word文档
End Sub

Private Sub Command3_Click()
'新建Excel类表格
'NewExcel
Dim mNoArgs()
Dim oSpreadsheetDocument As Object
Dim oTextDocument As Object
'Using StarOffice API - Basics 19
Dim oSM As Object
Set oSM = CreateObject("com.sun.star.ServiceManager")
Dim oDesktop
Set oDesktop = oSM.CreateInstance("com.sun.star.frame.Desktop")
'oDesktop = createUnoService("com.sun.star.frame.Desktop")
Dim sUrl
sUrl = "private:factory/scalc"
Set oSpreadsheetDocument = _
oDesktop.loadComponentFromURL(sUrl, "_blank", 0, mNoArgs())
 

 'GetCell = oSheet.getCellByPosition(nColumn, nRow)
 Dim oSheet As Object
 Set oSheet = oSpreadsheetDocument.getSheets().getByIndex(0)
 Dim Row As Long, Col As Long
 Row = 2
 Col = 2
 
  Dim s As String
 For Row = 1 To 3
 For Col = 1 To 5
 
 'oSheet.getCellByPosition(Col - 1, Row - 1).Value = Row & Col
 s = "v" & Row & Col
 
 'oSheet.getCellByPosition(Col - 1, Row - 1).v = Row & Col' long,value
 oSheet.getCellByPosition(Col - 1, Row - 1).String = s '
 Next
 Next

End Sub

Sub NewExcelWord()
Dim mNoArgs()
Dim oSpreadsheetDocument As Object
Dim oTextDocument As Object
'Using StarOffice API - Basics 19
Dim oSM As Object
Set oSM = CreateObject("com.sun.star.ServiceManager")
Dim oDesktop
Set oDesktop = oSM.CreateInstance("com.sun.star.frame.Desktop")
'oDesktop = createUnoService("com.sun.star.frame.Desktop")
Dim sUrl
sUrl = "private:factory/scalc"
Set oSpreadsheetDocument = _
oDesktop.loadComponentFromURL(sUrl, "_blank", 0, mNoArgs())
sUrl = "private:factory/swriter"
Set oTextDocument = _
oDesktop.loadComponentFromURL(sUrl, "_blank", 0, mNoArgs)
End Sub

Private Sub Command4_Click()
 'OpenWord
 '打开一个WORD文件
Dim mFileProperties(0) ' As New com.sun.star.beans.PropertyValue
Dim sUrl As String
Dim oSM As Object
Set oSM = CreateObject("com.sun.star.ServiceManager")
Dim oDesktop
Dim oDocument
Set oDesktop = oSM.CreateInstance("com.sun.star.frame.Desktop")

sUrl = "file:///" & App.Path & "\002word.doc"
sUrl = Replace(sUrl, "\", "/")
sUrl = GetFileName(App.Path & "\002word.doc")

'mFileProperties(0).Name = "FilterName"
'mFileProperties(0).Value = "scalc: Text - txt - csv (StarCalc)"
Set oDocument = oDesktop.loadComponentFromURL(sUrl, "_blank", 0, mFileProperties())
End Sub
Function GetFileName(ByVal sUrl As String) As String
sUrl = "file:///" & sUrl
sUrl = Replace(sUrl, "\", "/")
GetFileName = sUrl
End Function

Private Sub Command5_Click()
 'Open Excel File
 '打开一个Excel文件,GOOD
Dim mFileProperties(0) ' As New com.sun.star.beans.PropertyValue
Dim sUrl As String
Dim oSM As Object
Set oSM = CreateObject("com.sun.star.ServiceManager")
Dim oDesktop
Dim oDocument
Set oDesktop = oSM.CreateInstance("com.sun.star.frame.Desktop")

sUrl = GetFileName(App.Path & "\001excel.xls")

Set oDocument = oDesktop.loadComponentFromURL(sUrl, "_blank", 0, mFileProperties())
End Sub

vb Fast Crc32 (crc32str,Crc32File)

$
0
0
Running speed test record: average time,Evaluation object
====================
use CbsPersist_20200521111942.log(161m),not 7z format

time(ms) TestObject
125.76 Crc32_Wqweto
281.03 Crc32ByAsm
326.17 Crc32Api
458.95 Crc32_LaVolpe
461.22 Crc32FromByte
====================
(USE 320M File,7z format)

----------------Advanced optimization:
249.41 Crc32_Wqweto
555.39 Crc32ByAsm
648.79 Crc32Api

905.41 Crc32_LaVolpe
906.42 Crc32FromByte
----------------Pentium Pro(Tm) optimization:
573.88 Crc32ByAsm UsedTime(Ms)
665.31 Crc32Api UsedTime(Ms)
737.25 Crc32FromByte UsedTime(Ms)
739.31 Crc32_LaVolpe UsedTime(Ms)
====================
Why is this forum picture compressed automatically? The total capacity of attachments uploaded at the same time is also pitiful?
Name:  FunctionSpeedTesting.jpg
Views: 106
Size:  47.6 KB
method1:use api RtlComputeCrc32
Code:

Private Declare Function RtlComputeCrc32 Lib "ntdll.dll" ( _
    ByVal dwInitial As Long, _
    ByVal pData As Long, _
    ByVal iLen As Long) As Long

Public Function Crc32Api ( tBuff() As Byte) as long   
    Crc32Api = RtlComputeCrc32(0, VarPtr(tBuff(0)), UBound(tBuff) + 1)
End Function

Public Function GetStringCRC32(ByVal InString As String) As String
'123456789=CBF43926
    Dim lRet As Long, tBuff() As Byte
   
    tBuff = StrConv(InString, vbFromUnicode)
   
    lRet = RtlComputeCrc32(0, VarPtr(tBuff(0)), UBound(tBuff) + 1)
    GetStringCRC32 = Hex(lRet)
End Function

method2:
Code:

'call InitCrc32 'First
Dim CRC32Table(255) As Long


Private Declare Function MultiByteToWideChar Lib "kernel32 " (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
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 Const CP_ACP = 0 ' default to ANSI code page
Private Const CP_UTF8 = 65001 ' default to UTF-8 code page

'string to UTF8
Public Function EncodeToBytes(ByVal sData As String) As Byte() ' Note: Len(sData) > 0
Dim aRetn() As Byte
Dim nSize As Long
nSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sData), -1, 0, 0, 0, 0) - 1
If nSize = 0 Then Exit Function
ReDim aRetn(0 To nSize - 1) As Byte
WideCharToMultiByte CP_UTF8, 0, StrPtr(sData), -1, VarPtr(aRetn(0)), nSize, 0, 0
EncodeToBytes = aRetn
Erase aRetn
End Function

Function Crc32FromByte(B() As Byte) As Long
    Dim i As Long, iCRC As Long
    iCRC = &HFFFFFFFF
    For i = 0 To UBound(B)
        iCRC = (((iCRC And &HFFFFFF00) \ &H100) And &HFFFFFF) Xor CRC32Table((iCRC And &HFF) Xor B(i))
    Next
    Crc32FromByte = iCRC Xor &HFFFFFFFF
End Function

Function crc32byte(B() As Byte) As long
    Dim i As Long, iCRC As Long, lngA As Long, ret As Long
    dim bytT As Byte, bytC As Byte
   
    iCRC = &HFFFFFFFF
    For i = 0 To UBound(B)
        bytC = B(i)
        bytT = (iCRC And &HFF) Xor bytC
        lngA = ((iCRC And &HFFFFFF00) \ &H100) And &HFFFFFF
        iCRC = lngA Xor CRC32Table(bytT)
    Next
    ret = iCRC Xor &HFFFFFFFF
    crc32byte =ret
End Function

'string's CRC32
Public Function crc32str(item As String) As String
    Dim i As Long, iCRC As Long, lngA As Long, ret As Long
    Dim B() As Byte, bytT As Byte, bytC As Byte
    B = StrConv(item, vbFromUnicode)
   
    iCRC = &HFFFFFFFF
    For i = 0 To UBound(B)
        bytC = B(i)
        bytT = (iCRC And &HFF) Xor bytC
        lngA = ((iCRC And &HFFFFFF00) \ &H100) And &HFFFFFF
        iCRC = lngA Xor CRC32Table(bytT)
    Next
    ret = iCRC Xor &HFFFFFFFF
    crc32str = Right("00000000" & Hex(ret), 8)
End Function

Public Function Crc32File(sFilePath As String, Optional Block As Long = 1024) As Long ' String
'改进后180M左右以上的文件更快了,超过“GetFileCRC32_MapFile”
    Dim hFile As Long, i As Long, iCRC As Long, lngA As Long, Size As Long, ret As Long
    Dim bytT As Byte, bytC As Byte
    Dim sSize As Currency, total As Currency, Ub As Long
    total = FileLen(sFilePath)
    If total = 0 Then Exit Function 'Len(Dir(sFilePath))
    If total < 0 Then total = total + 256 ^ 4
    sSize = Block * 1024
    hFile = FreeFile
    Open sFilePath For Binary Access Read As #hFile
    iCRC = &HFFFFFFFF
'    Dim sSize2 As Long
'    sSize2 = sSize + 1
    'Dim sSizeX As Long
    'sSizeX = sSize - 1

    Ub = sSize - 1
    ReDim B(Ub) As Byte
 
'sSize=8,sSizeX=7
    While total >= sSize '>=8  '722-725
    'While total > sSizeX  '>7
    'While total > sSize - 1 '慢去 '713-715
        Get #hFile, , B
        For i = 0 To Ub
            bytC = B(i)
            bytT = (iCRC And &HFF) Xor bytC
            lngA = ((iCRC And &HFFFFFF00) \ &H100) And &HFFFFFF
            iCRC = lngA Xor CRC32Table(bytT)
        Next
        total = total - sSize
    Wend
   
    If total > 0 Then '余下区块
        Ub = total - 1
        ReDim B(Ub) As Byte
        Get #hFile, , B
        For i = 0 To Ub
            bytC = B(i)
            bytT = (iCRC And &HFF) Xor bytC
            lngA = ((iCRC And &HFFFFFF00) \ &H100) And &HFFFFFF
            iCRC = lngA Xor CRC32Table(bytT)
        Next
    End If
   
 
   
    Close #hFile
    ret = iCRC Xor &HFFFFFFFF
    Crc32File = ret
    'Crc32File = Right("00000000" & Hex(ret), 8)
End Function
'CRC32 Table
Public Function InitCrc32(Optional ByVal Seed As Long = &HEDB88320, Optional ByVal Precondition As Long = &HFFFFFFFF) As Long
    Dim i As Integer, j As Integer, CRC32 As Long, Temp As Long
    For i = 0 To 255
        CRC32 = i
        For j = 0 To 7
            Temp = ((CRC32 And &HFFFFFFFE) \ &H2) And &H7FFFFFFF
            If (CRC32 And &H1) Then CRC32 = Temp Xor Seed Else CRC32 = Temp
        Next
        CRC32Table(i) = CRC32
    Next
    InitCrc32 = Precondition
End Function

METHOD3: GetCrcByASM.CLS
Code:

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Sub CpyMem4 Lib "msvbvm60.dll" Alias "GetMem4" (Source As Any, Destination As Any)

Dim ASMBL() As Byte
Dim Table(0 To 255) As Long
Function Crc32ByAsm(Data() As Byte) As Long
'0为下标的数组,原来函数名:ChecksumDataEx
    Dim CRC32 As Long
    CRC32 = &HFFFFFFFF
    On Local Error GoTo ErrCB
    CallWindowProc VarPtr(ASMBL(0)), VarPtr(CRC32), VarPtr(Data(0)), VarPtr(Table(0)), UBound(Data) + 1
ErrCB:
    Crc32ByAsm = Not CRC32
End Function

Function ChecksumFileEx(Path As String) As Long
On Error GoTo ErrFC
Dim FreeF As Integer, Data() As Byte
FreeF = FreeFile
Open Path For Binary Access Read As #FreeF
ReDim Data(0 To LOF(FreeF) - 1) As Byte
Get #FreeF, , Data
Close #FreeF
ChecksumFileEx = Crc32ByAsm(Data)
ErrFC:
End Function
Function ChecksumFile(Path As String) As String
ChecksumFile = Hex(ChecksumFileEx(Path))
End Function

Function ChecksumTextEx(Text As String) As Long
If Len(Text) = 0 Then Exit Function
ChecksumTextEx = Crc32ByAsm(StrConv(Text, vbFromUnicode))
End Function
Function ChecksumText(Text As String) As String
ChecksumText = Hex(ChecksumTextEx(Text))
End Function


Function Crc32ByAsm2(Data() As Byte) As Long '非0下标
Dim CRC32 As Long
CRC32 = &HFFFFFFFF 'CRC32 初始值(必须)
On Local Error GoTo ErrCB
Dim DLen As Long
DLen = UBound(Data) - LBound(Data) + 1
CallWindowProc VarPtr(ASMBL(0)), VarPtr(CRC32), VarPtr(Data(LBound(Data))), VarPtr(Table(0)), DLen
ErrCB:
Crc32ByAsm2 = Not CRC32
End Function

Function ChecksumData(Data() As Byte) As String
ChecksumData = Hex(Crc32ByAsm(Data))
End Function

Function LngToBin(ipLong As Long) As Byte()
Dim tB() As Byte
ReDim tB(1 To 4)
CpyMem4 ipLong, tB(1)
LngToBin = tB
End Function
Function BinToLng(ipBin4() As Byte) As Long
CpyMem4 ipBin4(LBound(ipBin4)), BinToLng
End Function

Sub IntAsm()
Dim i As Long, j As Long

Const ASM As String = "5589E557565053518B45088B008B750C8B7D108B4D1431DB8A1E30C3C1E80833049F464975F28B4D088901595B585E5F89EC5DC21000"

' Decoded ASM source from HIEW 6.86 (Hacker's View)
'
' 55 PUSH BP
' 89E5 MOV BP,SP
' 57 PUSH DI
' 56 PUSH SI
' 50 PUSH AX
' 53 PUSH BX
' 51 PUSH CX
' 8B4508 MOV AX,DI[08]
' 8B00 MOV AX,BX[SI]
' 8B750C MOV SI,DI[0C]
' 8B7D10 MOV DI,DI[10]
' 8B4D14 MOV CX,DI[14]
' 31DB XOR BX,BX
' 8A1E30C3 MOV BL,0C330
' C1E808 SHR AX,008 <-.
' 3304 XOR AX,[SI] |
' 9F LAHF |
' 46 INC SI |
' 49 DEC CX |
' 75F2 JNE 000000018 -'
' 8B4D08 MOV CX,DI[08]
' 8901 MOV BX[DI],AX
' 59 POP CX
' 5B POP BX
' 58 POP AX
' 5E POP SI
' 5F POP DI
' 89EC MOV SP,BP
' 5D POP BP
' C21000 RETN 00010

ReDim ASMBL(0 To 53) 'Len(ASM) \ 2 - 1
For i = 1 To Len(ASM) - 1 Step 2
ASMBL(j) = Val("&H" & Mid(ASM, i, 2))
j = j + 1
Next i

Dim vCRC32 As Long, vB As Boolean
Const vXor32 As Long = &HEDB88320
For i = 0 To 255
vCRC32 = i
For j = 8 To 1 Step -1
vB = vCRC32 And 1
vCRC32 = ((vCRC32 And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
If vB Then vCRC32 = vCRC32 Xor vXor32
Next j
Table(i) = vCRC32
Next i
End Sub
Private Sub Class_Initialize()
IntAsm
End Sub

method 4:
Code:

Function Crc32_LaVolpe(Buffer() As Byte) As Long
Dim crc32val As Long, i As Long
crc32val = &HFFFFFFFF
For i = 0 To UBound(Buffer)
crc32val = (((crc32val And &HFFFFFF00) \ &H100&) And &HFFFFFF) Xor CRC32Table((crc32val And &HFF) Xor Buffer(i))
Next i
Crc32_LaVolpe = crc32val Xor &HFFFFFFFF
End Function

Attached Images
 

Friend in Class1-VB6 calls multiple methods to run speed test

$
0
0
Optimized for vb6 running speed
call function Fastest c=Bas_Sum(a,b)
call Friend is quick than "public function",The operating speed is 4.6 times faster
-----------
Class_OBJ 452.38 (dim a as class1 ,call a.Sum(**))
Class_Friend_Ptr 70.38
Class_Friend 80.65(call a.FrinedSum)
----------
call objptr like stdcall :cUniversalDLLCalls.CallFunction_COM(***),The operating speed is 1 times faster(up 100%)

Pointer call function address of COM object:
call com dll(activex.dll).FrinedSum(***), Speed increased by 5.6 times
(465.77 pk 70.57)
It takes 827 seconds to call activex.exe, which is 14000 times more than the time to directly call the process

Unfortunately, this seems to be no way. It is like operating the "EXCEL.APPLICATION" object in VB6 and controlling the third-party process of excel.exe. It is very slow. Unless running in EXCEL VBA, it is also about 4 times slower than VB6, but it is slower than ActiveX.EXE with 14,000 times is still much better.
This is just a theoretical number and has not been tested specifically, but calling activex.exe is really slow.
=====================
method1:Friend Function FrinedSum(ByRef a As Long, ByRef b As Long) As Long
method2:Public Function Sum(ByRef a As Long, ByRef b As Long) As Long
method3:Public Function Bas_Sum in moudle.bas
method4:Public Sub BasSub_Sum in moudle.bas

com dll=(class1.cls in comdll1.dll)
actexe=(class1.cls in activex1.exe)
class1.cls in same vb project
call function sum(a,b)
call sub sum(a,b,returnvalue)
The main methods of testing

Code:

TestCount = 1000000*20
Sub Test_Exe1_MySum_object(id As Long)
dim Exe1 as new activex1_exe.Class1
Dim i As Long
For i = 1 To TestCount
    a1 = 3
    b1 = 4
    'Call Exe1_MySum2(ThisExe1, a1, b1, Ret) 'by objptr stdcall
    Ret = Exe1.Sum(a1, b1)
next
end sub

Public Function Bas_Sum(ByRef a As Long, ByRef b As Long) As Long 'method3
 
Bas_Sum = a + b
a = a * a
b = b * b
End Function
Public Sub BasSub_Sum(ByRef a As Long, ByRef b As Long, ByRef Value1 As Long) 'method4
 
Value1 = a + b
a = a * a
b = b * b
End Sub

class1.cls
Code:

Option Explicit
 Public Event Sum2(ByRef id As Long)   

Public Sub Test()
MsgBox "ComDll.lib-test"
End Sub
Public Sub TEST2()
MsgBox "ComDll.lib-test2"
End Sub
Public Function Sum(ByRef a As Long, ByRef b As Long) As Long
 
Sum = a + b
a = a * a
b = b * b
End Function
 
Public Sub test3()
Dim i As Long
Dim v2 As Long
Dim V1 As Long
For i = 1 To 1
V1 = i
v2 = i
 
RaiseEvent Sum2(v2)
 
Next
End Sub
Friend Function FrinedSum(ByRef a As Long, ByRef b As Long) As Long
 
MsgBox "FrinedSum"
FrinedSum = a + b
a = a * a
b = b * b
End Function
Friend Function FrinedSum2(ByRef a As Long, ByRef b As Long) As Long
 
MsgBox "Class_FrinedSum2"
FrinedSum2 = a + b
a = a * a
b = b * b
End Function

Alt+NumPad input for Unicode TextBox with surrogate pair support

$
0
0
When using Alt+NumPad for Unicode input I get a bogus character in Notepad/Notepad++ and all other Unicode TextBox implementations that I tried. WordPad and InkEdit, on the other hand. works OK, including surrogate pairs.

Test summary:
Alt+128512 (&H1F600) WordPad/InkEdit , Notepad/Notepad++/TextBoxW/ucText Nothing
Alt+173569 (&H2A601) WordPad/InkEdit , Notepad/Notepad++TextBoxW/ucText ☺ (&H263A, 9786)
Alt+931 (&H03A3) WordPad/InkEdit Σ , Notepad/Notepad++/TextBoxW/ucText ú (&HFA, 250)

Here is sample code that overrides the internal Alt+NumPad behavior:
1. Assumes you have a subclassed Unicode TextBox with source code that exposes Translate Accelerator.
2, Make sure NumLock is On before testing.
3. Tested with Segoe UI Regular.

Code:

Option Explicit

Private mbDeleteChar As Boolean

Private Function KeyPressed(ByVal KeyCode As KeyCodeConstants) As Boolean
  KeyPressed = CBool((GetAsyncKeyState(KeyCode) And &H8000&) = &H8000&)
End Function

Private Function ToSurrogatePair(ByVal i As Long) As String
  Dim Hi              As Integer, Lo As Integer
  On Error GoTo ErrHandler
  i = i - &H10000
  Hi = i \ &H400 + &HD800
  Select Case Hi
    Case &HD800 To &HDBFF
      Lo = i Mod &H400 + &HDC00
      Select Case Lo
        Case &HDC00 To &HDFFF
          'Debug.Print Hex(Hi), Hex(Lo)
          ToSurrogatePair = ChrW$(Hi) & ChrW$(Lo)
      End Select
  End Select
ErrHandler:
End Function

'Build string in Translate Accelerator WM_SYSKEYDOWN.
Friend Function TranslateAccel(pMsg As Msg) As Boolean
  Static mSysWord  As String
 
    Case WM_SYSKEYDOWN
      If KeyPressed(vbKeyMenu) Then 'Alt Pressed
        Select Case pMsg.wParam
          Case vbKeyNumpad0 To vbKeyNumpad9
            mSysWord = mSysWord & ChrW$(pMsg.wParam - 48)
        End Select
      End If
    Case WM_CHAR
      If Len(mSysWord) Then
        Dim i                As Long
        Dim s                As String
        On Error Resume Next
        i = CLng(mSysWord)
        Select Case i
          Case &HD800& To &HDBFF& 'Skip Reserved
          Case Is <= &HFFFF& '0 - 65535
            s = ChrW$(i)
          Case Is <= &H10FFFF 'Unicode max value
            s = ToSurrogatePair(i)
        End Select
        If Len(s) Then
          SelText = s 'Insert as SelText
          mSysWord = vbNullString 'Reset
          mbDeleteChar = True 'To delete bogus WM_CHAR that Alt+ generated internally.
        End If
        On Error GoTo 0
      End If

'Finally delete the bogus character that appears in WM_CHAR when Alt is released.
myWndProc:
    Case WM_CHAR
      If mbDeleteChar Then
        mbDeleteChar = False
        wParam = 0
      End If

Similar code was tested in Krools TextBoxW (use wParam in lieu pf pMsg.wParam and KeyChar = 0 in WindowProcControl) and it appears to be working OK here. TextBoxW.Zip atttached.

TextBoxW.zip
Attached Files

Vmware Sdk For vb6(VixCOM64.dll),vbs-CreateObject("VixCOM.VixLib")

$
0
0
Need VMWare VIX Automation Tools and SDK

Code:

'Reference
'C:\Windows\SysWOW64\regsvr32.exe ***\VixCOM64.dll
'Reference VixCOM64.dll TO vb6 Project
Dim lib As VixCOM.VixLib
Dim vmPath As String

Private Sub Form_Load()
vmPath = "***/Windows 7.vmx"

' Copyright 2006 VMware, Inc.
' All rights not expressly granted to you by VMware, Inc. are reserved.
'

' VixCOM VBScript Sample Script (powerOn)
'
' This demonstrates how to open a VM, power it on and power it off.
'
' This uses the Wait function to block after starting each
' asynchronous function. This effectively makes the asynchronous
' functions synchronous, because Wait will not return until the
' asynchronous function has completed.
'
' Instructions for Windows 2000 and later operating systems:
'
'  - there should be an accompanying file named 'powerOn.wsf'
'    It is placed in the same directory as this file during
'    product installation. This file is responsible for setting
'    up the Windows Script Host environment and loading the
'    VixCOM type library, thereby enabling this script to
'    reference symbolic constants such as VIX_API_VERSION
'
'  - in a command line window, type:
'    cscript //nologo powerOn.wsf
'
Dim results
'Dim lib
Dim job
Dim host
Dim vm As IVM2
Dim err
Dim useWorkstation
Dim hostType
Dim hostName
Dim hostUsername
Dim hostPassword

Dim poweronOption

' Certain arguments differ when using VIX with VMware Server 2.0 and
' VMware Workstation.
'
' Comment out this line to use this code with VMware Server 2.0.
useWorkstation = 1

If useWorkstation Then
  hostType = VixCOM.Constants.VIX_SERVICEPROVIDER_VMWARE_WORKSTATION '=3
  hostName = Empty
  hostUsername = Empty
  hostPassword = Empty
  'vmPath = "***/Windows 7.vmx"
  poweronOption = VixCOM.Constants.VIX_VMPOWEROP_LAUNCH_GUI '=512
Else
  ' For VMware Server 2.0
  hostType = VixCOM.Constants.VIX_SERVICEPROVIDER_VMWARE_VI_SERVER
  hostName = "https://192.20.30.40:8333/sdk"
  hostUsername = "Administrator"
  hostPassword = "password"
  vmPath = "[standard] winxppro/winxppro.vmx"
  poweronOption = VixCOM.Constants.VIX_VMPOWEROP_NORMAL
End If

Set lib = CreateObject("VixCOM.VixLib")

' Connect to the local installation of Workstation. This also intializes the VIX API.
Set job = lib.Connect(VixCOM.Constants.VIX_API_VERSION, hostType, hostName, 0, hostUsername, hostPassword, 0, Nothing, Nothing)

' results needs to be initialized before it's used, even if it's just going to be overwritten.
Set results = Nothing

' Wait waits until the job started by an asynchronous function call has finished. It also
' can be used to get various properties from the job. The first argument is an array
' of VIX property IDs that specify the properties requested. When Wait returns, the
' second argument will be set to an array that holds the values for those properties,
' one for each ID requested.
err = job.Wait(Array(VixCOM.Constants.VIX_PROPERTY_JOB_RESULT_HANDLE), results)
If err <> 0 Then QuitIfError (err)

' The job result handle will be first element in the results array.
Set host = results(0)

' Open the virtual machine with the given .vmx file.
Set job = host.OpenVM(vmPath, Nothing)
err = job.Wait(Array(VixCOM.Constants.VIX_PROPERTY_JOB_RESULT_HANDLE), results)
If CLng(err) <> 0 Then QuitIfError (err)


Set vm = results(0)
'MsgBox TypeName(vm)


' Power on the virtual machine we just opened. This will launch Workstation if it hasn't
' already been started.
Set job = vm.PowerOn(poweronOption, Nothing, Nothing)
' WaitWithoutResults is just like Wait, except it does not get any properties.
err = job.WaitWithoutResults()
If CLng(err) <> 0 Then QuitIfError (err)
'MsgBox "正在启动,启动完成后,点确定按钮"
MsgBox "Doing Start Vmware virtual machine,When Start Successfull,CLICK OK BUTTON", vbOKOnly

' Here you would do any operations on the guest inside the virtual machine.

' Power off the virtual machine. This will cause Workstation to shut down if it
' was not running previous to the call to PowerOn.
'If MsgBox("是否关闭?", vbYesNo) = vbYes Then
If MsgBox("Do You Want to Close Vmware virtual machine?", vbYesNo) = vbYes Then
Set job = vm.PowerOff(VixCOM.Constants.VIX_VMPOWEROP_NORMAL, Nothing)
err = job.WaitWithoutResults()
If CLng(err) <> 0 Then QuitIfError (err)

host.Disconnect
End If
'MsgBox "测试完成"
MsgBox "TestOk"

End Sub
Sub QuitIfError(errID)
On Error GoTo DoErr
MsgBox "errID:" & CLng(errID)
'  If lib.ErrorIndicatesFailure(err) Then
'      WScript.Echo ("Error: " & lib.GetErrorText(err, Empty))
'      WScript.Quit
'  End If
Exit Sub
DoErr:
MsgBox err.Description
End Sub

VB6 radial Progress-Control

$
0
0
Just another one of these circular Progress-UCs, which recently seem "all the rage" ... ;)

What's different with this one?
- it's really small (only about 80 Lines of Code), so no need to put this into a compiled OCX
- it's entirely GDI-based (just for fun, I've tried to avoid anything "Cairo or GDIPlus")
- it uses a single ChangeSettings-MethodCall ...instead having to set (or implement) a bunch of behaviour-Properties

Here is, what it looks like:


And here's the Zip with the DemoCode:
ucRadialProgress.zip

Have fun,

Olaf
Attached Files

[vb6] Virtual Pet Roach v1.2 (Updated 08/06/20)

$
0
0
Since I see the famouse "sheep.exe" I wanted to create something like a virtual pet... finally 2 decades later I found the time to do it.
This is a cockroach that roam the screen. It run outside the screen when touched with the cursor and if computer is left idle for certain time, start spawning more cockroachs until certain limit.
Animation of every limb and movement is made with detail and looks very realistic.

Also this code can be usefull te see how to interact with the mouse, how to calculate angles, idle detection , creating a systray and draw 8 bits transparency forms (32bpp)

Name:  VirtPet_Snap1.jpg
Views: 155
Size:  15.2 KB
Running wild over desktop windows

Name:  VirtPet_Snap2.jpg
Views: 157
Size:  40.0 KB
Debug movement screen enabled

PD: Also got a cool about screen effect.


Download: prjVirtualPet_v1.2_Src.zip


v1.1 - Memory leak completely fixed!!!!
v1.2 - Fixed display on HighDPI screen

TODO: Multi monitor support
Attached Images
  
Attached Files

mBox Reader

$
0
0
Hi this is a mail message box reader I made to read old usenet message box files. if you want any mail box files you can find a load on wayback machine. with this little app it makes it easyer to read each message. anyway hope you like it.

Name:  logo.jpg
Views: 44
Size:  40.6 KB

Download Source Project:

mBox.zip
Attached Images
 
Attached Files

Text To Picture

$
0
0
Hi
This is a project I made sometime ago, it allows you to encrypt text and save as a bitmap, You can then load the bitmap and with the right encrypt key you used you can decrypt the text.
Hope you find it usfull.

Name:  logo.jpg
Views: 43
Size:  153.9 KB

Download Project
Text2Pic.zip
Attached Images
 
Attached Files
Viewing all 1498 articles
Browse latest View live


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