Quantcast
Channel: VBForums

Please Reset With ElRuffsta

0
0
Sometimes, relationships start off poorly, and that has been the case with ElRuffsta. After a lengthy discussion with him, he has asked, and I am asking, that everybody agree to start over. It isn't necessarily easy to leave behind past relationships. People usually abandon things that don't work out initially. In this case, ElRuffsta was not willing to abandon, but wanted to improve the relationship. I respect that, and I'm asking everybody else to do so, as well.

Whatever issues you've had in the past, please leave them there. Start fresh, and we'll see where this goes.

VS 2022 Problem with MemoryStream working on second attempt

0
0
Greetings

I'm having trouble using a MemoryStream to display an image bytearray to a picturebox. It works well the first time, but all subsequent attempts throw an exception "Parameter is not valid" with no further information.

Code:

Public Class Form_Main

    Private PreviewArray() As Byte
.
.
    Private Function PreviewImage() As Boolean
.
            ReDim PreviewArray(PreviewLength)

            ' The PreviewArray is then loaded with image byte data
            ' from another source within the application. This works fine.

            ' This line throws an error on second attempt
            Form_ImagePreview.Pic_Preview.Image = ByteToImage(PreviewArray)

    End Function

    Private Function ByteToImage(byteArray As Byte()) As Image

        Dim ms As New MemoryStream(byteArray)
        Dim returnImage As Image = Image.FromStream(ms)
        Return returnImage
        ms.Dispose()

    End Function

End Class



Public Class Form_ImagePreview

    Private Sub Btn_ImgPreviewClose_Click(sender As Object, e As EventArgs) Handles Btn_ImgPreviewClose.Click

        Pic_Preview.Image = Nothing
        Me.Close()

    End Sub


End Class


I've tried all variety of code to declare and dispose of the bytearray and the memorystream with no success.

If you have any suggestions on how to resolve this problem, it would be greatly appreciated.

GUID/CLSID/UUID Comparison API?

0
0
I know how to get the GUID type from a GUID string and vice versa.
If I have a lot of GUIDS (in an array or similar) there is very resource consuming to check every one against each other.
Is there any API that can deal with this matter? I do only find comparing macros in the MSDN describing this.
This is just an example how I think.
Public Declare Function IsEqualGuid Lib "ole32.dll" (pguid1 As Any, pguid2 As Any) As Long
With a BOOL return.

Cheers :wave:

VB6 - Add/Modify UDTs (User Defined Types) to/from a VB6 Collection (No ActiveX DLL)

0
0
Having recently encountered (again) this ancient issue of trying to add UDTs to a VB6 Collection, I have decided to take another look at it. There are several existing methods to tackle this problem which include converting the UDT into a Class, creating an in-memory TypeLib for the UDT, serialize the UDT into a byte array, declare the UDT in a Public Class from an ActiveX DLL and possibly others.

As it turns out, just by adding a measly 8 bytes to each UDT, you can easily convince VB6 that your UDT is in fact an object and it will happily add it "as is" to any collection. Just declare your desired UDT in a BAS module and manage it through a Public Property Get/Let. The UDT can contain members of any type (numeric, strings (fixed or variable length), static or dynamic arrays, objects, other UDTs, etc):

Code:

Public Type UDT
    ID As Long
    Value As Currency
    Date As String
    Year As String * 4
    ByteArray() As Byte
    Picture As IPicture
    DummyClass As New cDummy
End Type

Public Property Get CollectionItem - Retrieve an UDT stored in the collection

Public Property Let CollectionItem - Update an UDT from the collection

Public Sub CollectionAdd - add a new UDT to the collection

frmCollectionUDT form. Just click on the form to print and modify UDTs from the collection:
Code:

Option Explicit

Private Sub PrintItem(tUDT As UDT)
    With tUDT
        Debug.Print .ID, .Value, StrConv(.ByteArray, vbUnicode), .Year, TypeName(.Picture), .DummyClass.ID, .Date
    End With
End Sub

Private Sub Form_Click()
Dim tUDT As UDT, i As Long
    i = Rand(1, 20)
    tUDT = CollectionItem(i, tUDT): PrintItem tUDT ' Retrieve an UDT from the collection and print the values of its members
    With tUDT
        If .Value > 0 Then
            .Value = -.Value
            .Date = "This date has been reset!"
            .Year = "NULL"
            .ByteArray = StrConv(.Year, vbFromUnicode)
            Set .Picture = Nothing
            .DummyClass.ID = -.ID
          CollectionItem(i, tUDT) = tUDT ' Update the collection with the modified UDT
        End If
    End With
End Sub

Private Sub Form_Load()
Dim tUDT As UDT, i As Long
    Randomize
    For i = 1 To 20
        With tUDT
            .ID = i
            .Value = 10000 * Rnd
            .Date = Format$(DateSerial(Rand(1970, 2024), Rand(1, 12), Rand(1, 31)), "dddd, mmmm dd yyyy")
            .Year = Right$(.Date, 4)
            .ByteArray = StrConv(UCase$(Left$(.Date, InStr(.Date, ",") - 1)), vbFromUnicode)
            Set .Picture = Icon
            .DummyClass.ID = i
        End With
        CollectionAdd tUDT ' Create a new UDT with random values and add it to the collection
    Next i
End Sub

Private Function Rand(lMin As Long, lMax As Long) As Long
    Rand = Int((lMax - lMin + 1) * Rnd + lMin)
End Function

mdlCollectionUDT BAS module:
Code:

Option Explicit

Private Type VTable
    VTable(0 To 2) As Long
End Type

Public Type UDT
    ID As Long
    Value As Currency
    Date As String
    Year As String * 4
    ByteArray() As Byte
    Picture As IPicture
    DummyClass As New cDummy
End Type

Private Type ObjectUDT
    pVTable As Long
    RefCount As Long
    tUDT As UDT
End Type

Private Declare Sub CopyBytesZero Lib "msvbvm60" Alias "#184" (ByVal Length As Long, Destination As Any, Source As Any)
Private Declare Sub PutMem4 Lib "msvbvm60" Alias "#307" (Ptr As Any, ByVal NewVal As Long)
Private Declare Function CoTaskMemAlloc Lib "ole32" (ByVal cbMem As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal lpMem As Long)

Private m_VTable As VTable, m_pVTable As Long, colUDT As New Collection

Private Property Get GetVTablePointer() As Long
Dim i As Long
    If m_pVTable = 0 Then ' one-time VTable creation for this UDT object
        With m_VTable
            For i = LBound(.VTable) To UBound(.VTable)
                .VTable(i) = Choose(i + 1, AddressOf QueryInterfaceUDT, AddressOf AddRefUDT, AddressOf ReleaseUDT)
            Next i
        End With
        m_pVTable = VarPtr(m_VTable)
    End If
    GetVTablePointer = m_pVTable
End Property

Private Function QueryInterfaceUDT(This As ObjectUDT, ByVal rIID As Long, pObj As Long) As Long
Const E_NOINTERFACE As Long = &H80004002
    Debug.Assert False ' QueryInterface shouldn't be called
    pObj = 0: QueryInterfaceUDT = E_NOINTERFACE
End Function

Private Function AddRefUDT(This As ObjectUDT) As Long
    With This
        .RefCount = .RefCount + 1: AddRefUDT = .RefCount ' Increase the reference count for this UDT object
    End With
End Function

Private Function ReleaseUDT(This As ObjectUDT) As Long
    With This
        .RefCount = .RefCount - 1: ReleaseUDT = .RefCount ' Decrease the reference count for this UDT object
        If .RefCount = 0 Then DeleteThis VarPtr(This) ' Clean up the resources taken by this UDT object when the reference count reaches zero
    End With
End Function

Private Sub DeleteThis(pThis As Long)
Dim tCopyUDT As ObjectUDT
    CopyBytesZero LenB(tCopyUDT), ByVal VarPtr(tCopyUDT), ByVal pThis ' Automatically release any Strings, Arrays or Objects stored in this UDT as soon as the function exits
    CoTaskMemFree pThis ' Free the previously allocated memory for this UDT object
End Sub

Private Function CreateInstance(tUDT As UDT) As IUnknown
Dim pThis As Long
    pThis = CoTaskMemAlloc(LenB(tUDT) + 8) ' Allocate memory for this UDT plus an additional 8 bytes for the VTable pointer and reference count
    If pThis Then
        PutMem4 ByVal pThis, GetVTablePointer: PutMem4 ByVal pThis + 4, 1& ' Initialize the VTable pointer and reference count for this UDT object
        CopyBytesZero LenB(tUDT), ByVal pThis + 8, ByVal VarPtr(tUDT) ' Copy the UDT contents to the newly allocated memory and erase the original to prevent unwanted deallocations
        PutMem4 CreateInstance, pThis ' Complete the creation of this UDT object
    End If
End Function

Public Property Get CollectionItem(ByVal lIndex As Long, tUDT As UDT) As UDT ' The "tUDT" parameter is just a generic placeholder to reserve space on the stack
    If lIndex > 0 And lIndex <= colUDT.Count Then
        PutMem4 ByVal VarPtr(lIndex) + 4, ObjPtr(colUDT(lIndex)) + 8 ' Now the "tUDT" parameter points to the corresponding UDT member stored in the collection
        CollectionItem = tUDT
    End If
End Property

Public Property Let CollectionItem(ByVal lIndex As Long, tUDT As UDT, tmpUDT As UDT) ' The "tUDT" parameter is just a generic placeholder to reserve space on the stack
    If lIndex > 0 And lIndex <= colUDT.Count Then
        PutMem4 ByVal VarPtr(lIndex) + 4, ObjPtr(colUDT(lIndex)) + 8 ' Now the "tUDT" parameter points to the corresponding UDT member stored in the collection
        tUDT = tmpUDT
    End If
End Property

Public Sub CollectionAdd(tUDT As UDT, Optional Before, Optional After)
    colUDT.Add CreateInstance(tUDT), , Before, After ' Create a new instance of this UDT and add it to the collection
End Sub

The UDT also contains a "Dummy" class member for demonstration purposes just to show how each object fires its "Class_Terminate" event when the collection is destroyed.

Here's the demo project: CollectionUDT.zip
Attached Files

[RESOLVED] Time and Date from memory

0
0
I tried different ways and none worked so far so I'm giving up and ask your help guys & gals.

I save the date and time to binary:
Code:

Open "test.bin" For Binary As #1
    Put #1, , Date
    Put #1, , Time
Close #1

This method works:
Code:

Open "test.bin" For Binary As #1
    Get #1, , myDate
    Get #1, , myTime
Close #1

However, I want to (for my reasons) read it from memory instead:
Code:

sFileName = "test.bin"
lFileSize = FileLen(sFileName)
ReDim bytArray(0 To lFileSize - 1) As Byte
Open sFileName For Binary As #1
    Get #1, , bytArray
Close #1

lMemAddr = VarPtr(bytArray(0))
myDate = MemRead(lMemAddr, 8)
myTime = MemRead(lMemAddr+8, 8)

According to this information, the date and time are stored as 'an IEEE 64-bit (8-byte) floating point number, just like a Double.' It should work but apparently, I'm missing something.


Alternative solution

I decided to follow SmUX2k's advice and use UNIXTIME. My data includes more than just the date and time, and it is stored in long words, so this solution suits me better. Here is the working code:

Code:

Function UnixTimeToDate(unixTime As Long) As Date
    UnixTimeToDate = DateAdd("s", unixTime, #1/1/1970#)
End Function

Function DateToUnixTime(inputDate As Date) As Long
    DateToUnixTime = DateDiff("s", #1/1/1970#, inputDate)
End Function

Function GetDate(unixTime As Long) As Date
    Dim convertedDate As Date
    convertedDate = UnixTimeToDate(unixTime)
    GetDate = Int(convertedDate)
End Function

Function GetTime(unixTime As Long) As Date
    Dim convertedDate As Date
    convertedDate = UnixTimeToDate(unixTime)
    GetTime = convertedDate - Int(convertedDate)
End Function

Code:

Dim unixTime        As Long
Dim inputDate      As Date
Dim convertedDate  As Date

' Assign a date and time value
inputDate = Now ' Or e.g.: #3/28/2024 7:30:00 AM#

' Convert Date and Time to Unix time
unixTime = DateToUnixTime(inputDate)

' Convert Unix time to Date
convertedDate = UnixTimeToDate(unixTime)

Code:

Dim datePart As Date
Dim timePart As Date

' Take Date
datePart = GetDate(unixTime)

' Take Time
timePart = GetTime(unixTime)

Draw And Move Multiple Lines

0
0
I need to draw straight lines and then be able to select any one of them and move them around by the ends and even change the length and angle of the line.

If handle are used then have the handle appear when the line is clicked by the mouse and vanish when the mouse clicks elsewhere.

Drawing on a form surface.

Sample code would make it clear to me.

Code To Share

0
0
I have code to share.

Snippets and full applications.

How and where do I do this ?

Step details please.

Help tidying up word userform

0
0
Hello,

I made a userform in word where the user can enter their hearing test results and the form applies a correction based on age (combobox) stimulus type (radio button) and transducer (radio button). They press ok and the values are dumped into a table in the word doc.

It works as expected but I basically copied and pasted the same code on the change event for each control, plus you have 2 ears so its pasted multiple times. There are 10 boxes per ear (the ones labelled nhl) where you type in a number.

I was thinking to put the code once in a module or class module and then have "see module" on the change event for each control.

I have no idea how to do this and google is not helping.

This part of a larger report that I have cut down to just the bit i need help with - in order not to dox myself also. That's why the form looks weird.

I've attached it, if you look you can see what I'm talking about. The picture under the table in the word doc are the source corrections that I used to create the form.

I taught myself some very basic vba by googling and trial and error, so please keep that in mind.

Apologies if this is in the wrong place, its not very clear where to post this tbh. Thanks in advance
Attached Files

A WAN that never returns a 404 error

0
0
G'Day Guys

Easters almost here & I promised myself I would spend more time on a project I'm starting to wonder if IT is even possible in VB6

I have a .au direct domain http://5o.au - sub-domains I have already created are

http://visit.barossa.5o.au & http://park.pv.5o.au

But, if a person types

http://coles.5118.5o.au <- This return 404 error currently - No Sub-dom

into a browser I want AI to generate the HTML / CSS / JS in RT & return what we call a Go Page.

- 1st issue - coles isn't a sub-dom of 5118, ITs not in any DNS server - SOLVED
- 2nd issue - No index.html exists on any web servers hard disk - SOLVED
- 3rd Issue - Having AI generate the same style Go Pages in RT from temples - Prototyping - N O T S O L V E D !!!

BTW - In the Australian postcode region 5118 these are 2 x Coles stores, Olde coles & New Coles, I want the AI to return a page that uses Google Maps Directions to show the user how they get from their current location for both stores, with Oldes Coles in top 50% of page & New Coles in bottom 50% of page

The VB6 language is sxxt at AI

Should I be using C Plus Plus socket programming or Python or ?

open regedit to desired key

0
0
regmon used to have a neat feature where it could open regedit and navigate the treeview to the registry key it was displaying.
turns out Mark spun it off into its own command line utility as well called regjump: https://learn.microsoft.com/en-us/sy...nloads/regjump

here is a quick vb version for newer versions of regedit that have the path textbox at the top.
the old xp compatible regmon version used to send keys to the treeview

Code:

Option Explicit

'demo form needs a button, listbox, and textbox all with default names..

Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClassName As String, ByVal lpszWindowName As String) As Long
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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetFocus2 Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long

Private Const SW_RESTORE = 9
Private Const WM_KEYDOWN = &H100
Private Const WM_SETFOCUS = &H7
Private Const WM_CHAR = &H102
Private Const WM_PASTE = &H302
Private Const EM_SETSEL = &HB1
Private Const VK_RETURN = &HD

Private Sub Form_Load()
    Text1 = "hkcu\SOFTWARE\Microsoft\Windows\CurrentVersion\Run"
End Sub

Private Sub Command1_Click()

    Dim regedit As Long, edit As Long, pid As Long
    Dim path As String
   
    List1.Clear
    List1.AddItem "Started " & Now
   
    path = ExpandPath(Text1)
    regedit = FindChild("RegEdit_RegEdit")
   
    List1.AddItem "expanded path = " & path
    List1.AddItem "regedit = " & Hex(regedit)
   
    If Not isValid(regedit) Then
   
        List1.AddItem "regedit not found opening..."
        pid = Shell("regedit.exe", vbNormalFocus)
       
        If pid = 0 Then
            List1.AddItem "Failed to start regedit?"
            Exit Sub
        End If
       
        Sleep 800
        regedit = FindChild("RegEdit_RegEdit")
        List1.AddItem "regedit = " & Hex(regedit)
       
        If Not isValid(regedit) Then
            List1.AddItem "started but still cant find permission?"
            Exit Sub
        End If
       
    End If
   
    If IsIconic(regedit) Then
        List1.AddItem "Regedit was minimized restoring..."
        ShowWindow regedit, SW_RESTORE
    End If
   
    SetForegroundWindow regedit
    SetFocus2 regedit
       
    edit = FindChild("Edit", regedit)
    List1.AddItem "edit = " & Hex(edit)
   
    If Not isValid(edit) Then
        List1.AddItem "Cant find edit window?"
        Exit Sub
    End If
   
    Clipboard.Clear
    Clipboard.SetText path
   
    SendMessage edit, EM_SETSEL, 0, 1000
    SendMessage edit, WM_PASTE, 0, 0
    SendMessage edit, WM_KEYDOWN, VK_RETURN, 0
   
    List1.AddItem "done.."
   
End Sub

Function ExpandPath(path As String) As String
   
    Dim prefix As String
   
    ExpandPath = path
    prefix = UCase(Left(path, 4))
   
    If prefix = "HKLM" Then
        ExpandPath = Replace(path, "HKLM\", "HKEY_LOCAL_MACHINE\", 1, 1, vbTextCompare)
    ElseIf prefix = "HKCU" Then
        ExpandPath = Replace(path, "HKCU\", "HKEY_CURRENT_USER\", 1, 1, vbTextCompare)
    ElseIf prefix = "HKCC" Then
        ExpandPath = Replace(path, "HKCC\", "HKEY_CURRENT_CONFIG\", 1, 1, vbTextCompare)
    ElseIf prefix = "HKCR" Then
        ExpandPath = Replace(path, "HKCR\", "HKEY_CLASSES_ROOT\", 1, 1, vbTextCompare)
    ElseIf prefix = "HKU\" Then
        ExpandPath = Replace(path, "HKU\", "HKEY_USERS\", 1, 1, vbTextCompare)
    End If
   
End Function

Function FindChild(ByVal className As String, Optional parentHwnd As Long = 0) As Long
    FindChild = FindWindowEx(parentHwnd, 0&, className, vbNullString)
End Function

Function isValid(hwnd As Long) As Boolean
    isValid = Not (IsWindow(hwnd) = 0)
End Function

Export time value from Datagridview to Excel

0
0
I want to export time value from Datagridview to Excel
The values i have in the datagridvies is like:
14:00
14:15
9:30
11:45

The results i have in Excel is
30/12/1899 14:00:00
30/12/1899 14:15:00
30/12/1899 9:30:00
30/12/1899 11:45:00

Used code:
excelWS.Range("G3").Value = "Werktijd" 'Title
excelWS.Range("G" & i).Value = row.Cells(6).Value.ToString


Could someone help me to have the richt export?

how to make the headers of txt file in one row

0
0
Hello,

I have the following code and the headers what i add are not in the same row and some of them go to the next line. do you have idea how to make the headers in the first line?
I attached also the picture of text fileName:  testscreenshot.jpg
Views: 31
Size:  6.0 KB
for example in this picture Sturm, Erdbeben, Überschwemmung, Hagel, Erdrutsch, Kraftfahrzeug, Marine, Luftfahrt, Feuer, Haftpflicht1 is ereignisnummer and should come below of the ereignisnummer but it comes below of these columns: Bis Schadenaufwand Gefahrenart


Code:

Using sfd As New SaveFileDialog()
    sfd.Filter = "Textdateien (*.txt)|*.txt"
    If sfd.ShowDialog(Me) = DialogResult.OK Then
        Using writer = New StreamWriter(sfd.FileName, False)
            writer.WriteLine(L("Ereignissucheeinstellungen:"))
            Dim listeinstellungen As New List(Of String)({"CatZeitraum", "Gefahrenart", "CatGrenze"})
            For index As Integer = 0 To EreignissucheLog.EreignissucheSettings.Count - 1
                writer.WriteLine(listeinstellungen(index) & ":" & EreignissucheLog.EreignissucheSettings(index))
            Next
            writer.WriteLine()
            writer.WriteLine(L("{0} Liste von Ereignise:", EreignissucheLog.Ereignisinfoliste.Count))
            writer.Write("Ereignisnummer" & Space(100))
            writer.Write("Name" & Space(114))
            writer.Write("Von" & Space(13))
            writer.Write("Bis" & Space(13))
            writer.Write("Schadenaufwand" & Space(2))
            writer.WriteLine("Gefahrenart")
            For Each Ereignis In EreignissucheLog.Ereignisinfoliste
                writer.Write(Ereignis.Er.Ereignisnummer & Space(114 - Ereignis.Er.Ereignisnummer.Length))
                writer.Write(Ereignis.Er.Ereignisname & Space(118 - Ereignis.Er.Ereignisname.Length))
                writer.Write(Ereignis.Von.ToShortDateString().ToString() & Space(16 - Ereignis.Von.ToShortDateString().ToString().Length))
                writer.Write(Ereignis.Bis.ToShortDateString().ToString() & Space(16 - Ereignis.Bis.ToShortDateString().ToString().Length))
                writer.Write(Format(Ereignis.Schadenaufwand, "0.0000") & Space(16 - Format(Ereignis.Schadenaufwand, "0.0000").Length))
                writer.WriteLine(HauptgefahrenUtils.HauptgefahrenToString(Ereignis.Er.Gefahrenart, Nothing))
                For index As Integer = 0 To Ereignis.Schaeden.Count - 1
                    writer.Write("Schaden" & index + 1 & ":" & "SchadenID:" & Ereignis.Schaeden(0).SchadenID & vbTab)
                    writer.Write("Sparte:" & Ereignis.Schaeden(0).Sparte & vbTab)
                    writer.Write("Schadendatum:" & Ereignis.Schaeden(0).Schadendatum.ToShortDateString() & vbTab)
                    writer.WriteLine()
                Next
            Next
        End Using
    End If
End Using

Attached Images
 

vb6 install under win10.

0
0
Hello,
I am trying to install VB6 Pro under win10 using VS6Installer ver. 5, following youtube video :
"Visual Basic 6 SP6 Working in Windows 10 64-bit".
During installation a msg in "French" traduction : "version of visual studio 6 is detected, a potential conflict ..., after intallation of this product, one of the two products may not work"
Obviously no other visual studio 6 product exists on my pc.

I note that in the past visual c++ 6.0 had been installed but uninstalled since.
Any idea ?

VB6IDEMouseWheelAddin

0
0
I am having issues getting this working in Windows 11. I have finally been successful getting VB6, SP6, Sheridan Widgets, Threed32.ocx and Spin32.ocx installed and all working. I can load my apps, run them, compile them, etc. Which is great! However, this Mouse Wheel fix is not. I have copied it into the SysWOW64 folder and done the regsvr32 from the command line prompt being run as admin and done the VBA Mouse Wheel Fix.reg and rebooted. In VB I have gone into Addin Manager and set it to Load and Startup. But still will not work. Any ideas?

loading forms

0
0
hi guys. i have a quick question. I have a form with a command button that when i click i want to load a new form. it was easy in vb6 but i can't figure it out in vb.net

I'd love some help with this one guys.





Latest Images