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

[RESOLVED] Voice Action Program Problems with recognition.

July 27, 2021, 4:14 pm
$
0
0
well i was posting in the wrong area now finally in the correct area i can get an answer here we go:


I'm using Voice Action a 1999 program made in very old vb6 that does voice recognition and records association of wav files with text and voice and pattern in .SAY files I'm trying to create my custom patterns and words but in my visual studio it runs, but when I record audio nothing happens or even open the voice synthesizer screen, analyzing the code I realized that everything is fine and I have no idea how to use VoiceAction I'm trying to use it to record my audios didn't even do that then neither get it see

Name: photo.jpg Views: 209 Size: 30.9 KB

everything is working well here but it does not display the synthesizer editor as it is said in the program's documentation how do I record an audio because it seems this is the only program that will be able to help me in speech recognition by comparing files.

Does anyone know why mine has a problem, I've done everything you can imagine read the document I searched on google modified code but all in vain.

The following synthesizer was supposed to appear:
https://www.vbforums.com/showthread....t=#post5529368

another problem is that the other program that manages the audio files didn't come included, which in this case is .say, so there's no way for me to compare, I'll have to implement everything in this same.

If there is no solution, another recognizer that makes audio file comparisons is welcome.

See the VoiceAction code (download):

https://www.freevbcode.com/ShowCode.asp?ID=2685
Attached Images
 
↧
Search

Extract Styles from HTML as inline CSS

August 4, 2021, 6:32 am
$
0
0
In my project, I had to "clean" HTML that are generated like this
PHP Code:
<table style='margin-left: -.4pt; border-collapse: collapse; table-layout: auto; border: none;'>
    <tbody>
        <tr style='padding: 0cm 3.6pt 0cm 3.6pt;vertical-align: top;'>
            <td style='padding: 0cm 3.6pt 0cm 3.6pt;vertical-align: top;border: solid black 1.0pt;background-color: #E6ECFD;'>
                <p style='line-height: normal; text-autospace: none;padding: 0cm 3.6pt 0cm 3.6pt;text-align: left;'>
                    <strong>Date</strong>
                </p>
            </td>
            <td style='padding: 0cm 3.6pt 0cm 3.6pt;vertical-align: top;border: solid black 1.0pt;background-color: #E6ECFD;'>
                <p style='line-height: normal; text-autospace: none;padding: 0cm 3.6pt 0cm 3.6pt;text-align: left;'>
                    <strong>Infos</strong>
                </p>
            </td>
... 
and having instead of style, CSS.
After some research, I found nothing on the web.

The required result should be something like :
PHP Code:
<style type='text/css'>.s1 {margin-left: -.4pt; border-collapse: collapse; table-layout: auto; border: none;}.s2 {padding: 0cm 3.6pt 0cm 3.6pt;vertical-align: top;}.s3 {padding: 0cm 3.6pt 0cm 3.6pt;vertical-align: top;border: solid black 1.0pt;background-color: #E6ECFD;}.s4 {line-height: normal; text-autospace: none;padding: 0cm 3.6pt 0cm 3.6pt;text-align: left;}.s5 {line-height: normal; text-autospace: none;padding: 0cm 3.6pt 0cm 3.6pt;text-align: right;}.s6 {padding: 0cm 3.6pt 0cm 3.6pt;vertical-align: top;border: solid black 1.0pt;}.s7 {color: #008000;}.s8 {color: #FF0000;}</style>
<table class='s1'>
    <tbody>
        <tr class='s2'>
            <td class='s3'>
                <p class='s4'>
                    <strong>Date</strong>
                </p>
            </td>
            <td class='s3'>
                <p class='s4'>
                    <strong>Infos</strong>
                </p>
            </td>
... 
So I wrote this piece of code to implement it dynamically.
The HTML layout generated is always the same.

PHP Code:
Public Function HTML_Stylus(sHTML As String) As String
   ' #VBIDEUtils#************************************************************
   ' * Author           : xxxx
   ' * Web Site         : xxxx
   ' * E-Mail           : xxxx
   ' * Date             : 08/04/2021
   ' * Time             : 14:00
   ' * Module Name      : HTML_Module
   ' * Module Filename  : HTML.bas
   ' * Procedure Name   : HTML_Stylus
   ' * Purpose          :
   ' * Parameters       :
   ' *                    sHTML As String
   ' * Purpose          :
   ' **********************************************************************
   ' * Comments         :
   ' *
   ' *
   ' * Example          :
   ' *
   ' * See Also         :
   ' *
   ' * History          :
   ' *
   ' *
   ' **********************************************************************

   ' #VBIDEUtilsERROR#
   On Error GoTo ERROR_HTML_Stylus
   
   Dim oXML             As New MSXML2.DOMDocument
   Dim oNodes           As MSXML2.IXMLDOMNodeList
   Dim oNode            As MSXML2.IXMLDOMNode
   
   Dim sXPath           As String
   
   Dim sNewHTML         As String
   Dim sStyle           As String
   Dim sStyleName       As String
   Dim sCSSStyle        As String
   
   Dim oColStyles       As class_Collection
   
   Dim nPos             As String
   
   sNewHTML = sHTML
   sCSSStyle = vbNullString
   
   Set oColStyles = New class_Collection
   
   If oXML.LoadXML(sHTML) Then
      sXPath = "//*[@style]"
      Set oNodes = oXML.selectNodes(sXPath)

      For Each oNode In oNodes
         sStyle = Trim$(XML_GetAttribute(oNode, "style"))
         If Not oColStyles.KeyExists(sStyle) Then
            sStyleName = "s" & oColStyles.ItemCount + 1
            sCSSStyle = sCSSStyle & "." & sStyleName & " {" & sStyle & "}"
            sNewHTML = Replace(sNewHTML, "style='" & sStyle & "'", "class='" & sStyleName & "'")
            oColStyles.AddItem sCSSStyle, sStyle
         End If
      Next
      
      If LenB(sCSSStyle) > 0 Then
         sNewHTML = "<style type='text/css'>" & sCSSStyle & "</style>" & sNewHTML
      End If
   End If

EXIT_HTML_Stylus:
   On Error Resume Next
   
   Set oXML = Nothing

   Set oColStyles = Nothing
   
   HTML_Stylus = sNewHTML

   Exit Function

   ' #VBIDEUtilsERROR#
ERROR_HTML_Stylus:
   Select Case IAErrorHandler(gcError & Err.Number & ": " & Err.Description & vbCrLf & "in HTML_Module.HTML_Stylus" & vbCrLf & gcErrorLine & Erl, vbAbortRetryIgnore + vbCritical, "Error")
   Case vbAbort
      Screen.MousePointer = vbDefault
      Resume EXIT_HTML_Stylus
   Case vbRetry
      Resume
   Case vbIgnore
      Resume Next
   End Select
   
   Resume EXIT_HTML_Stylus

End Function 
NB : Class_Collection is an enhanced collection. It could be replaced by something else.

I think it could be optimised, but, this will be for later, if you want to enhance it, post here.
↧
↧

vb6 cannot write Greek in code module

August 5, 2021, 12:52 am
$
0
0
Hi all .

All of a sudden l cannot write Greek in code module when working on a project .
Greek language and Greek keyboard are of course installed , and had no problem
God knows for how many years .
The trouble is that in designing mode works fine l can name a label caption in
Greek or writing in a textbox or whatever even here (αβγδε) .

Any ideas please ....
↧

UTF-8 Demo

August 5, 2021, 9:54 am
$
0
0
Attached is a UTF-8 demo of several Unicode samples; ASCII, Spanish, Japanese, Chinese, & Hebrew. UTF-8 byte arrays are converted to Unicode strings and back again. An InkEdit Control is utilized in order to display the Unicode samples.

Be advised that an unexplained glitch occurs when reversing the Hebrew sample. This demo is based on one by DI Management.

J.A. Coutts

Updated: 08/05/2021
Attached Files
↧

RGB TO LONG,Long to rgb-vb6

August 6, 2021, 8:32 am
$
0
0
Code:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Type LongType
    longV As Long
End Type
Private Type RGBN
    R As Byte
    G As Byte
    b As Byte
    N As Byte
End Type

Private Sub Form_Load()
    Dim RGBN1 As RGBN
    Dim Long1T As LongType
    Dim Long2T As LongType
    Long1T.longV = RGB(11, 22, 33)
    LSet RGBN1 = Long1T
    LSet Long2T = RGBN1
    MsgBox "Long1=" & Long1T.longV & vbCrLf _
        & RGBN1.R & "," & RGBN1.G & "," & RGBN1.b & vbCrLf _
        & Long2T.longV
End Sub

Sub TEST2()
    Dim Long1 As Long, RGBN1 As RGBN, Long2 As Long
    Long1 = RGB(11, 22, 33)
   
    CopyMemory RGBN1, Long1, 4
   
    CopyMemory Long2, RGBN1, 4
    MsgBox "Long1=" & Long1 & vbCrLf _
    & RGBN1.R & "," & RGBN1.G & "," & RGBN1.b & vbCrLf _
    & "Long2=" & Long2
End Sub
↧
↧

VB6 Slider usercontrol with Range

August 7, 2021, 7:33 am
$
0
0
Can someone please help me with the math to handle Value1 and Value2 properties. For some reason I can't get my head around the math to make it work right. Thanks in advance for any help. UPDATE: Its not perfect and maybe its not pretty ,but here is my best shot at this control.
Attached Images
 
Attached Files
↧

VB6-Adodc1.Recordset.ActiveConnection.Execute Sql

August 11, 2021, 6:16 am
$
0
0
Code:
Adodc1.ConnectionString = "provider=microsoft.jet.oledb.4.0;data source=" & App.Path & "\test.mdb"
Adodc1.RecordSource = "select * from usertable"
Adodc1.Refresh

Adodc1Execute "UPDATE Usertable SET Usertable.[Password] = 'abc2" & Now & "' WHERE UserName='user1'"

Function Adodc1Execute(Sql As String)
'On Error GoTo err
    Adodc1.Recordset.ActiveConnection.Execute Sql
 
    Adodc1.Recordset.ActiveConnection.Close
    Adodc1.Refresh

'    Adodc1.Refresh
'    DataGrid1.Refresh
'    Adodc1.Refresh
    Exit Function
err:
    MsgBox err.Description
End Function
↧

VB6 Flood Fill Art

August 13, 2021, 4:56 pm
$
0
0
Just something I threw together. All its good for is to pass the time. Add your own patterns and color away.
Attached Images
 
Attached Files
↧
Search

VB6 Message Box Control

August 15, 2021, 6:14 am
$
0
0
This is my version of a beat to death message box. What I'd like to know is if it is usable for you . I've lightly tested it and it seems okay , but does it function alright as a usercontrol or should I re-do it on a separate form all its own ?
Attached Images
 
Attached Files
↧
↧

VB6 Capture Pixel from Screen

August 17, 2021, 12:18 pm
$
0
0
Gets the pixel color from desktop. Can keep up to 5 colors per session. I find it very helpful when creating graphics for my apps.
Give it a try. Enjoy. (please no comments on this or the world will come to an end. haha)
Attached Images
 
Attached Files
↧

VB6 Project Folder Creator

August 18, 2021, 8:01 am
$
0
0
This will create and add a project folder with selected sub folders(Usercontrol,Classes,Modules,etc).
Attached Images
 
Attached Files
↧

VB6 Locks up at breakpoint in Windows 10

August 19, 2021, 12:16 pm
$
0
0
I've got VB6 installed and running in Windows 10 after following some tips.

Unfortunately, it doesn't behave right.

For example, when I set a BREAKPOINT and then RUN the app, it stops at the breakpoint, highlights it normally, but then I can't do anything else. It just 'dings' whenever I click on something.

I've set compatibility to XP, win7, and Run as Admin with no success.

I also notice the Inspect window opens in another monitor (I have 3 monitor setup).

Any suggestions?

TIA
↧

PicServer as Service

August 20, 2021, 10:34 am
$
0
0
PicServer has been made into a service. It is quite a bit more complex than the original, and is called PicSvc.

PicSvc requires the use of NTSVC.ocx. To allow some trouble shooting in the IDE, PicSvc can be run as a Desktop application as well. To create the service, change the IsService flag to true and compile as PicSvc.exe. Although PicSvc.exe can be installed/unistalled by running with a command line extension of /I or /U, you will need to setup some parameters. To accomplish this, a seoond program is required called PicSvcCtrl (prjInterface.vbp), which allows you to install, uninstall, setup, and start the service. The password maintenance portion is not functional yet. The thing to remember is that registry values for any service are automatically deleted when a service is uninstalled, and that the service must be stopped before it can be uninstalled. Also, PicSvc.exe must be in the same directory as PicSvCtrl.

After installing the service, run Setup. The second time around, the default settings will be borrowed from the Desktop version, but will get recreated for the service version.

Errors, connects, disconnects, and file access are logged to a daily logfile. When operating as a service, you will need a directory to serve as a location for the logfiles. A service needs a directory that is accessible to all users, and that is relegated to the "\Windows\System32\LogFiles\service" directory.

One important thing to remember about a service is that there can be no output to the screen, as it operates in session 0 with system privileges, and continues to operate even if you are logged off.

J.A. Coutts
Attached Files
↧
↧

System Wide Got/Lost Focus (subclassing)

August 20, 2021, 10:50 am
$
0
0
This is just a small example of how one might accomplish system wide GotFocus and LostFocus events in VB6.

The way it's setup, it's fairly IDE safe. With the Comctl32 subclassing, there are only two cases that crash the IDE: 1) when you click the "End" button when you get a runtime error, and 2) when you use the IDE's "Stop" button while a modal form is showing. If you've got no modal forms, the IDE's stop button is safe.

Here's the code that must be placed in a BAS module:

Code:

Option Explicit
'
Private Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
'
Private Declare Function vbaObjSetAddref Lib "msvbvm60.dll" Alias "__vbaObjSetAddref" (ByRef dstObject As Any, ByRef srcObjPtr As Any) As Long
'

Public Function SubclassForSystemFocus(frm As Form) As Long
    SubclassForSystemFocus = SetWindowSubclass(frm.hWnd, AddressOf ProcForSystemFocus, frm.hWnd, ObjPtr(frm))
End Function

Public Function UnSubclassForSystemFocus(hWnd As Long) As Long
    UnSubclassForSystemFocus = RemoveWindowSubclass(hWnd, AddressOf ProcForSystemFocus, hWnd)
End Function

Public Function ProcForSystemFocus(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
    Const WM_DESTROY          As Long = &H2&
    Const WM_SETFOCUS          As Long = &H7&
    Const WM_KILLFOCUS        As Long = &H8&
    '
    Dim frm As VB.Form                              ' Used for our form's temporary "object" reference.
    '
    Select Case uMsg
    Case WM_DESTROY
        UnSubclassForSystemFocus hWnd
    Case WM_SETFOCUS                                ' Did our form just GET the focus?
        On Error Resume Next                        ' This prevents the IDE from crashing if the GotFocusSystemWide procedure doesn't exist.
            vbaObjSetAddref frm, ByVal dwRefData    ' Get an object reference for our form.
            frm.GotFocusSystemWide                  ' Call our form's GotFocusSystemWide event, or let error handling do its thing.
        On Error GoTo 0
    Case WM_KILLFOCUS                              ' Did our form just LOSE the focus?
        On Error Resume Next                        ' This prevents the IDE from crashing if the LostFocusSystemWide procedure doesn't exist.
            vbaObjSetAddref frm, ByVal dwRefData    ' Get an object reference for our form.
            frm.LostFocusSystemWide                ' Call our form's LostFocusSystemWide event, or let error handling do its thing.
        On Error GoTo 0
    End Select
    ProcForSystemFocus = DefSubclassProc(hWnd, uMsg, wParam, lParam)
End Function


And here's a small test for any form:

Code:

Option Explicit

Private Sub Form_Load()
    SubclassForSystemFocus Me  ' No need to unsubclass, as it's done automatically.
End Sub



Public Sub GotFocusSystemWide()
    Debug.Print "I've got the focus."


    ' DON'T put any other user-interface in here, or you may create a perpetual loop.
    ' You're still basically in the subclass procedure when you're in here.


End Sub

Public Sub LostFocusSystemWide()
    Debug.Print "I've lost the focus."


    ' DON'T put any other user-interface in here, or you may create a perpetual loop.
    ' You're still basically in the subclass procedure when you're in here.


End Sub


Notice that the GotFocusSystemWide/LostFocusSystemWide events must be declared as Public. This is true because of the late-binding of the form object in the subclass procedure.

-----------

And hey, if someone wants to rework this with one of the "completely IDE safe" thunks, that'd be absolutely fine with me.
↧

InputBox With Password mask,Get screen coordinate position of the input box

August 21, 2021, 6:53 am
$
0
0
You can specify the display position of the input dialog or message box when it starts.
After manually moving to the new position, the last position will be remembered, and the new dialog box will be displayed in the same coordinate position.

Code:
Private Sub Form_Load()
InputX = 300 * Screen.TwipsPerPixelX
InputY = 500 * Screen.TwipsPerPixelY
End Sub

Private Sub Command1_Click()
  Dim S As String
  S = InputboxXY("Please Input Your Password", , True, "Tip Info", InputX, InputY)
  MsgBox "S=" & S
End Sub

Code:
Public InputX As Long, InputY As Long
Dim PassMode As Boolean
Dim FindInput As Boolean, InputTitle As String
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Dim lngTimerID As Long
Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Const EM_SETPASSWORDCHAR = &HCC

Function InputboxXY(Optional Title As String, Optional Default As String, Optional PassModeA As Boolean, Optional Prompt As String, Optional XPos, Optional YPos)
    If Title = "" Then Title = App.Title
    InputTitle = Title
    FindInput = False
    PassMode = PassModeA
    lngTimerID = SetTimer(0, 0, 15, AddressOf TimerProc)
    If InputX > 0 Then XPos = InputX: YPos = InputY
    If IsMissing(XPos) Then
            InputboxXY = InputBox(Prompt, Title, Default)
    Else
            InputboxXY = InputBox(Prompt, Title, Default, XPos, YPos)
    End If
End Function
Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    Static Rect1 As RECT
    Dim win As Long, InputHwd As Long
    win = FindWindow(vbNullString, InputTitle)
    If win > 0 Then
            If IsWindowVisible(win) Then
                    If FindInput = False Then
                        FindInput = True
                        If PassMode Then
                              InputHwd = FindWindowEx(win, 0, "edit", vbNullString)
                              SendMessage InputHwd, EM_SETPASSWORDCHAR, 42, 0
                        End If
                    End If
                    GetWindowRect win, Rect1
        End If
  ElseIf FindInput Then
            KillTimer 0, lngTimerID
            InputX = Rect1.Left * Screen.TwipsPerPixelX
            InputY = Rect1.Top * Screen.TwipsPerPixelY
    End If
End Sub
↧
Search

Adjust the size of the borderless window-VB6

August 24, 2021, 10:48 pm
$
0
0
Code:
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTLEFT = 10
Private Const HTRIGHT = 11
Private Const HTTOP = 12
Private Const HTBOTTOM = 15
Private Const HTBOTTOMRIGHT = 17
Private Const HTBOTTOMLEFT = 16
Private Const HTTOPLEFT = 13
Private Const HTTOPRIGHT = 14
'sendmessage函数声明
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private intEdge As Integer '临界距离，鼠标在离边框距离小于等于该值则判定在边框上……
Private Sub Form_Load()
'相当于三个象素
intEdge = Me.ScaleX(3, vbPixels, Me.ScaleMode)
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Critical:将处理四角的代码放在前面
If X + intEdge >= ScaleWidth And Y + intEdge >= ScaleHeight Then '右下角
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTBOTTOMRIGHT, 0
ElseIf Y + intEdge >= ScaleHeight And X <= intEdge Then '左下角
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTBOTTOMLEFT, 0
ElseIf Y <= intEdge And X <= intEdge Then '左上角
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTTOPLEFT, 0
ElseIf Y <= intEdge And X + intEdge <= ScaleWidth Then '右上边
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTTOPRIGHT, 0
ElseIf X + intEdge >= ScaleWidth And Y <= ScaleHeight Then '右边
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTRIGHT, 0
ElseIf Y + intEdge >= ScaleHeight And X <= ScaleWidth Then '下边
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTBOTTOM, 0
ElseIf X <= intEdge And Y <= ScaleHeight Then '左边
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTLEFT, 0
ElseIf Y <= intEdge And X <= ScaleWidth Then '上边
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTTOP, 0
End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Critical:将处理四角的代码放在前面
Label1.Caption = X & " " & Y
If (X + intEdge >= ScaleWidth And Y + intEdge >= ScaleHeight) Or (Y <= intEdge And X <= intEdge) Then '右下\左上角
MousePointer = vbSizeNWSE
ElseIf Y + intEdge >= ScaleHeight And X <= intEdge Or Y <= intEdge And X + intEdge <= ScaleWidth Then '左下\右上角
MousePointer = vbSizeNESW
ElseIf X + intEdge >= ScaleWidth And Y <= ScaleHeight Or X <= intEdge And Y <= ScaleHeight Then '左、右
MousePointer = vbSizeWE
ElseIf Y + intEdge >= ScaleHeight And X <= ScaleWidth Or Y <= intEdge And X <= ScaleWidth Then '上边下边
MousePointer = vbSizeNS
Else
MousePointer = vbNormal
End If
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
SetCapture hwnd
End Sub
↧

VB6 Flip Digit Style Clock from the 70's

August 26, 2021, 1:45 pm
$
0
0
Very simple clock code with the graphics that look similar to the flip digit clocks from the 70's . Added the date just for grins
Attached Images
 
Attached Files
↧
↧

Get Library Name by Com DLL with vb6

August 27, 2021, 6:55 pm
$
0
0
HOW to get Library Name by Com DLL with vb6?

from : Library info.-VBForums
https://www.vbforums.com/showthread....6-Library-info

Library Excel
c:\***\Office16\EXCEL.EXE
Microsoft Excel 16.0 Object Library

Library VSFlex8Ctl
C:\Program Files (x86)\Microsoft Visual Basic 6.0\v8.oca
ComponentOne VSFlexGrid 8.0 (OLEDB)

i used v8.ocx(VSFlexGrid),but why vb6 com typeinfo tool show:v8.oca??

Code:


'need Reference=*\G{3181A65A-CC39-4CDE-A4DF-2E889E6F1AF1}#1.51#0#olelib1.81.tlb#Edanmo's OLE interfaces & functions v1.81

Dim Path As String
 Path = "C:\Program Files (x86)\Microsoft Visual Basic 6.0\v8.ocx"

    Dim locLib      As ITypeLib
    Dim Name        As String
    Dim Desc        As String
 
    On Error Resume Next
    Set locLib = LoadTypeLibEx(Path, REGKIND_NONE)


    If Err.Number Then Err.Clear: Exit Sub
    On Error GoTo 0

    locLib.GetDocumentation -1, Name, Desc, 0, vbNullString

    InputBox "", "", Name & " (" & Desc & ")"
' my result=VSFlex8 (ComponentOne VSFlexGrid 8.0 (OLEDB))
why vb6 show (Library VSFlex8Ctl)?
--------------------------------
need Reference=*\G{3181A65A-CC39-4CDE-A4DF-2E889E6F1AF1}#1.51#0#olelib1.81.tlb#Edanmo's OLE interfaces & functions v1.81

Object={BEEECC20-4D5F-4F8B-BFDC-5D9B6FBDE09D}#1.0#0; v8.ocx
Reference=*\G{00020813-0000-0000-C000-000000000046}#1.9#0#**\Office16\EXCEL.EXE#Microsoft Excel 16.0 Object Library
Reference=*\G{3181A65A-CC39-4CDE-A4DF-2E889E6F1AF1}#1.51#0#olelib1.81.tlb#Edanmo's OLE interfaces & functions v1.81

How is the reference part of the project file generated with code?


VSflexgrid8.oca
Library:VSFlex8Ctl (ComponentOne VSFlexGrid 8.0 (OLEDB))

VSflexgrid88.ocx
Library:VSFlex8 (ComponentOne VSFlexGrid 8.0 (OLEDB))
(VSflexgrid8.ocx There is no event list, VSflexgrid8.oca has 2 sets of event objects，_iVSFlexgridEvents,_Event0）
↧

vb6 everything SDK,quick Search file for vb6,vba

August 2, 2021, 8:33 pm
$
0
0
Need Run EveryThing.exe First !

it's support x64 everything.exe,but un suppot about:Lite version
Download Portable Zip 64-bit,it's only 2 files,it's funny
(Everything.exe,Everything.lng),it's support ipc, VB6 Everything SDK


'Note: sample copied from https://www.voidtools.com/support/ev.../visual_basic/
https://www.voidtools.com/Everything-SDK.zip

Everything-SDK\dll\Everything32.dll
vb6 sdk
Code:
'it's VB6 Everything SDK

'VB.net and the Everything SDK - voidtools forum
'https://www.voidtools.com/forum/viewtopic.php?f=10&t=5550
Option Explicit

Public Declare Function Everything_SetSearchA Lib "Everything32.dll" (ByVal ins As String) As Long
Public Declare Function Everything_QueryA Lib "Everything32.dll" (ByVal bWait As Long) As Long

Public Declare Function Everything_SetSearchW Lib "Everything32.dll" (ByVal ins As Long) As Long

Public Declare Function Everything_SetRequestFlags Lib "Everything32.dll" (ByVal dwRequestFlags As Long) As Long
Public Declare Function Everything_QueryW Lib "Everything32.dll" (ByVal bWait As Long) As Long
Public Declare Function Everything_GetNumResults Lib "Everything32.dll" () As Long
Public Declare Function Everything_GetResultFileNameW Lib "Everything32.dll" (ByVal index As Long) As Long
Public Declare Function Everything_GetLastError Lib "Everything32.dll" () As Long
Public Declare Function Everything_GetResultFullPathNameW Lib "Everything32.dll" (ByVal index As Long, ByVal ins As Long, ByVal size As Long) As Long
Public Declare Function Everything_GetResultSize Lib "Everything32.dll" (ByVal index As Long, ByRef size As Long) As Long          'size UInt64
Public Declare Function Everything_GetResultDateModified Lib "Everything32.dll" (ByVal index As Long, ByRef ft As Long) As Long    'ft UInt64

Public Const EVERYTHING_REQUEST_FILE_NAME = &H1
Public Const EVERYTHING_REQUEST_PATH = &H2
Public Const EVERYTHING_REQUEST_FULL_PATH_AND_FILE_NAME = &H4
Public Const EVERYTHING_REQUEST_EXTENSION = &H8
Public Const EVERYTHING_REQUEST_SIZE = &H10
Public Const EVERYTHING_REQUEST_DATE_CREATED = &H20
Public Const EVERYTHING_REQUEST_DATE_MODIFIED = &H40
Public Const EVERYTHING_REQUEST_DATE_ACCESSED = &H80
Public Const EVERYTHING_REQUEST_ATTRIBUTES = &H100
Public Const EVERYTHING_REQUEST_FILE_LIST_FILE_NAME = &H200
Public Const EVERYTHING_REQUEST_RUN_COUNT = &H400
Public Const EVERYTHING_REQUEST_DATE_RUN = &H800
Public Const EVERYTHING_REQUEST_DATE_RECENTLY_CHANGED = &H1000
Public Const EVERYTHING_REQUEST_HIGHLIGHTED_FILE_NAME = &H2000
Public Const EVERYTHING_REQUEST_HIGHLIGHTED_PATH = &H4000
Public Const EVERYTHING_REQUEST_HIGHLIGHTED_FULL_PATH_AND_FILE_NAME = &H8000

Public Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Public Type SYSTEMTIME
    wYear As Long
    wMonth As Long
    wDayOfWeek As Long
    wDay As Long
    wHour As Long
    wMinute As Long
    wSecond As Long
    wMilliseconds As Long
End Type

Private Declare Function FileTimeToSystemTime Lib "kernel32" (ByRef ft As Long, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function SystemTimeToTzSpecificLocalTime Lib "kernel32" (ByVal tzi As Long, lpst As SYSTEMTIME, lplt As SYSTEMTIME) As Long
Private Declare Function SystemTimeToVariantTime Lib "OLEAUT32.DLL" (lpSystemTime As SYSTEMTIME, vtime As Date) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Function CheckEverythingRunning() As Boolean
    Dim FindOK As Boolean
    Dim Hwnd As Long
    Hwnd = FindWindow("EVERYTHING", "Everything")
    CheckEverythingRunning = Hwnd <> 0
End Function
Sub SimpleTest()
If Not CheckEverythingRunning Then
 Debug.Print "Please check Everything Is Running"
Exit Sub
End If
    Dim EyText As String
    Dim test As Boolean
    EyText = "Everything"
  Call Everything_SetSearchW(StrPtr(EyText))
    'Call Everything_SetSearchA(EyText)
   
    Everything_SetRequestFlags (EVERYTHING_REQUEST_FILE_NAME Or EVERYTHING_REQUEST_PATH Or EVERYTHING_REQUEST_SIZE Or EVERYTHING_REQUEST_DATE_MODIFIED)
    test = Everything_QueryW(True)
    'test = Everything_QueryA(True)
    If Not test Then
        Debug.Print "Search Err:Please check Everything Is Running"
        Exit Sub
    End If

    Dim NumResults As Long
    Dim i As Long
    Dim filename2 As String
    Dim filesize As Long
    Dim size As Long
    Dim ftdm As Long
    Dim stdm As SYSTEMTIME
    Dim ltdm As SYSTEMTIME
    Dim DateModified As Date
    Dim ID As Long
 

    NumResults = Everything_GetNumResults()
    Debug.Print "Find FILES:" & NumResults
    filename2 = String(260, 0)
 
    If NumResults > 0 Then
        For i = 0 To NumResults - 1
            test = Everything_GetResultFullPathNameW(i, StrPtr(filename2), 260)
            ID = InStr(filename2, Chr(0))
            If ID > 0 Then
            FileName = Left(filename2, ID - 1)
            Else
            FileName = filename2
            End If
           
            test = Everything_GetResultSize(i, size)

           
            test = Everything_GetResultDateModified(i, ftdm)
            test = FileTimeToSystemTime(ftdm, stdm)
            test = SystemTimeToTzSpecificLocalTime(0, stdm, ltdm)
            test = SystemTimeToVariantTime(ltdm, DateModified)
            Debug.Print DateModified & "//" & size & "//" & FileName
        Next
    End If
End Sub

x64 vba sdk:
Code:
'Replaced for VBA usage
' - UINT32 with LONG
' - UINT64 with LONGLONG
' - INTPtr with LONGPtr
' - System.Text.StringBuilder with String
' - System.DateTime with String
' - filename.Capacity with filesize

Public Declare PtrSafe Function Everything_SetSearchW Lib "C:\SDK\Everything64.dll" (ByVal ins As LongPtr) As Long
Public Declare PtrSafe Function Everything_SetRequestFlags Lib "C:\SDK\Everything64.dll" (ByVal dwRequestFlags As Long) As Long
Public Declare PtrSafe Function Everything_QueryW Lib "C:\SDK\Everything64.dll" (ByVal bWait As Integer) As Integer
Public Declare PtrSafe Function Everything_GetNumResults Lib "C:\SDK\Everything64.dll" () As Long
Public Declare PtrSafe Function Everything_GetResultFileNameW Lib "C:\SDK\Everything64.dll" (ByVal index As Long) As LongPtr
Public Declare PtrSafe Function Everything_GetLastError Lib "C:\SDK\Everything64.dll" () As Long
Public Declare PtrSafe Function Everything_GetResultFullPathNameW Lib "C:\SDK\Everything64.dll" (ByVal index As Long, ByVal ins As LongPtr, ByVal size As Long) As Long
Public Declare PtrSafe Function Everything_GetResultSize Lib "C:\SDK\Everything64.dll" (ByVal index As Long, ByRef size As LongLong) As Integer        'size UInt64
Public Declare PtrSafe Function Everything_GetResultDateModified Lib "C:\SDK\Everything64.dll" (ByVal index As Long, ByRef ft As LongLong) As Integer  'ft UInt64

Public Const EVERYTHING_REQUEST_FILE_NAME = &H1
Public Const EVERYTHING_REQUEST_PATH = &H2
Public Const EVERYTHING_REQUEST_FULL_PATH_AND_FILE_NAME = &H4
Public Const EVERYTHING_REQUEST_EXTENSION = &H8
Public Const EVERYTHING_REQUEST_SIZE = &H10
Public Const EVERYTHING_REQUEST_DATE_CREATED = &H20
Public Const EVERYTHING_REQUEST_DATE_MODIFIED = &H40
Public Const EVERYTHING_REQUEST_DATE_ACCESSED = &H80
Public Const EVERYTHING_REQUEST_ATTRIBUTES = &H100
Public Const EVERYTHING_REQUEST_FILE_LIST_FILE_NAME = &H200
Public Const EVERYTHING_REQUEST_RUN_COUNT = &H400
Public Const EVERYTHING_REQUEST_DATE_RUN = &H800
Public Const EVERYTHING_REQUEST_DATE_RECENTLY_CHANGED = &H1000
Public Const EVERYTHING_REQUEST_HIGHLIGHTED_FILE_NAME = &H2000
Public Const EVERYTHING_REQUEST_HIGHLIGHTED_PATH = &H4000
Public Const EVERYTHING_REQUEST_HIGHLIGHTED_FULL_PATH_AND_FILE_NAME = &H8000

Public Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Public Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Private Declare PtrSafe Function FileTimeToSystemTime Lib "kernel32" (ByRef ft As LongLong, lpSystemTime As SYSTEMTIME) As Long
Private Declare PtrSafe Function SystemTimeToTzSpecificLocalTime Lib "kernel32" (ByVal tzi As LongPtr, lpst As SYSTEMTIME, lplt As SYSTEMTIME) As Long
Private Declare PtrSafe Function SystemTimeToVariantTime Lib "OLEAUT32.DLL" (lpSystemTime As SYSTEMTIME, vtime As Date) As Long

Sub SimpleTest()
    Dim EyText As String
    Dim test As Boolean
    EyText = "Everything"
    Everything_SetSearchW (StrPtr(EyText))
    Everything_SetRequestFlags (EVERYTHING_REQUEST_FILE_NAME Or EVERYTHING_REQUEST_PATH Or EVERYTHING_REQUEST_SIZE Or EVERYTHING_REQUEST_DATE_MODIFIED)
    test = Everything_QueryW(True)
    Debug.Print test

    Dim NumResults As Long
    Dim i As Long
    Dim filename As String
    Dim filesize As Long
    Dim size As LongLong
    Dim ftdm As LongLong
    Dim stdm As SYSTEMTIME
    Dim ltdm As SYSTEMTIME
    Dim DateModified As Date

    filename = String(260, 0)

    NumResults = Everything_GetNumResults()
    Debug.Print NumResults

    If NumResults > 0 Then
        For i = 0 To NumResults - 1
            test = Everything_GetResultFullPathNameW(i, StrPtr(filename), 260)
            Debug.Print filename
           
            test = Everything_GetResultSize(i, size)
            Debug.Print size
           
            test = Everything_GetResultDateModified(i, ftdm)
            test = FileTimeToSystemTime(ftdm, stdm)
            test = SystemTimeToTzSpecificLocalTime(0, stdm, ltdm)
            test = SystemTimeToVariantTime(ltdm, DateModified)
            Debug.Print DateModified
        Next
    End If
End Sub
↧

VB6 Rolling3Digits BitBlt

August 29, 2021, 4:28 pm
$
0
0
Just threw this together to have something to do . Does'nt really do much, but looks neat. It can only display numbers not add or subtract. Maybe someone will find something useful in it. Maybe even make it actually add and subtract.
Attached Images
 
Attached Files
↧
Viewing all 1492 articles
Browse latest View live
Search
<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>