Error on sending mail using Windows application - windows

In my system, I'm using a windows application project. While I'm sending a mail from the project I get an error as "Creating an instance of the COM component with CLSID {20C62CA0-15DA-101B-B9A8-444553540000} from the IClassFactory failed due to the following error:80040112 Class is not licensed for use (Exception from HRResult: 0x800401120).". Can you please help me with the fix for this? I'm using Windows 10 OS.
Dim oMAPSession As New MSMAPI.MAPISession <br/>
Dim MAPIMessages As New MSMAPI.MAPIMessages
Do While J > 0
With MAPIMessages
oMAPSession.SignOn()
.SessionID = oMAPSession.SessionID
.Compose()
If attachbio Then
.AttachmentIndex = 0
If CustomTable.GetCustomNumber("TEPrintPerUser") = 1 Then
.AttachmentPathName = g_fpReportsPath & "\tempbio.pdf"
Else
.AttachmentPathName = Application.StartupPath & "\tempbio.pdf"
End If
.AttachmentName = "techbio.pdf"
End If
strRecip = Trim(rdtxtFldNumber.Text)
i = 0
Do
.RecipIndex = i
.RecipType = 1
If InStr(1, strRecip, ";") > 0 Then
.RecipDisplayName = Microsoft.VisualBasic.Left(strRecip, InStr(1, strRecip, ";") - 1)
strRecip = Mid(strRecip, InStr(1, strRecip, ";") + 1)
i = i + 1
Else
If (strRecip <> "") Then
.RecipDisplayName = strRecip
End If
Exit Do
End If
Loop
GetDispatchForm = New FrmDispatch
If g_sidCustomization = "Nebrasky" And GetDispatchForm.rdddlText.SelectedIndex = 1 Then
.MsgSubject = Replace(rdtxtfpSubject.Text, Chr(10), " ")
Else
.MsgSubject = "Text Message " & Date.Now
End If
If tmpTextCapacity <= 0 Or (Not IsNumeric(Microsoft.VisualBasic.Left(.RecipDisplayName, InStr(1, .RecipDisplayName, "#") - 1))) Then
.MsgNoteText = strText
J = 0
Else
.MsgNoteText = Microsoft.VisualBasic.Left(strText, tmpTextCapacity)
End If
.Send()
End With
strText = Mid(strText, tmpTextCapacity + 1)
J = J - tmpTextCapacity
Loop

Related

Optimizing Copy and Paste from one workbook to another in VBA

I have several .xlsm templates in a folder. I'm trying to read through all the excel files in that folder and based on the type of the file, it reads through all the sheets in each file and copy specific cells into another my active workbook (ThisWorkbook).
Following is my code and it is working correctly. However it is super slow. I'm looking for any solution that can speed up the code. I've already tried Application.ScreenUpdating = False but still it is very slow. It takes about 10 min for 20 files to be processed.
DO you guys have any suggestion on how to increase the speed.
Thanks Veru mich in Advance
...
Application.ScreenUpdating = False
FileType = "*.xls*"
OutputRow = 5
Range("$B$6:$M$300").ClearContents
filepath = Range("$B$3") & "\"
ThisWorkbook.ActiveSheet.Range("B" & OutputRow).Activate
OutputRow = OutputRow + 1
Curr_File = Dir(filepath & FileType)
Do Until Curr_File = ""
Set FldrWkbk = Workbooks.Open(filepath & Curr_File, False, True)
ThisWorkbook.ActiveSheet.Range("B" & OutputRow) = Curr_File
OutputRow = OutputRow
For Each sht In FldrWkbk.Sheets
ThisWorkbook.ActiveSheet.Range("C" & OutputRow) = sht.Name
If Workbooks(Curr_File).Worksheets(sht.Name).Range("B7") = "Project Number" Then
For i = 1 To 4
If IsEmpty(Workbooks(Curr_File).Worksheets(sht.Name).Cells(10, 5 + 2 * i)) = False Then
With Workbooks(Curr_File).Worksheets(sht.Name)
MyE = .Cells(10, 5 + 2 * i).Value
MyF = .Cells(11, 5 + 2 * i).Value
End With
With ThisWorkbook.ActiveSheet
.Range("D" & OutputRow).Value = "Unit Weight"
.Range("E" & OutputRow).Value = MyE
.Range("F" & OutputRow).Value = MyF
End With
OutputRow = OutputRow + 1
End If
Next
OutputRow = OutputRow - 1
ElseIf Workbooks(Curr_File).Worksheets(sht.Name).Range("C6") = "PROJECT NUMBER" Then
With Workbooks(Curr_File).Worksheets(sht.Name)
MyE = .Range("$H$9").Value
MyF = .Range("$B$9").Value
End With
With ThisWorkbook.ActiveSheet
.Range("D" & OutputRow).Value = "Specific Gravity"
.Range("E" & OutputRow).Value = MyE
.Range("F" & OutputRow).Value = MyF
End With
ElseIf Workbooks(Curr_File).Worksheets(sht.Name).Range("C6") = "Project Number" Then
With Workbooks(Curr_File).Worksheets(sht.Name)
MyE = .Range("$E$4").Value
MyF = .Range("$R$4").Value
MyG = .Range("$R$5").Value
End With
With ThisWorkbook.ActiveSheet
.Range("D" & OutputRow).Value = "Sieve & Hydrometer"
.Range("E" & OutputRow).Value = MyE
.Range("F" & OutputRow).Value = MyF
.Range("G" & OutputRow).Value = MyG
End With
ElseIf Workbooks(Curr_File).Worksheets(sht.Name).Range("A6") = "PROJECT NUMBER" Then
ThisWorkbook.ActiveSheet.Range("D" & OutputRow).Value = "Moisture Content"
Last = Workbooks(Curr_File).Worksheets(sht.Name).Cells(Rows.Count, "J").End(xlUp).Row
ThisWorkbook.ActiveSheet.Range("I" & OutputRow).Value =
Workbooks(Curr_File).Worksheets(sht.Name).Cells(Last, 10)
ElseIf Workbooks(Curr_File).Worksheets(sht.Name).Range("C5") = "Project Number" Then
With Workbooks(Curr_File).Worksheets(sht.Name)
MyE = .Range("$H$8").Value
MyF = .Range("$B$8").Value
MyG = .Range("$D$8").Value
End With
With ThisWorkbook.ActiveSheet
.Range("D" & OutputRow).Value = "Atterberg Limits"
.Range("E" & OutputRow).Value = MyE
.Range("F" & OutputRow).Value = MyF
.Range("G" & OutputRow).Value = MyG
End With
ElseIf Workbooks(Curr_File).Worksheets(sht.Name).Range("B5") = "Project Number" Then
With Workbooks(Curr_File).Worksheets(sht.Name)
MyE = .Range("$G$4").Value
MyF = .Range("$E$4").Value
MyG = .Range("$E$5").Value
End With
With ThisWorkbook.ActiveSheet
.Range("D" & OutputRow).Value = "Gradation Size"
.Range("E" & OutputRow).Value = MyE
.Range("F" & OutputRow).Value = MyF
.Range("G" & OutputRow).Value = MyG
End With
End If
OutputRow = OutputRow + 1
Next sht
FldrWkbk.Close SaveChanges:=False
Curr_File = Dir
Loop
Set FldrWkbk = Nothing
Application.ScreenUpdating = True
...
I Just realized that the slow performance is due to the formulations that are written in the excel but are linked to the ranges that are pasted from the Macro code. As it was addressed in the previous stack overflow solutions, I simply added "Application.Calculation = xlCalculationManual" in the beginning of the code and "Application.Calculation = xlCalculationAutomatic" at the end of the code and now it is much much faster.
I hope it is also useful to whom is reading this

How Export fpspread to Excel vb6?

I try to export to Excel with the fpsread plugin, but there really is no information on how, I have searched the manual but they only show me how to do it with .net
Will someone have an idea?
I managed to do it was very simple, but wanting to import the titles was the heaviest, but here I leave the code in case any work
Private Sub CmdImportar_Click()
Call Export_Excel(cdgExcel, sprFacturas)
Call HacerBusqueda
End Sub
Public Sub Export_Excel(cdgExcel As CommonDialog, Spread As fpSpread)
Dim Header() As String
Dim I As Integer
Dim j As Integer
Dim x As Integer
With cdgExcel
.CancelError = False
.InitDir = "C:/:"
.Filter = "Excel(*.xls)|*.xls"
.ShowSave
If .filename <> "" Then
Spread.Redraw = False
For I = 1 To Spread.ColHeaderRows
ReDim Header(Spread.MaxCols) As String
Spread.Row = SpreadHeader + (I - 1)
For j = 1 To Spread.MaxCols
Spread.Col = j
Header(j) = Spread.Text & ""
Next j
Spread.MaxRows = Spread.MaxRows + 1
Spread.Row = I
Spread.Action = ActionInsertRow
For j = 1 To Spread.MaxCols
Spread.Col = j
Spread.CellType = Spread.CellType
Spread.TypeHAlign = Spread.TypeHAlign
Spread.TypeVAlign = Spread.TypeVAlign
Spread.Text = Header(j) & ""
Next j
Next I
x = Spread.ExportToExcel(.filename, "Sheet1", "")
For I = 1 To Spread.ColHeaderRows
Spread.Row = 1
Spread.Action = ActionDeleteRow
Next I
If x = True Then
MsgBox .filename & vbNewLine & "Se ha Importado el archivo", vbInformation, "Resultado"
Else
MsgBox "No se ha podido exportar el archivo", vbCritical, "Error"
End If
End If
End With
End Sub

Read WebSocket client data to the server vb.net

Good afternoon. I clarify that I don't know much about WebSockets, but I'm learning about it. I am trying to make a connection between vb.net (server) and browser (client) using WebSocket. Searching on the internet I could make this work (Websocket Server VB.NET - Data Frame) Currently I can send a message from vb.net to the browser, but I have not known how to read the messages that the client sends to the server .. I found a code about it, but I do not understand well how it could be implemented to my code (WebSocket Server, client -> server frame mask)
CLIENT
function connect(host) {
var ws = new WebSocket(host);
ws.onopen = function () {
console('connected');
//ws.send("test");
};
ws.onmessage = function (evt) {
console('reveived data:'+evt.data);
};
ws.onclose = function () {
console('socket closed');
};
SERVER
Imports System.Net.Sockets
Imports System.Threading
Imports System.Net
Public Class Form1
Dim serverTcp As TcpListener
Dim serverThread As Thread
Dim host_ As String = ""
Dim curSocket As Socket
Sub Main()
'' Start server
serverThread = New Thread(AddressOf serverProc)
serverThread.Start()
End Sub
Private Sub serverProc()
Try
'' Listen to port 5665
serverTcp = New TcpListener(System.Net.IPAddress.Parse(host_), 5665)
serverTcp.Start()
Console.WriteLine("Listen to port 5665 ...")
'' Accept any connection
While (True)
curSocket = serverTcp.AcceptSocket()
Dim thread As New Thread(AddressOf clientProc)
thread.Start(curSocket)
End While
Catch ex As Exception
End Try
End Sub
Private Sub clientProc(ByVal sck As Socket)
Try
Dim netStream As New NetworkStream(sck)
Dim netReader As New IO.StreamReader(netStream)
Dim netWriter As New IO.StreamWriter(netStream)
Dim key As String = ""
Console.WriteLine("Accept new connection ...")
'' Reading handshake message
While (True)
Dim line As String = netReader.ReadLine()
If line.Length = 0 Then
Exit While
End If
If (line.StartsWith("Sec-WebSocket-Key: ")) Then
key = line.Split(":")(1).Trim()
End If
Console.WriteLine("Data: " & line)
End While
'' Calculate accept-key
key += "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
key = getSHA1Hash(key)
'' Response handshake message
Dim response As String
response = "HTTP/1.1 101 Switching Protocols" & vbCrLf
response &= "Upgrade: websocket" & vbCrLf
response &= "Connection: Upgrade" & vbCrLf
response &= "Sec-WebSocket-Accept: " & key & vbCrLf & vbCrLf
netWriter.Write(response)
netWriter.Flush()
'' Sending message
SendMessage(sck, "SEND.. VB.NET")
Catch ex As Exception
End Try
End Sub
Sub Msg(t As String)
Console.WriteLine(t)
End Sub
Function getSHA1Hash(ByVal strToHash As String) As String
Dim sha1Obj As New System.Security.Cryptography.SHA1CryptoServiceProvider
Dim bytesToHash() As Byte = System.Text.Encoding.ASCII.GetBytes(strToHash)
Dim result As String
bytesToHash = sha1Obj.ComputeHash(bytesToHash)
result = Convert.ToBase64String(bytesToHash)
Return result
End Function
Sub SendMessage(sck As Socket, message As String)
Dim rawData = System.Text.Encoding.UTF8.GetBytes(message)
Dim frameCount = 0
Dim frame(10) As Byte
frame(0) = CByte(129)
If rawData.Length <= 125 Then
frame(1) = CByte(rawData.Length)
frameCount = 2
ElseIf rawData.Length >= 126 AndAlso rawData.Length <= 65535 Then
frame(1) = CByte(126)
Dim len = CByte(rawData.Length)
frame(2) = CByte(((len >> 8) & CByte(255)))
frame(3) = CByte((len & CByte(255)))
frameCount = 4
Else
frame(1) = CByte(127)
Dim len = CByte(rawData.Length)
frame(2) = CByte(((len >> 56) & CByte(255)))
frame(3) = CByte(((len >> 48) & CByte(255)))
frame(4) = CByte(((len >> 40) & CByte(255)))
frame(5) = CByte(((len >> 32) & CByte(255)))
frame(6) = CByte(((len >> 24) & CByte(255)))
frame(7) = CByte(((len >> 16) & CByte(255)))
frame(8) = CByte(((len >> 8) & CByte(255)))
frame(9) = CByte((len & CByte(255)))
frameCount = 10
End If
Dim bLength = frameCount + rawData.Length
Console.WriteLine(frameCount)
Console.WriteLine(rawData.Length)
Dim reply(bLength + 1) As Byte
Dim bLim = 0
For i = 0 To frameCount - 1
Console.WriteLine(bLim)
reply(bLim) = frame(i)
bLim += 1
Next
For i = 0 To rawData.Length - 1
Console.WriteLine(bLim)
reply(bLim) = rawData(i)
bLim += 1
Next
sck.Send(reply)
End Sub
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
host_ = Dns.GetHostEntry(Dns.GetHostName()).AddressList _
.Where(Function(a As IPAddress) Not a.IsIPv6LinkLocal AndAlso Not a.IsIPv6Multicast AndAlso Not a.IsIPv6SiteLocal) _
.Last() _
.ToString()
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Main()
End Sub
Private Sub btnEnviarMensaje_Click(sender As Object, e As EventArgs) Handles btnEnviarMensaje.Click
SendMessage(curSocket, txtMensaje.Text)
End Sub
End Class
it is simple if you want implement this in your vb.net project
you have to put this code anywhere in your project to calling
you also can use it as a "clientProc" private sub or you also
can insert this code in button1 object if you will click on button
after handshake it will give you return web browser websocket client message
Dim netStream As New NetworkStream(curSocket)
Dim bytesArray(1024) As [Byte]
Dim byteslen As Int32
byteslen = netStream.Read(bytesArray, 0, bytesArray.Length)
If bytesArray.Length > 1 Then
Msg("---------------------------------------------------")
Msg("data type: " & bytesArray(0))
Dim secondByte As Byte = bytesArray(1)
Dim theLength As UInteger = secondByte And 127
Dim indexFirstMask As Integer = 2
If theLength = 126 Then
indexFirstMask = 4
ElseIf theLength = 127 Then
indexFirstMask = 10
End If
Msg("indexFirstMask: " & indexFirstMask)
Dim masks As New List(Of Byte)
Dim x As Integer = indexFirstMask
While (x < indexFirstMask + 4)
masks.Add(bytesArray(x))
x += 1
End While
Dim indexFirstDataByte = indexFirstMask + 4
Dim decoded(byteslen - indexFirstDataByte) As Byte
Dim i As Integer = 0, j As Integer = 0
For i = indexFirstDataByte To byteslen Step 1
Dim mask As Byte = masks(j Mod 4)
Dim encodedByte As Byte = bytesArray(i)
decoded(j) = (encodedByte Xor mask)
j += 1
Next
Console.WriteLine("FROM CLIENT: '" & System.Text.Encoding.UTF8.GetString(decoded) & "'")
'Console.WriteLine("temp " + decoded.ToString)
SendMessage(curSocket, "CONNECTION_OK")
End If

websocket stop responding after handshake

I am building a websocket client (vb.net) with a simple socket.
I'm doing it to have better understanding of it before starting it on embedded project (cc3220).
It seems like i passed the handshake just fine, and after receiving one text frame the data stop to be received.
the websocket server is .net core Azure project works as echo. works great with simple websocket client chrome extension with multiple connections.
here is the log from my VB.NET app, maybe please someone can spot the problem:
--- Sending via socket--
GET http://xxxxxxxx.azurewebsites.net/xxxxxxx HTTP/1.1
Host: xxxxxxxxxx.azurewebsites.net
Connection: Upgrade
Upgrade: WebSocket
Sec-WebSocket-Version: 13
Sec-WebSocket-Key: gnuE6HbBVfsHzYVNLdxxbQ==
--- New pack received---
total bytes:206
72,84,84,80,47,49,46,49,32,49,48,49,32,83,119,105,116,99,104,105,110,103,32,80,114,111,116,111,99,111,108,115,13,10,85,112,103,114,97,100,101,58,32,119,101,98,115,111,99,107,101,116,13,10,83,101,114,118,101,114,58,32,75,101,115,116,114,101,108,13,10,83,101,99,45,87,101,98,83,111,99,107,101,116,45,65,99,99,101,112,116,58,32,84,101,70,54,79,103,112,48,109,79,106,118,102,105,99,70,82,116,90,48,107,105,52,114,83,49,103,61,13,10,88,45,80,111,119,101,114,101,100,45,66,121,58,32,65,83,80,46,78,69,84,13,10,67,111,110,110,101,99,116,105,111,110,58,32,85,112,103,114,97,100,101,13,10,68,97,116,101,58,32,84,117,101,44,32,49,48,32,65,112,114,32,50,48,49,56,32,50,48,58,51,56,58,53,54,32,71,77,84,13,10,13,10,0,
HTTP/1.1 101 Switching Protocols
Upgrade: websocket
Server: Kestrel
Sec-WebSocket-Accept: TeF6Ogp0mOjvficFRtZ0ki4rS1g=
X-Powered-By: ASP.NET
Connection: Upgrade
Date: Tue, 10 Apr 2018 20:38:56 GMT
--- New pack receive---
total bytes:42
129,24,119,101,108,99,111,109,101,32,104,111,119,32,100,111,32,121,111,117,32,100,111,63,13,10,129,14,110,101,119,32,99,111,110,110,101,99,116,105,111,110,32,
welcome how do you do?
new connection
Length: 24 op_code: 1(string data)
-- sending data (string 123) via socket, here there is no respond, the server should echo this ----
Sending string: 123
Sending bytes: 129,3,49,50,51,
Sending string: 123
Sending bytes: 129,3,49,50,51,
--- even when sending data via another websocket client app, the data is not received here, but it does to the third websocket client app ---
VbCode:
Public Class SocketObject
Public socket As Socket = Nothing
Public Const BUFFER_SIZE As Integer = 1024
Public buffer(BUFFER_SIZE) As Byte
End Class 'StateObject
Dim sock As New SocketObject()
Private Sub printbytes(ByVal bytes() As Byte, ByVal size As Int16)
Dim i As Integer = 0
Dim a As String = vbCrLf + "--- New pack receive--- " + vbCrLf + "total bytes:" + size.ToString() + vbCrLf
Dim b As String = ""
For i = 0 To size
a += bytes(i).ToString() + ","
b += Chr(bytes(i))
Next
Dim c As String = ""
If (bytes(0) >= &H0) And (bytes(0) <= &H7F) Then
c = "(0x00 to 0x7F) --> Data... --> 0xFF "
Else
c = "(0x80 to 0xFF) --> Length --> Data..."
c += " Length: " + bytes(1).ToString()
Dim op_code As Byte = bytes(0) And &HF
c += " op_code: " + op_code.ToString()
Select Case op_code
Case 9
c += "(ping) response - Pong"
Dim ascii As Encoding = Encoding.UTF8
Dim request As String = " Pong"
Dim bytesSent As [Byte]() = ascii.GetBytes(request)
bytesSent(0) = &H8A
bytesSent(1) = 4
' Send request to the server.
sock.socket.Send(bytesSent, bytesSent.Length, 0)
Case 10
c += "(pong)"
Case 1
c += "(string data)"
Case 2
c += "(binary data)"
Case 8
c += "(connection close) - response and close"
Dim ascii As Encoding = Encoding.UTF8
Dim request As String = " "
Dim bytesSent As [Byte]() = ascii.GetBytes(request)
bytesSent(0) = &H8
' Send request to the server.
sock.socket.Send(bytesSent, bytesSent.Length, 0)
Case Else
c += "(unknown!!)"
End Select
End If
Me.Dispatcher.Invoke(Windows.Threading.DispatcherPriority.Background, New Delegate_LableAddText(AddressOf LableAddText), a + vbCrLf + b + vbCrLf + c + vbCrLf + vbCrLf)
End Sub
Public Sub Read_Callback(ar As IAsyncResult)
Dim so As SocketObject = CType(ar.AsyncState, SocketObject)
Dim s As Socket = so.socket
Try
Dim read As Integer = s.EndReceive(ar)
If read > 0 Then
Dim frameCount = 2
Dim bytes As Byte() = so.buffer
printbytes(bytes, read)
End If
If (s.Connected = True) Then
s.BeginReceive(so.buffer, 0, SocketObject.BUFFER_SIZE, 0, New AsyncCallback(AddressOf Read_Callback), so)
Else
Me.Dispatcher.Invoke(Windows.Threading.DispatcherPriority.Background, New Delegate_LableAddText(AddressOf LableAddText), "-close-")
End If
Catch
End Try
End Sub
Public Delegate Sub Delegate_LableAddText(ByVal str As String)
''' <summary>
''' Check the received data and see if there is command from the device to check
''' </summary>
''' <param name="str"></param>
Public Sub LableAddText(ByVal str As String)
LblSock.Text += str
End Sub
Private Sub Button3_Click(sender As Object, e As RoutedEventArgs)
sock.socket.Close()
End Sub
Private Function random_sc_key() As String
Dim s As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
Dim r As New Random
Dim sb As New StringBuilder
For i As Integer = 0 To "gnuE6HbBVfsHzYVNLdxxbQ==".Length
Dim idx As Integer = r.Next(0, 35)
sb.Append(s.Substring(idx, 1))
Next
Dim a As String = sb.ToString()
Return "gnuE6HbBVfsHzYVNLdxxbQ=="
End Function
Private Sub BtnConnect_Click(sender As Object, e As RoutedEventArgs)
LblSock.Text = ""
'Set up variables and String to write to the server.
Dim ascii As Encoding = Encoding.UTF8
Dim request As String = "GET http://xxxxxxxxx.azurewebsites.net/xxxxxxxxx HTTP/1.1" + ControlChars.Cr + ControlChars.Lf + "Host: xxxxxxxxx.azurewebsites.net" + ControlChars.Cr + ControlChars.Lf + "Connection: Upgrade" + ControlChars.Cr + ControlChars.Lf + "Upgrade: WebSocket" + ControlChars.Cr + ControlChars.Lf + "Sec-WebSocket-Version: 13" + ControlChars.Cr + ControlChars.Lf + "Sec-WebSocket-Key: " + random_sc_key() + vbCrLf + vbCrLf
Dim bytesSent As [Byte]() = ascii.GetBytes(request)
Dim bytesReceived(255) As [Byte]
Dim hostEntry As IPHostEntry = Nothing
' Get host related information.
hostEntry = Dns.GetHostEntry("xxxxxxxxx.azurewebsites.net")
Dim address As IPAddress
For Each address In hostEntry.AddressList
Dim endPoint As New IPEndPoint(address, 80)
Dim tempSocket As New Socket(endPoint.AddressFamily, SocketType.Stream, ProtocolType.Tcp)
tempSocket.Connect(endPoint)
If tempSocket.Connected Then
sock.socket = tempSocket
Exit For
End If
Next address
If sock.socket Is Nothing Then
MessageBox.Show("Connection failed")
Exit Sub
End If
LblSock.Text += "Sending: " + request
' Send request to the server.
sock.socket.Send(bytesSent, bytesSent.Length, 0)
LblSock.Text += "BeginReceive" + vbCrLf
sock.socket.BeginReceive(sock.buffer, 0, SocketObject.BUFFER_SIZE, 0, New AsyncCallback(AddressOf Read_Callback), sock)
End Sub
Private Sub BtnSendString1_Click(sender As Object, e As RoutedEventArgs)
If (sock.socket.Connected = False) Then
LblSock.Text += vbCrLf + "connection closed" + vbCrLf
Exit Sub
End If
Dim request As String = txtsock.Text
request = "11" & request
Dim ascii As Encoding = Encoding.UTF8
Dim bytesSent As Byte() = ascii.GetBytes(request)
bytesSent(0) = &H81
bytesSent(1) = txtsock.Text.Length
LblSock.Text += vbCrLf + "Sending string: " + txtsock.Text
LblSock.Text += vbCrLf + "Sending bytes: "
Dim i As Int16
For i = 0 To bytesSent.Length - 1
LblSock.Text += bytesSent(i).ToString() + ","
Next
sock.socket.Send(bytesSent)
End Sub
Private Sub BtnCloseSock_Click(sender As Object, e As RoutedEventArgs)
If (sock.socket.Connected = False) Then
LblSock.Text += vbCrLf + "connection closed" + vbCrLf
Exit Sub
End If
Dim request As String = txtsock.Text
request = "1" & request & "1"
Dim ascii As Encoding = Encoding.UTF8
Dim bytesSent As Byte() = ascii.GetBytes(request)
bytesSent(0) = 0
'bytesSent(1) = txtsock.Text.Length
bytesSent(bytesSent.Length - 1) = &HFF
sock.socket.Send(bytesSent)
End Sub
Thanks to Myst that point me to the MASK issue.
here is the fixed code to preform simple text transmit to the server from the client:
Private Sub BtnSendString1_Click(sender As Object, e As RoutedEventArgs)
If (sock.socket.Connected = False) Then
LblSock.Text += vbCrLf + "connection closed" + vbCrLf
Exit Sub
End If
Dim rand As Random = New Random()
Dim masking_key(4) As Byte
Dim i As Integer
masking_key(0) = Convert.ToByte(rand.Next(0, 250))
masking_key(1) = Convert.ToByte(rand.Next(0, 250))
masking_key(2) = Convert.ToByte(rand.Next(0, 250))
masking_key(3) = Convert.ToByte(rand.Next(0, 250))
Dim request As String = txtsock.Text
If (txtsock.Text.Length <= 125) Then
request = "112222" & request
Dim ascii As Encoding = Encoding.UTF8
Dim bytesSent As Byte() = ascii.GetBytes(request)
bytesSent(0) = &H80 Or 1
bytesSent(1) = txtsock.Text.Length Or &H80
bytesSent(2) = masking_key(0)
bytesSent(3) = masking_key(1)
bytesSent(4) = masking_key(2)
bytesSent(5) = masking_key(3)
Dim s As Integer = 0
For i = 6 To bytesSent.Length - 1
bytesSent(i) = bytesSent(i) Xor masking_key(s)
s += 1
If s = 4 Then s = 0
Next
LblSock.Text += vbCrLf + "Sending string: " + txtsock.Text
LblSock.Text += vbCrLf + "Sending bytes: "
For i = 0 To bytesSent.Length - 1
LblSock.Text += bytesSent(i).ToString() + ","
Next
sock.socket.Send(bytesSent)
ElseIf (txtsock.Text.Length <= 65535) Then
request = "11111111" & request
Dim ascii As Encoding = Encoding.UTF8
Dim bytesSent As Byte() = ascii.GetBytes(request)
bytesSent(0) = &H80 Or 1
bytesSent(1) = 126 Or &H80
bytesSent(2) = BitConverter.GetBytes(txtsock.Text.Length)(1)
bytesSent(3) = BitConverter.GetBytes(txtsock.Text.Length)(0)
bytesSent(4) = masking_key(0)
bytesSent(5) = masking_key(1)
bytesSent(6) = masking_key(2)
bytesSent(7) = masking_key(3)
Dim s As Integer = 0
For i = 8 To bytesSent.Length - 1
bytesSent(i) = bytesSent(i) Xor masking_key(s)
s += 1
If s = 4 Then s = 0
Next
LblSock.Text += vbCrLf + "Sending string: " + txtsock.Text
LblSock.Text += vbCrLf + "Sending bytes: "
For i = 0 To bytesSent.Length - 1
LblSock.Text += bytesSent(i).ToString() + ","
Next
sock.socket.Send(bytesSent)
Else
request = "1111111112222" & request
Dim ascii As Encoding = Encoding.UTF8
Dim bytesSent As Byte() = ascii.GetBytes(request)
bytesSent(0) = &H80 Or 1
bytesSent(1) = 126 Or &H80
bytesSent(2) = BitConverter.GetBytes(txtsock.Text.Length)(0)
bytesSent(3) = BitConverter.GetBytes(txtsock.Text.Length)(1)
bytesSent(4) = BitConverter.GetBytes(txtsock.Text.Length)(2)
bytesSent(5) = BitConverter.GetBytes(txtsock.Text.Length)(3)
bytesSent(6) = BitConverter.GetBytes(txtsock.Text.Length)(4)
bytesSent(7) = BitConverter.GetBytes(txtsock.Text.Length)(5)
bytesSent(8) = BitConverter.GetBytes(txtsock.Text.Length)(6)
bytesSent(9) = BitConverter.GetBytes(txtsock.Text.Length)(7)
bytesSent(10) = masking_key(0)
bytesSent(11) = masking_key(1)
bytesSent(12) = masking_key(2)
bytesSent(13) = masking_key(3)
Dim s As Integer = 0
For i = 13 To bytesSent.Length - 1
bytesSent(i) = bytesSent(i) Xor masking_key(s)
s += 1
If s = 4 Then s = 0
Next
LblSock.Text += vbCrLf + "Sending string: " + txtsock.Text
LblSock.Text += vbCrLf + "Sending bytes: "
For i = 0 To bytesSent.Length - 1
LblSock.Text += bytesSent(i).ToString() + ","
Next
sock.socket.Send(bytesSent)
End If
LblSock.ScrollToEnd()
End Sub

VBScript - Windows Patch Verification - Arrays - If Else - For Next

I have been tasked with a requirement to get the current patch level of number of computers within a domain. Currently with the help of code snippets used from many sources I have managed to come-up with the following:
My Approach was to check the July 2017 Patches first and then goto June 2017, then further down up to March 2017. I am quite new to VBScript and need advice :| (Only VBScript can be used due to many restrictions in the Server environments)
' Checks only servers
' Add Respective HotFixID in to respective Array
' Create a new Array if missing in Format "HotFixIDs<YYYY><MM>"
' Add the Array Name as the First in "HotFixIDArray"
'Enter the hotfix number to check for: ONLY the number, no letters here!
ComputerName = "."
Dim status
Dim found
Dim HotFixIDArray()
Set fso = CreateObject("Scripting.FileSystemObject" )
Set file = fso.OpenTextFile("C:\temp\tetran\patchstatus_2017.txt",2,1)
found = 0
HotFixIDArray = Array("HotFixIDs201707","HotFixIDs201706","HotFixIDs201705","HotFixIDs201704","HotFixIDs201703")
For i = 0 To UBound(HotFixIDArray) (
If found = 0 Then
'Check July 2017 Patches
Dim HotFixIDs201707()
HotFixIDs201707 = Array("4032955","4026061","4026059","4025877","4025872","4025674","4025497","4025409","4025398","4025397","4025343","4025341","4025339","4025337","4025336","4025333","4025331","4025240","4022914","4022748","4022746")
For j = 0 To UBound(HotFixIDs201707)
status = CheckParticularHotfix(ComputerName, HotFixIDs201707(j))
If status = True Then
file.writeLine ("The hotfix with number " & HotFixIDs201707(j) & " IS installed.")
found = 1
Exit For
Else
status = False
found = 0
Next
If found = 1 Then
file.writeLine ("2017 July Patch Installed")
Exit For
Else
'Check June 2017 Patches
Dim HotFixIDs201706()
HotFixIDs201706 = Array("3217845","4018106","4019204","4019263","4019264","4021903","4021923","4022008","4022010","4022013","4022715","4022717","4022718","4022719","4022722","4022724","4022726","4022883","4022884","4022887","4024402")
For j = 0 To UBound(HotFixIDs201706)
status = CheckParticularHotfix(ComputerName, HotFixIDs201706(j))
If status = True Then
file.writeLine ("The hotfix with number " & HotFixIDs201706(j) & " IS installed.")
found = 1
Exit For
Else
status = False
found = 0
Next
If found = 1 Then
file.writeLine ("2017 June Patch Installed")
Exit For
Else
'Check May 2017 Patches
Dim HotFixIDs201705()
HotFixIDs201705 = Array("4018196","4018466","4018556","4018821","4018885","4018927","4019149","4019206","4019213","4019214","4019215","4019216","4019472")
For j = 0 To UBound(HotFixIDs201705)
status = CheckParticularHotfix(ComputerName, HotFixIDs201705(j))
If status = True Then
file.writeLine ("The hotfix with number " & HotFixIDs201705(j) & " IS installed.")
found = 1
Exit For
Else
status = False
found = 0
Next
If found = 1 Then
file.writeLine ("2017 May Patch Installed")
Exit For
Else
'Check April 2017 Patches
Dim HotFixIDs201704()
HotFixIDs201704 = Array("3211308","3217841","4014652","4014793","4014794","4015068","4015195","4015217","4015380","4015383","4015546","4015547","4015548","4015549","4015550","4015551","4020535")
For j = 0 To UBound(HotFixIDs201704)
status = CheckParticularHotfix(ComputerName, HotFixIDs201704(j))
If status = True Then
file.writeLine ("The hotfix with number " & HotFixIDs201704(j) & " IS installed.")
found = 1
Exit For
Else
status = False
found = 0
Next
If found = 1 Then
file.writeLine ("2017 April Patch Installed")
Exit For
Else
'Check March 2017 Patches
Dim HotFixIDs201703()
HotFixIDs201703 = Array("3211306","3214051","3217587","3217882","3218362","4011981","4012021","4012212","4012213","4012214","4012215","4012216","4012217","4012373","4012497","4012583","4012584","4012598","4013429","4017018")
For j = 0 To UBound(HotFixIDs201703)
status = CheckParticularHotfix(ComputerName, HotFixIDs201703(j))
If status = True Then
file.writeLine ("The hotfix with number " & HotFixIDs201703(j) & " IS installed.")
found = 1
Exit For
Else
status = False
found = 0
Next
If found = 1 Then
file.writeLine ("2017 March Patch Installed")
Exit For
Else
'Do nothing
'201703 End
'201704 End
'201705 End
'201706 End
'201707 End
If found = 0 Then
'Do nothing
Else
'Do nothing
Else
Exit For
)
Next
File.close
Private Function CheckParticularHotfix(strPuter, strHotfixID)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Version 1.0
' Checks if a particular hotfix is installed or not.
' This function has these 3 return options:
' TRUE, FALSE, <error description>
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strPuter & "\root\cimv2")
If err.number <> 0 Then
CheckParticularHotfix = "WMI could not connect to computer '" & strPuter & "'"
Exit Function 'No reason to continue
End If
strWMIforesp = "Select * from Win32_QuickFixEngineering where HotFixID = 'Q" & strHotfixID &_
"' OR HotFixID = 'KB" & strHotfixID & "'"
Set colQuickFixes = objWMIService.ExecQuery (strWMIforesp)
If err.number <> 0 Then 'if an error occurs
CheckParticularHotfix = "Unable to get WMI hotfix info"
Else 'Error number 0 meaning no error occured
tal = colQuickFixes.count
If tal > 0 Then
CheckParticularHotfix = True 'HF installed
Else
CheckParticularHotfix = False 'HF not installed
End If
End If
Set colQuickFixes = Nothing
Err.Clear
On Error Goto 0
End Function
Finally got around and managed to fix the VBScript :)
'Enter the name of the computer to check: (Replace the dot with a computer name, to connect to a remote computer)
ComputerName = "."
'Creates the FileSystemObject and use it to read the file "patch2017.txt"
Set fso = CreateObject("Scripting.FileSystemObject" )
Set file = fso.OpenTextFile("C:\temp\Patch\patch2017.txt",2,1)
'Variable to identify the installation status
Dim j
j = 0
'July 2017 Patches
'Enter the hotfix number to check for: (ONLY the number, no letters here!)
HotFixID = Array("4032955","4026061","4026059","4025877","4025872","4025674","4025497","4025409","4025398","4025397","4025343","4025341","4025339","4025337","4025336","4025333","4025331","4025240","4022914","4022748","4022746")
For i = 0 To UBound(HotFixID)
status = CheckParticularHotfix(ComputerName, HotFixID(i))
If status = True Then
j = 1
File.WriteLine("July 2017")
Exit For
End If
Next
'June 2017 Patches
HotFixID = Array("3217845","4018106","4019204","4019263","4019264","4021903","4021923","4022008","4022010","4022013","4022715","4022717","4022718","4022719","4022722","4022724","4022726","4022883","4022884","4022887","4024402")
For i = 0 To UBound(HotFixID)
status = CheckParticularHotfix(ComputerName, HotFixID(i))
If status = True Then
j = 1
File.WriteLine("June 2017")
Exit For
End If
Next
'May 2017 Patches
HotFixID = Array("4018196","4018466","4018556","4018821","4018885","4018927","4019149","4019206","4019213","4019214","4019215","4019216","4019472")
For i = 0 To UBound(HotFixID)
status = CheckParticularHotfix(ComputerName, HotFixID(i))
If status = True Then
j = 1
File.WriteLine("May 2017")
Exit For
End If
Next
'April 2017 Patches
HotFixID = Array("3211308","3217841","4014652","4014793","4014794","4015068","4015195","4015217","4015380","4015383","4015546","4015547","4015548","4015549","4015550","4015551","4020535")
For i = 0 To UBound(HotFixID)
status = CheckParticularHotfix(ComputerName, HotFixID(i))
If status = True Then
j = 1
File.WriteLine("April 2017")
Exit For
End If
Next
'March 2017 Patches
HotFixID = Array("3211306","3214051","3217587","3217882","3218362","4011981","4012021","4012212","4012213","4012214","4012215","4012216","4012217","4012373","4012497","4012583","4012584","4012598","4013429","4017018")
For i = 0 To UBound(HotFixID)
status = CheckParticularHotfix(ComputerName, HotFixID(i))
If status = True Then
j = 1
file.WriteLine("March 2017")
Exit For
End If
Next
file.Close
'**************************************
'* Read file and produce and output *
'* Only if the File is not Empty *
'* If File is empty output UNKNOWN *
'**************************************
If (fso.FileExists("C:\temp\Patch\patch2017.txt")) Then
If (fso.GetFile("C:\temp\Patch\patch2017.txt").Size <> 0) Then
Dim firstLine
Set firstLine = fso.OpenTextFile("C:\temp\Patch\patch2017.txt",1)
WScript.Echo firstLine.ReadLine
firstLine.Close
Else
WScript.Echo "UNKNOWN"
End If
End If
'*********************************************************************
'* This Function checks if a particular hotfix is installed or not *
'* This function has these 3 return options: *
'* TRUE, FALSE, <error description> *
'*********************************************************************
Private Function CheckParticularHotfix(strPuter, strHotfixID)
On Error Resume Next
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strPuter & "\root\cimv2")
If err.number <> 0 Then
CheckParticularHotfix = "WMI could not connect to computer '" & strPuter & "'"
Exit Function
End If
strWMIforesp = "Select * from Win32_QuickFixEngineering where HotFixID = 'Q" & strHotfixID &_
"' OR HotFixID = 'KB" & strHotfixID & "'"
Set colQuickFixes = objWMIService.ExecQuery (strWMIforesp)
If err.number <> 0 Then
CheckParticularHotfix = "Unable to get WMI hotfix info"
Else
tal = colQuickFixes.count
If tal > 0 Then
CheckParticularHotfix = True 'HF installed
Else
CheckParticularHotfix = False 'HF not installed
End If
End If
Set colQuickFixes = Nothing
Err.Clear
On Error Goto 0
End Function

Resources