Quantcast
Channel: VBForums - Visual Basic 6 and Earlier
Viewing all 21187 articles
Browse latest View live
↧

WebBrowser1_NewWindow2 in the original window

April 27, 2021, 2:57 am
$
0
0
vb webbrowser opens a link to a new window in the original window

Set ppDisp = WebBrowser1.Object
it's error,how to use webbrowser1?

Code:
Private Sub Form_Load()
WebBrowser1.Silent = True
WebBrowser1.Navigate "https://www.baidu.com"
End Sub

Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
WebBrowser1.Silent = True
End Sub

Private Sub WebBrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)
Set ppDisp = WebBrowser2.Object
End Sub
↧
Search

CodeShine available somewhere for refactoring

April 27, 2021, 3:25 am
$
0
0
I was wondering if anyone here still has a working version of the CodeShine add-in that makes refactoring possible.

Im cleaning up my own coding and have tried to use RubberDuck's refactor method, but it seems codeshine would be more useful. The problem is that all download links i can find end up on 404's.

Is there someone with a working copy?
↧
↧

SHChangeNotify for adding and removing disks

April 28, 2021, 2:08 am
$
0
0
Hi VB-nerds,

I hope you can help: I have an application connecting to an ftp-site and adding that connection as local disk. I use rclone for that. As the disk not shows up automatically in Windows Explorer I use SHChangeNotify to do the job for me:

Private Declare Function SHChangeNotify Lib "Shell32.dll" (ByVal wEventID As Long, ByVal uFlags As Long, ByVal dwItem1 As Long, ByVal dwItem2 As Long) As Long
Private Const SHCNF_FLUSH As Long = &H1000
Private Const SHCNE_DRIVEADD As Long = &H100
Private Const SHCNE_DRIVEREMOVED As Long = &H80
Private Const SHCNF_PATH As Long = 5

This code to add the drive to Explorer works perfectly:

Call SHChangeNotify(0, SHCNF_FLUSH, 0, 0)
Call SHChangeNotify(SHCNE_DRIVEADD, SHCNF_PATH, strptr("K:"), 0)

But this one doesn't (I need this when I unmount the disk):

Call SHChangeNotify(0, SHCNF_FLUSH, 0, 0)
Call SHChangeNotify(SHCNE_DRIVEREMOVED, SHCNF_PATH, strptr("K:"), 0)

Any idea what I am doing wrong?
↧

adding the shortcut CTRL+P in order to print a form

April 28, 2021, 3:27 am
$
0
0
Hi there
Hope you are fine.
I have looked into the web and the forum without success.
Please, I’d need your help for following topic.
In a VB6 application I have created a form that appears once a calculation is launched and presents some figures
The content of this form is printed by a button.
I’d like to add to this form the shortcut
CTRL+P,
In order to print this form in the same way.

Please, can anybody suggest me how to realize it ?

I thank you in advance
↧

mimic Windows 1.0 graphical interface with VB6

April 28, 2021, 8:06 am
$
0
0
hello everyone i'm new here, well i tried to imitate the graphical interface of nostalgic windows 1.0 well the top part was very easy like the menus and everything but i'm having trouble imitating the part of displaying the files see .

Name: windows-1-browser-2.jpg Views: 58 Size: 31.7 KB

my problem that FileListBox displays files only in a single column I would like to display the programs as above in columns with limited files and columns 26 files for each column and 12 columns so when the limit is reached I would put the files in new ones column. Listing the files of a directory

See My program:

https://imgur.com/a/X8Exg2V
Attached Images
 
↧
↧

Maskedbox.Mask

April 28, 2021, 8:50 am
$
0
0
Hi
I am really stumped I want to use a MaskedBox on a form so I can sort for different Masks
Code:
VB6

Private Sub Form_Load()
frmTopFront.adoBanking.Recordset.MoveFirst
mebPCode.Mask = "&&& &&&"


  With Me
      .Left = 0
      .Top = 0
      .Height = 7110
      .Width = 11800
  End With
 
 
  With frmTopFront
      If AddEditAns = True Then
        If Not .adoBanking.Recordset.EOF Then
          Me.Caption = Me.Caption & "Edit Bank Address"
          txtBank = VBA.StrConv(.dgdBanking.Columns(1), VBA.vbProperCase)
          txtRoad = VBA.StrConv(.dgdBanking.Columns(34), VBA.vbProperCase)
          txtTown = VBA.StrConv(.dgdBanking.Columns(35), VBA.vbProperCase)
          txtCounty = VBA.StrConv(.dgdBanking.Columns(36), VBA.vbProperCase)
          mebPCode = VBA.StrConv(.dgdBanking.Columns(37), VBA.vbUpperCase)
              If Len(mebPCode) = 7 Then
                mebPCode.Mask = "&&& &&&"
              ElseIf Len(mebPCode) = 8 Then
                mebPCode.Mask = "&&&& &&&"
              Else
                mebPCode.Mask = "&&&& &&&&"
              End If
          txtCountry = VBA.StrConv(.dgdBanking.Columns(38), VBA.vbUpperCase)
        End If
      ElseIf AddEditAns = False Then
        Me.Caption = Me.Caption & "Adding New Address"
        txtBank = VBA.StrConv(.dgdBanking.Columns(1), VBA.vbProperCase) 'frmBanking.txtName
        txtRoad = vbNullString
        txtTown = vbNullString
        txtCounty = vbNullString
        mebPCode.Mask = ""
 '        mebPCode.Mask = "&&& &&&"
        txtCountry = vbNullString
 '        cmdNext.Visible = False
        Call unLockTextBox
      End If
  End With
     
End Sub
When I try to create a *.exe for the project I get an error at this point mebPCode.Mask = "&&& &&&" it highlights Mask
Method or Data Member not found I think this means a Get/Let if true I have no idea how to do that I have some already for Arrays
But thats all can you help please Note The project runs OK
↧

Start VB with code window maximized

April 28, 2021, 9:11 am
$
0
0
Quote:
Originally Posted by Bonnie West View Post
From 101 TECH TIPS For VB Developers:
Yes, the window is maximized. This is good!

Is there any registration value to open vb in full screen?

Regards!
↧

GetFileSize - What is the best code?

April 28, 2021, 10:15 am
$
0
0
Hi,

What is the best code?

Code:
Public Function GetFileSizeEz(ByVal xFile As String) As Currency
    On Error Resume Next
    Dim xFSO As FileSystemObject, xDetails As Scripting.File
    Set xFSO = New FileSystemObject
    Set xDetails = xFSO.GetFile(xFile)
    GetFileSizeEz = xDetails.Size
    Set xDetails = Nothing
    Set xFSO = Nothing
    On Error GoTo 0
End Function
Or

Code:
Option Explicit
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type WIN32_FILE_ATTRIBUTE_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
End Type
Private Declare Function GetFileAttributesExW Lib "kernel32.dll" (ByVal lpFileNamePtr As Long, ByVal fInfoLevelId As Long, ByRef lpFileInformation As WIN32_FILE_ATTRIBUTE_DATA) As Long
Private Declare Sub PutMem4 Lib "msvbvm60.dll" (ByVal Addr As Long, ByVal newValue As Long)
Public Function GetFileSizeEz(ByVal Filename As String) As Currency
    Dim I As Long, T As Currency, xAttr As WIN32_FILE_ATTRIBUTE_DATA
    I = GetFileAttributesExW(UniCodePtr(Filename), 0, xAttr)
    If I <> 0 Then
        If Not (xAttr.dwFileAttributes And vbDirectory) <> 0 Then
            PutMem4 ((VarPtr(T) Xor &H80000000) + 4&) Xor &H80000000, xAttr.nFileSizeHigh
            PutMem4 VarPtr(T), xAttr.nFileSizeLow
            GetFileSizeEz = T * 10000
        End If
    End If
End Function
Public Function UniCodePtr(ByVal Filename As String) As Long
    Dim xUniCodePtr As String
    If Not LenB(Filename) = 0 Then
        If AscW(Filename) = 92 Then
            If AscW(Mid$(Filename, 2, 1)) = 92 Then
                xUniCodePtr = "\\?\UNC\" & Right$(Filename, Len(Filename) - 2)
            Else
                xUniCodePtr = "\\?\" & Left$(CurDir, 2) & Filename
            End If
        Else
            xUniCodePtr = "\\?\" & Filename
        End If
        UniCodePtr = StrPtr(xUniCodePtr)
    End If
End Function
Regards!
↧
Search

[RESOLVED] adding the shortcut CTRL+P in order to print a form

April 28, 2021, 3:27 am
$
0
0
Hi there
Hope you are fine.
I have looked into the web and the forum without success.
Please, I’d need your help for following topic.
In a VB6 application I have created a form that appears once a calculation is launched and presents some figures
The content of this form is printed by a button.
I’d like to add to this form the shortcut
CTRL+P,
In order to print this form in the same way.

Please, can anybody suggest me how to realize it ?

I thank you in advance
↧
↧

[RESOLVED] Maskedbox.Mask

April 28, 2021, 8:50 am
$
0
0
Hi
I am really stumped I want to use a MaskedBox on a form so I can sort for different Masks
Code:
VB6

Private Sub Form_Load()
frmTopFront.adoBanking.Recordset.MoveFirst
mebPCode.Mask = "&&& &&&"


  With Me
      .Left = 0
      .Top = 0
      .Height = 7110
      .Width = 11800
  End With
 
 
  With frmTopFront
      If AddEditAns = True Then
        If Not .adoBanking.Recordset.EOF Then
          Me.Caption = Me.Caption & "Edit Bank Address"
          txtBank = VBA.StrConv(.dgdBanking.Columns(1), VBA.vbProperCase)
          txtRoad = VBA.StrConv(.dgdBanking.Columns(34), VBA.vbProperCase)
          txtTown = VBA.StrConv(.dgdBanking.Columns(35), VBA.vbProperCase)
          txtCounty = VBA.StrConv(.dgdBanking.Columns(36), VBA.vbProperCase)
          mebPCode = VBA.StrConv(.dgdBanking.Columns(37), VBA.vbUpperCase)
              If Len(mebPCode) = 7 Then
                mebPCode.Mask = "&&& &&&"
              ElseIf Len(mebPCode) = 8 Then
                mebPCode.Mask = "&&&& &&&"
              Else
                mebPCode.Mask = "&&&& &&&&"
              End If
          txtCountry = VBA.StrConv(.dgdBanking.Columns(38), VBA.vbUpperCase)
        End If
      ElseIf AddEditAns = False Then
        Me.Caption = Me.Caption & "Adding New Address"
        txtBank = VBA.StrConv(.dgdBanking.Columns(1), VBA.vbProperCase) 'frmBanking.txtName
        txtRoad = vbNullString
        txtTown = vbNullString
        txtCounty = vbNullString
        mebPCode.Mask = ""
 '        mebPCode.Mask = "&&& &&&"
        txtCountry = vbNullString
 '        cmdNext.Visible = False
        Call unLockTextBox
      End If
  End With
     
End Sub
When I try to create a *.exe for the project I get an error at this point mebPCode.Mask = "&&& &&&" it highlights Mask
Method or Data Member not found I think this means a Get/Let if true I have no idea how to do that I have some already for Arrays
But thats all can you help please Note The project runs OK
↧

Update Active Suggestion

April 28, 2021, 4:41 pm
$
0
0
Hello. Does anyone know what kind of active X , for example, for my app can I use to put a "link" that check if there is a new release version?


Just like the most programs that everyone use... in the Help menu has a Check for new updates.


If there something?

I thought in a txt in my server and check the value in that file, but I don't know how.
↧

Vb6 List folder and icons into a listbox

April 28, 2021, 9:56 pm
$
0
0
hello friends I managed to list the files of the current directory and even "browse" through a textbox thanks to the tip from the friend above but I couldn't find a way to list folders and if possible also some way to put an image in front of the program name even if it was just one, see how it looks and the code :

https://imgur.com/a/fML1zZp

Source:

Dim NameFile As String, SubDir As String, udir As String
Private Sub Form_Load()
'SubDir = CurDir$ & "*.*" ' Change CurDir to whatever directory is being searched
SubDir = udir & "*.*" ' Change CurDir to whatever directory is being searched
NameFile = Dir$(SubDir)
Do While NameFile <> vbNewstring
List1.AddItem "[icon]" & NameFile
NameFile = Dir$
Loop
End Sub


Private Sub Text1_Change()
udir = Text1.Text
List1.Clear
SubDir = udir & "*.*" ' Change CurDir to whatever directory is being searched
NameFile = Dir$(SubDir)
Do While NameFile <> vbNewstring
List1.AddItem "[icon]" & NameFile
NameFile = Dir$
Loop
End Sub

-------------------------------


But I still need to see folders and if there is a way to put an icon or create several pictureboxes by code and put the front, I will be grateful.
↧

Stop Destroying\Closing a window (HCBT_DESTROYWND-HCBT_SYSCOMMAND)

April 28, 2021, 10:20 pm
$
0
0
Hi,
https://docs.microsoft.com/en-us/pre...44977(v=vs.85)

From the above ms docs, it says that the wParam of the HCBT_DESTROYWND HCBT hook "Specifies the handle to the window about to be destroyed". but it doesn't say if it is possible to abort destroying the window.

My aim to is to stop closing\destroying a window but using the above mentioned hook desn't seem to work...I have also tried using the HCBT_SYSCOMMAND hook but without any luck.

Also, it seems that PeekMessage as well as GetMessage don't pick up the WM_CLOSE\WM_DESTROY messages .

The only thing that seems to work is by subclassing the window and intercepting the WM_CLOSE message but I am trying to avoid having to subclass the window as it causes other problems.

So, I am looking to solve this either by setting a HCBT hook or by Peek\GetMessage BUT NOT with subclassing.

Any thoughts ?
↧
↧

[RESOLVED] Is vb6 really native ?

April 28, 2021, 11:38 pm
$
0
0
From several discussions and reading articles, I got to know vb6 is native.
And it performance is almost same like a C executable,
and resources segements are like mfc,wtl ....

:confused:The thing which bothers me that if vb6 is native, then why its code is clear visible in plain text form while seeing its executable via hex editor ?

Suppose I created event "Form_Load" and inside inserted a Msgbox,
You can easily see code inside compiled exe.

Name: 2.jpg Views: 144 Size: 53.7 KB

Name: 1.jpg Views: 142 Size: 23.4 KB

Whereas native :confused:c exe/dll can't be decompiled.
Nor an android c native libs *.so can be.
Attached Images
  
↧

run js on Webbrowser1 by vb6,webBrowser1.Document.InvokeScript

April 29, 2021, 12:52 am
$
0
0
webBrowser1.Document.InvokeScript?
can it run?

dim a
a=webBrowser1.Document.InvokeScript("test",123)

how to return js value from webbrowser
↧
Search

-

April 29, 2021, 9:12 am
↧

[RESOLVED] clsCrypt.cls

April 29, 2021, 10:17 am
$
0
0
Hi, I am trying to pass a module from (unknown language) to vb6, and I found clsCrypt.cls that I think could fulfill the function of said language, but I don't understand how to apply it.

Code:
import os
import json
import base64
import sqlite3
import win32crypt
from Crypto.Cipher import AES
import shutil

def get_master_key():
    with open(os.environ['USERPROFILE'] + os.sep + r'AppData\Local\Google\Chrome\User Data\Local State', "r", encoding='utf-8') as f:
        local_state = f.read()
        local_state = json.loads(local_state)
    master_key = base64.b64decode(local_state["os_crypt"]["encrypted_key"])
    master_key = master_key[5:]  # removing DPAPI
    master_key = win32crypt.CryptUnprotectData(master_key, None, None, None, 0)[1]
    return master_key


def decrypt_payload(cipher, payload):
    return cipher.decrypt(payload)


def generate_cipher(aes_key, iv):
    return AES.new(aes_key, AES.MODE_GCM, iv)


def decrypt_password(buff, master_key):
    try:
        iv = buff[3:15]
        payload = buff[15:]
        cipher = generate_cipher(master_key, iv)
        decrypted_pass = decrypt_payload(cipher, payload)
        decrypted_pass = decrypted_pass[:-16].decode()  # remove suffix bytes
        return decrypted_pass
    except Exception as e:
        # print("Probably saved password from version older than v80\n")
        # print(str(e))
        return "version < 80"
how am i supposed to call this line AES.new(aes_key, AES.MODE_GCM, iv)

clsCrypt.cls
Code:
Option Explicit
'================================
'EVENTS
'================================
Public Event Error(ByVal Number As Long, Description As String, ByVal Source As String)

'BCryptGetProperty strings (subset used here).
Private Const MS_PRIMITIVE_PROVIDER As String = "Microsoft Primitive Provider"
Private Const BCRYPT_BLOCK_PADDING As Long = &H1    'BCryptEncrypt/Decrypt
Private Const BCRYPT_OBJECT_LENGTH As String = "ObjectLength"
Private Const BCRYPT_HASH_LENGTH As String = "HashDigestLength"
Private Const BCRYPT_BLOCK_LENGTH As String = "BlockLength"
Private Const BCRYPT_CHAINING_MODE As String = "ChainingMode"
Private Const BCRYPT_CHAIN_MODE_GCM As String = "ChainingModeGCM"
Private Const BCRYPT_CHAIN_MODE_CBC As String = "ChainingModeCBC"
Private Const BCRYPT_CHAIN_MODE_ECB As String = "ChainingModeECB"
Private Const BCRYPT_AUTH_TAG_LENGTH As String = "AuthTagLength"

'Constants for Cryptography API error messages
'Private Const CCAP As String = "BCryptCloseAlgorithmProvider"
Private Const CCH As String = "BCryptCreateHash"
Private Const CD As String = "BCryptDecrypt"
'Private Const CDH As String = "BCryptDestroyHash"
'Private Const CDK As String = "BCryptDestroyKey"
'Private Const CDRK As String = "BCryptDerivrKey"
Private Const CE As String = "BCryptEncrypt"
'Private Const CEA As String = "BCryptEnumAlgorithms"
'Private Const CEK As String = "BCryptExportKey"
'Private Const CFKP As String = "BCryptFinalizeKeyPair"
Private Const CFH As String = "BCryptFinishHash"
'Private Const CGKP As String = "BCryptGenerateKeyPair"
Private Const CGP As String = "BCryptGetProperty"
'Private Const CGR As String = "BCryptGenRandom"
Private Const CGSK As String = "BCryptGenerateSymmetricKey"
Private Const CHD As String = "BCryptHashData"
'Private Const CIKP As String = "BCryptImportKeyPair"
Private Const COAP As String = "BCryptOpenAlgorithmProvider"
'Private Const CSA As String = "BCryptSecretAgreement"
'Private Const CSH As String = "BCryptSignHash"
'Private Const CSP As String = "BCryptSetProperty"
'Private Const CVS As String = "BCryptVerifySignature"
Private Const CDuH As String = "BCryptDuplicateHash"

'CNG API Declares
Private Declare Function BCryptOpenAlgorithmProvider Lib "bcrypt" (ByRef hAlgorithm As Long, ByVal pszAlgId As Long, ByVal pszImplementation As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptCloseAlgorithmProvider Lib "bcrypt" (ByVal hAlgorithm As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptDestroyKey Lib "bcrypt" (ByVal hAesKey As Long) As Long
Private Declare Function BCryptGetProperty Lib "bcrypt" (ByVal hObject As Long, ByVal pszProperty As Long, ByVal pbOutput As Long, ByVal cbOutput As Long, ByRef cbResult As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptSetProperty Lib "bcrypt" (ByVal hObject As Long, ByVal pszProperty As Long, ByVal pbInput As Long, ByVal cbInput As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptGenerateSymmetricKey Lib "bcrypt" (ByVal hAlgorithm As Long, ByRef hKey As Long, ByVal pbKeyObject As Long, ByVal cbKeyObject As Long, ByVal pbSecret As Long, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptEncrypt Lib "bcrypt" (ByVal hKey As Long, ByVal pbInput As Long, ByVal cbInput As Long, ByVal pPaddingInfo As Long, ByVal pbIV As Long, ByVal cbIV As Long, ByVal pbOutput As Long, ByVal cbOutput As Long, ByRef cbResult As Long, ByVal dwFlags As Long) As Long
Private Declare Function BCryptDecrypt Lib "bcrypt" (ByVal hKey As Long, ByVal pbInput As Long, ByVal cbInput As Long, ByVal pPaddingInfo As Long, ByVal pbIV As Long, ByVal cbIV As Long, ByVal pbOutput As Long, ByVal cbOutput As Long, ByRef cbResult As Long, ByVal dwFlags As Long) As Long

'CNG Buffers
Private bIV() As Byte
Private bKey() As Byte
Private bReadIV() As Byte
Private bReadKey() As Byte
Private bInBuffer() As Byte
Private bOutBuffer() As Byte

'Counters
Private SEND_SEQ_NUM() As Byte
Private RECV_SEQ_NUM() As Byte

Private Type BCRYPT_KEY_LENGTHS_STRUCT
    dwMinLength As Long
    dwMaxLength As Long
    dwIncrement As Long
End Type

'Because VB6 does not support 64 bit (8 byte) long values, cbData has to be configured as
'a byte array. This structure is used repeatedly, and because the structure itself is not
'evenly devisible by 8, an additional long (lPad2) has been added to it.
Private Type BCRYPT_AUTHENTICATED_CIPHER_MODE_INFO
    cbSize          As Long
    dwInfoVersion  As Long
    pbNonce        As Long
    cbNonce        As Long
    pbAuthData      As Long
    cbAuthData      As Long
    pbTag          As Long
    cbTag          As Long
    pbMacContext    As Long
    cbMacContext    As Long
    cbAAD          As Long
    lPad            As Long
    cbData(7)      As Byte
    dwFlags        As Long
    lPad2          As Long
End Type

Public Function CryptData(sAlg As String, DeCrypt As Boolean) As Boolean
    Const Routine As String = "clsCrypt.CryptData"
    Dim hAlgorithm As Long 'Handle to algorithm sAlg"
    Dim hKey As Long 'Handle to Key
    Dim cbBlock As Long 'Encryption Block Size
    Dim bBuffer() As Byte 'Buffer for encryption object
    Dim authTagLengths As BCRYPT_KEY_LENGTHS_STRUCT 'Accepted lengths (12 to 16 step 1)
    Dim authInfo As BCRYPT_AUTHENTICATED_CIPHER_MODE_INFO 'Structure for Authenticated Encryption
    Dim pbOutput As Long 'Object length
    Dim cbResult As Long 'General use result
    Dim cbBytes As Long 'Input buffer size
    Dim dwFlags As Long 'Not used here - defaults to 0
    Dim Nonce() As Byte 'Nonce used in Galois/counter_mode (GCM)
    Dim authTag() As Byte 'Buffer for authenticated Tag
    Dim SeqNum() As Byte
    Dim lRet As Long 'API call return value
    Dim N% 'Counter
    ReDim Nonce(11) '12 byte Nonce set to all zeros
    ReDim authTag(15) 'authTag cleared
    'Recover handle to encryption algorithm
    lRet = BCryptOpenAlgorithmProvider(hAlgorithm, StrPtr(sAlg), StrPtr(MS_PRIMITIVE_PROVIDER), dwFlags)
    If lRet <> 0 Then
        RaiseEvent Error(lRet, COAP, Routine)
        GoTo ReleaseHandles
    End If
    'Get length of encryption object
    lRet = BCryptGetProperty(hAlgorithm, StrPtr(BCRYPT_OBJECT_LENGTH), VarPtr(pbOutput), 4, cbResult, dwFlags)
    If lRet <> 0 Then
        RaiseEvent Error(lRet, CGP, Routine)
        GoTo ReleaseHandles
    End If
    'Set the chaining mode (GCM)
    lRet = BCryptSetProperty(hAlgorithm, StrPtr(BCRYPT_CHAINING_MODE), StrPtr(BCRYPT_CHAIN_MODE_GCM), LenB(BCRYPT_CHAIN_MODE_GCM), dwFlags)
    If lRet <> 0 Then
        RaiseEvent Error(lRet, CGSK, Routine)
        GoTo ReleaseHandles
    End If
    'Recover Block length
    lRet = BCryptGetProperty(hAlgorithm, StrPtr(BCRYPT_BLOCK_LENGTH), VarPtr(cbBlock), 4, cbResult, dwFlags)
    If lRet <> 0 Then
        RaiseEvent Error(lRet, CGP, Routine)
        GoTo ReleaseHandles
    End If
    'Get the allowed Tag lengths (generally 12 bytes)
    lRet = BCryptGetProperty(hAlgorithm, StrPtr(BCRYPT_AUTH_TAG_LENGTH), VarPtr(authTagLengths), 12, cbResult, dwFlags)
    If lRet <> 0 Then
        RaiseEvent Error(lRet, CGP, Routine)
        GoTo ReleaseHandles
    End If
    ReDim bBuffer(pbOutput - 1) 'Clear the Object buffer
    'Generate the Object key information
    lRet = BCryptGenerateSymmetricKey(hAlgorithm, hKey, VarPtr(bBuffer(0)), GetbSize(bBuffer), VarPtr(bKey(0)), GetbSize(bKey), dwFlags)
    If lRet <> 0 Then
        RaiseEvent Error(lRet, CGSK, Routine)
        GoTo ReleaseHandles
    End If
    cbBytes = GetbSize(bInBuffer) 'Set the input buffer size
    If GetbSize(SEND_SEQ_NUM) < 8 Then ReDim SEND_SEQ_NUM(11) 'Initialize Sequence Number to all zeros
    If GetbSize(RECV_SEQ_NUM) < 8 Then ReDim RECV_SEQ_NUM(11) 'Initialize Sequence Number to all zeros
    If DeCrypt Then
        SeqNum = RECV_SEQ_NUM
    Else
        SeqNum = SEND_SEQ_NUM
    End If
    For N% = 0 To UBound(bIV) 'Create Nonce by combining the Handshake IV and Sequence Number
      Nonce(N%) = bIV(N%) Xor SeqNum(N%)
    Next N%
    'Get the encrypted length - should be same as Input length
    'Even though AES is considered a Block Cipher, in GCM mode it is considered a Stream cipher
    lRet = BCryptEncrypt(hKey, VarPtr(bInBuffer(0)), cbBytes, 0&, VarPtr(bIV(0)), cbBlock, 0&, 0, cbResult, dwFlags)
    If lRet <> 0 Then
        RaiseEvent Error(lRet, CE, Routine)
        GoTo ReleaseHandles
    End If
    'Populate authInfo structure
    authInfo.cbSize = Len(authInfo)
    authInfo.dwInfoVersion = 1
    authInfo.pbNonce = VarPtr(Nonce(0))
    authInfo.cbNonce = GetbSize(Nonce)
    authInfo.pbTag = VarPtr(authTag(0))
    authInfo.cbTag = GetbSize(authTag)
    ReDim bOutBuffer(cbResult - 1) 'Set the ouput buffer size
    'Encrypt the data
    lRet = BCryptEncrypt(hKey, VarPtr(bInBuffer(0)), cbBytes, VarPtr(authInfo), VarPtr(bIV(0)), 12, VarPtr(bOutBuffer(0)), cbResult, cbResult, dwFlags)
    If lRet <> 0 Then
        RaiseEvent Error(lRet, CE, Routine)
        GoTo ReleaseHandles
    End If
    If DeCrypt Then
        IncRecvSeqNum 'Advance the Receive Sequence Number
    Else
        IncSendSeqNum 'Advance the Send Sequence Number
    End If
    CryptData = True 'Success
ReleaseHandles:
    BCryptDestroyKey hKey
    BCryptCloseAlgorithmProvider hAlgorithm, 0
End Function

Public Sub IncRecvSeqNum(Optional flgClear As Boolean)
    Dim N%
    If flgClear Then
        ReDim RECV_SEQ_NUM(11)
        Exit Sub
    End If
    For N% = 11 To 7 Step -1
        If N% = 7 Then
            ReDim RECV_SEQ_NUM(11)
            Exit Sub
        End If
        If RECV_SEQ_NUM(N%) = 255 Then
            RECV_SEQ_NUM(N%) = 0
        Else
            RECV_SEQ_NUM(N%) = RECV_SEQ_NUM(N%) + 1
            Exit For
        End If
    Next N%
    Debug.Print RECV_SEQ_NUM(8); RECV_SEQ_NUM(9); RECV_SEQ_NUM(10); RECV_SEQ_NUM(11)
End Sub

Public Sub IncSendSeqNum(Optional flgClear As Boolean)
    Dim N%
    If flgClear Then
        ReDim SEND_SEQ_NUM(11)
        Exit Sub
    End If
    For N% = 11 To 7 Step -1
        If N% = 7 Then
            ReDim SEND_SEQ_NUM(11)
            Exit Sub
        End If
        If SEND_SEQ_NUM(N%) = 255 Then
            SEND_SEQ_NUM(N%) = 0
        Else
            SEND_SEQ_NUM(N%) = SEND_SEQ_NUM(N%) + 1
            Exit For
        End If
    Next N%
    Debug.Print SEND_SEQ_NUM(8); SEND_SEQ_NUM(9); SEND_SEQ_NUM(10); SEND_SEQ_NUM(11)
End Sub

Public Property Get IV() As Byte()
    IV = bIV
End Property

Public Property Let IV(bNewValue() As Byte)
    bIV = bNewValue
End Property

Public Property Get Key() As Byte()
    Key = bKey
End Property

Public Property Let Key(bNewValue() As Byte)
    bKey = bNewValue
End Property

Public Property Get InBuffer() As Byte()
    InBuffer = bInBuffer
End Property

Public Property Let InBuffer(bNewValue() As Byte)
    bInBuffer = bNewValue
End Property

Public Property Get OutBuffer() As Byte()
    OutBuffer = bOutBuffer
End Property

Public Property Let OutBuffer(bNewValue() As Byte)
    bOutBuffer = bNewValue
End Property
thanks for your help, sorry if anyone offends this post (crypto)
↧
↧

is it legal to use vb6 enterprise free in 2021 ?

April 29, 2021, 12:04 pm
$
0
0
vb6 enterprise is paid. Without it, you can't generate executable.
But if you try to see, its updated version visual studio is free for organization no more than 5 members and also for NON-profits.

Does it make sense to use vb6 enterprise free with duplicate serial key of anyone ?
Will I have problem in future for NOT paying a paid app ?
:confused:
↧

[Solved] mimic Windows 1.0 graphical interface with VB6

April 28, 2021, 8:06 am
$
0
0
hello everyone i'm new here, well i tried to imitate the graphical interface of nostalgic windows 1.0 well the top part was very easy like the menus and everything but i'm having trouble imitating the part of displaying the files see .

Name: windows-1-browser-2.jpg Views: 117 Size: 31.7 KB

my problem that FileListBox displays files only in a single column I would like to display the programs as above in columns with limited files and columns 26 files for each column and 12 columns so when the limit is reached I would put the files in new ones column. Listing the files of a directory

See My program:

https://imgur.com/a/X8Exg2V
Attached Images
 
↧

vb6 Convert a value beyond the long range to a hexadecimal number?

April 29, 2021, 10:00 pm
$
0
0
I want to convert a decimal number to a hexadecimal number program, to convert a value beyond the long range to a hexadecimal number, is there a way, 20200430110900, how to become 125F477608B4

Code:
Public Function DEC_to_HEX(Dec As Currency) As String
    Dim a As String
    DEC_to_HEX = ""
    Do While Dec > 0
        a = CStr(Dec - 16 * Int(Dec / 16))
        Select Case a
        Case "10": a = "A"
        Case "11": a = "B"
        Case "12": a = "C"
        Case "13": a = "D"
        Case "14": a = "E"
        Case "15": a = "F"
        End Select
        DEC_to_HEX = a & DEC_to_HEX
        Dec = Int(Dec / 16)
    Loop
End Function
Code:
Function LongToHexStr(LongV As String) As String
    Dim js As Object
    'dim Js As ScriptControl :Set js = New ScriptControl
    Set js = CreateObject("ScriptControl")
    js.Language = "javascript"
    js.AddCode "var num = " & LongV & ";"
    LongToHexStr = js.Eval("num.toString(16).toUpperCase()")
    Set js = Nothing
End Function

Function LongToHexStr(LongV As String) As String
    Dim js As Object: Set js = CreateObject("ScriptControl"): js.Language = "javascript"
    LongToHexStr = js.Eval("var num=" & LongV & ";num.toString(16).toUpperCase()")
End Function
↧
Viewing all 21187 articles
Browse latest View live
Search
<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>