websocket stop responding after handshake - websocket
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
Related
Error on sending mail using Windows application
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
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
VBA convert a binary image to a base64 encoded string for a webpage
I am trying to read in a JPG file and convert the file to a base64 encoded string that can be used as an embedded jpeg on a web page. I found two functions on the web for base64 encoding/decoding in VBA that appear to be well-accepted. The encode/decode process yields my original binary string, so the functions appear to be at least somewhat correct. However the base64 string I am getting is no where near what I get when I use an online tool to convert my image to base64. The base64 string should start: "/9j/4AAQSkZJRgABAQEAUgBSAAD". Instead it is starting with: "Pz8/Pz9BYT8/AD8/Pz8/Pz8/Pz8/Pz8/Pz8". I'm lost as to why I'm not getting the former result and why I'm getting the latter. Am I doing something wrong in my reading of the binary file? Here is my code: Sub TestBase64() Dim bytes, b64 With CreateObject("ADODB.Stream") .Open .Type = ADODB.adTypeBinary .LoadFromFile "c:\temp\TestPic.jpg" bytes = .Read .Close End With Debug.Print bytes b64 = Base64Encode(bytes) Debug.Print vbCrLf + vbCrLf Debug.Print b64 Debug.Print vbCrLf + vbCrLf Debug.Print Base64Decode(CStr(b64)) End Sub ' Decodes a base-64 encoded string (BSTR type). ' 1999 - 2004 Antonin Foller, http://www.motobit.com ' 1.01 - solves problem with Access And 'Compare Database' (InStr) Function Base64Decode(ByVal base64String) 'rfc1521 '1999 Antonin Foller, Motobit Software, http://Motobit.cz Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" Dim dataLength, sOut, groupBegin 'remove white spaces, If any base64String = Replace(base64String, vbCrLf, "") base64String = Replace(base64String, vbTab, "") base64String = Replace(base64String, " ", "") 'The source must consists from groups with Len of 4 chars dataLength = Len(base64String) If dataLength Mod 4 <> 0 Then Err.Raise 1, "Base64Decode", "Bad Base64 string." Exit Function End If ' Now decode each group: For groupBegin = 1 To dataLength Step 4 Dim numDataBytes, CharCounter, thisChar, thisData, nGroup, pOut ' Each data group encodes up To 3 actual bytes. numDataBytes = 3 nGroup = 0 For CharCounter = 0 To 3 ' Convert each character into 6 bits of data, And add it To ' an integer For temporary storage. If a character is a '=', there ' is one fewer data byte. (There can only be a maximum of 2 '=' In ' the whole string.) thisChar = Mid(base64String, groupBegin + CharCounter, 1) If thisChar = "=" Then numDataBytes = numDataBytes - 1 thisData = 0 Else thisData = InStr(1, Base64, thisChar, vbBinaryCompare) - 1 End If If thisData = -1 Then Err.Raise 2, "Base64Decode", "Bad character In Base64 string." Exit Function End If nGroup = 64 * nGroup + thisData Next 'Hex splits the long To 6 groups with 4 bits nGroup = Hex(nGroup) 'Add leading zeros nGroup = String(6 - Len(nGroup), "0") & nGroup 'Convert the 3 byte hex integer (6 chars) To 3 characters pOut = Chr(CByte("&H" & Mid(nGroup, 1, 2))) + _ Chr(CByte("&H" & Mid(nGroup, 3, 2))) + _ Chr(CByte("&H" & Mid(nGroup, 5, 2))) 'add numDataBytes characters To out string sOut = sOut & Left(pOut, numDataBytes) Next Base64Decode = sOut End Function Function Base64Encode(inData) 'rfc1521 '2001 Antonin Foller, Motobit Software, http://Motobit.cz Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" Dim cOut, sOut, i 'For each group of 3 bytes For i = 1 To Len(inData) Step 3 Dim nGroup, pOut, sGroup 'Create one long from this 3 bytes. nGroup = &H10000 * Asc(Mid(inData, i, 1)) + _ &H100 * MyASC(Mid(inData, i + 1, 1)) + MyASC(Mid(inData, i + 2, 1)) 'Oct splits the long To 8 groups with 3 bits nGroup = Oct(nGroup) 'Add leading zeros nGroup = String(8 - Len(nGroup), "0") & nGroup 'Convert To base64 pOut = Mid(Base64, CLng("&o" & Mid(nGroup, 1, 2)) + 1, 1) + _ Mid(Base64, CLng("&o" & Mid(nGroup, 3, 2)) + 1, 1) + _ Mid(Base64, CLng("&o" & Mid(nGroup, 5, 2)) + 1, 1) + _ Mid(Base64, CLng("&o" & Mid(nGroup, 7, 2)) + 1, 1) 'Add the part To OutPut string sOut = sOut + pOut 'Add a new line For Each 76 chars In dest (76*3/4 = 57) 'If (I + 2) Mod 57 = 0 Then sOut = sOut + vbCrLf Next Select Case Len(inData) Mod 3 Case 1: '8 bit final sOut = Left(sOut, Len(sOut) - 2) + "==" Case 2: '16 bit final sOut = Left(sOut, Len(sOut) - 1) + "=" End Select Base64Encode = sOut End Function Function MyASC(OneChar) If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar) End Function
That's some lengthy way to encode. I prefer this: You Need to add reference to Microsoft XML, v6.0 (or v3.0) Sub TestBase64() Dim bytes, b64 With CreateObject("ADODB.Stream") .Open .Type = ADODB.adTypeBinary .LoadFromFile "c:\temp\TestPic.jpeg" bytes = .Read .Close End With Debug.Print bytes b64 = EncodeBase64(bytes) Debug.Print vbCrLf + vbCrLf Debug.Print Left(b64, 100) ' Debug.Print vbCrLf + vbCrLf ' Debug.Print Base64Decode(CStr(b64)) End Sub Private Function EncodeBase64(bytes) As String Dim objXML As MSXML2.DOMDocument Dim objNode As MSXML2.IXMLDOMElement Set objXML = New MSXML2.DOMDocument Set objNode = objXML.createElement("b64") objNode.DataType = "bin.base64" objNode.nodeTypedValue = bytes EncodeBase64 = objNode.Text Set objNode = Nothing Set objXML = Nothing End Function Output (first few characters): /9j/4AAQSkZJRgABAQEAYABgAAD
Invalid procedure call or argument on split mac excel vba
I am not sure why but this cet = Split(strCSV, " - ") causes Run time error 5: Invalid procedure call or argument. strCSV = Trim(cWk.Range("P" & i)): dt = CDate(CLng(cWk.Range("H" & i))) where str = "Cap Style:Snapback - CD / Number:07 / Color:First Avenger(+S$1.50) / Box:none - Only Purchase 3 caps and above - Free Box " Following code works perfectly on windows but it throws error on the above mentioned line Option Explicit Option Compare Text Sub Get_Data() Application.ScreenUpdating = False Dim fName, wkB2 As Workbook, cWk As Worksheet, xWk As Worksheet, frowC As Long, i As Long, j As Long, ch As String, num As String Dim strCSV As String, dt As Date, shtName As String, cet, temp As String, rng As Range, cel As Range, cl As String, rw As Long, toF As String On Error GoTo Err fName = Application.GetOpenFilename If fName <> False Then Set wkB2 = Workbooks.Open(fName): Set cWk = wkB2.Worksheets(1): frowC = cWk.Range("P" & Rows.Count).End(xlUp).Row 'Cap Style:Baseball - CC / Number:04 / Color:Grey(+S$2) / Box:none - Only Purchase 3 caps and above - Free Box 'Cap Style:SnapBack - CC / Number:04 / Color:Grey(+S$1.50) / Box:none - Only Purchase 3 caps and above - Free Box For i = 2 To frowC strCSV = Trim(cWk.Range("P" & i)): dt = CDate(CLng(cWk.Range("H" & i))) If strCSV <> "" And IsDate(dt) Then 'ERROR cet = Split(strCSV, " - "): temp = cet(LBound(cet)): cet = Split(temp, ":"): shtName = Trim(cet(UBound(cet))) For Each xWk In ThisWorkbook.Worksheets If shtName = Trim(xWk.Name) Then Set rng = xWk.Range("E3:BD3") For Each cel In rng If cel.Value = dt Then cet = Split(cel.Address, "$"): cl = cet(UBound(cet) - 1): Exit For End If Next cel cet = Split(strCSV, "Number:"): temp = cet(UBound(cet)): cet = Split(temp, "/"): num = Trim(cet(LBound(cet))) cet = Split(strCSV, " / "): temp = cet(LBound(cet)): cet = Split(temp, " - "): ch = Trim(cet(UBound(cet))): ch = ch & "-" & num Debug.Print "Ch is " & ch Set rng = xWk.Range("A1:A" & xWk.Range("A" & Rows.Count).End(xlUp).Row) For Each cel In rng If cel.Value = ch Then rw = cel.Row: Exit For End If Next cel cet = Split(strCSV, "Color:"): temp = cet(UBound(cet)): cet = Split(temp, "("): toF = Trim(cet(LBound(cet))) For j = rw To rw - 10 Step -1 If Trim(xWk.Range("B" & j)) = toF Then rw = j: Exit For End If Next j Debug.Print "Address is: " & cl & rw & " for row " & i xWk.Range(cl & rw) = cWk.Range("O" & i) Exit For End If Next xWk End If Next i wkB2.Close False Else Exit Sub End If Application.ScreenUpdating = True MsgBox "Done" Exit Sub Err: MsgBox Err.Description End Sub
Update: SplitString now handle multi-character delimiters. We conclude that older versions of Mac Office use the equivalent of VB5. Since the Split function was introduced in VB6. An Invalid procedure call or argument is being thrown because the Split function is not available in VB5. The workaround would be to create a custom function that works like Spli. Split Replacement Function Function SplitString(Text As String, Delimiter As String) Dim arr() As String, s As String Dim i As Long, iEnd As Long, iStart As Long, length As Long length = Len(Delimiter) ReDim Preserve arr(0) iStart = 1 Do iEnd = InStr(Mid(Text, iStart), Delimiter) - 1 If iEnd = -1 Then ReDim Preserve arr(i) arr(i) = Mid(Text, iStart) Exit Do Else ReDim Preserve arr(i) arr(i) = Mid(Text, iStart, iEnd) iStart = iStart + iEnd + length i = i + 1 End If Loop Until iStart = 0 SplitString = arr End Function Here are the tests that I ran Sub BatchTest() Dim strCSV As String, Temp As String, Delimiter As String Dim a strCSV = "Cap Style Snapback - CD / Number 07 / Color First Avenger(+S$1.50) / Box none - Only Purchase 3 caps and above - Free Box" a = SplitString(strCSV, "/") TestSplit strCSV, " / " TestSplit strCSV, " /" TestSplit strCSV, "/" TestSplit strCSV, " Color First" End Sub Sub TestSplit(Text As String, Delimiter As String) Dim arr As Variant, sReplcement As String arr = SplitString(Text, Delimiter) sReplcement = Replace(Text, Delimiter, "|") Debug.Print sReplcement Debug.Print Join(arr, "|") Debug.Print sReplcement = Join(arr, "|") End Sub The Results of the tests Sub TestRegEx() MsgBox RegexExtract("sdi 99090 dfddf sdi 5666", "(sdi \d+)", ", ") = "sdi 99090, sdi 5666" End Sub Function RegexExtract(ByVal text As String, _ ByVal extract_what As String, _ Optional seperator As String = "") As String Dim i As Long, j As Long Dim result As String Dim allMatches As Object Dim RE As Object Set RE = CreateObject("vbscript.regexp") RE.Pattern = extract_what RE.Global = True Set allMatches = RE.Execute(text) For i = 0 To allMatches.count - 1 For j = 0 To allMatches.Item(i).submatches.count - 1 result = result & seperator & allMatches.Item(i).submatches.Item(j) Next Next If Len(result) <> 0 Then result = Right(result, Len(result) - Len(seperator)) End If RegexExtract = result End Function
VBS Script for listing out Outlook Profile Info
I have found some code on the Internet for listing out Outlook Profile Info and I would like to it, but it gives the error: Type mismatch:'[string: "A"]', at line 74 (code 800A000D). I don't know why it's not working. Here is the code: Option Explicit Const HKEY_CURRENT_USER = &H80000001 Const r_PSTGuidLocation = "01023d00" Const r_MasterConfig = "01023d0e" Const r_PSTCheckFile = "00033009" Const r_PSTFile = "001f6700" Const r_keyMaster = "9207f3e0a3b11019908b08002b2a56c2" Const r_ProfilesRoot = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles" Const r_DefaultProfileString = "DefaultProfile" Dim oReg:Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv") Dim arrSubKeys, subkey, strValue, i, pstFile, arrPSTs, DefaultProfileName oReg.GetStringValue HKEY_CURRENT_USER,r_ProfilesRoot,r_DefaultProfileString,DefaultProfileName GetPSTsForProfile(DefaultProfileName) '_____________________________________________________________________________________________________________________________ Function GetPSTsForProfile(p_profileName) Dim strHexNumber, strPSTGuid, strFoundPST oReg.GetBinaryValue HKEY_CURRENT_USER,r_ProfilesRoot & "\" & p_profileName & "\" & r_keyMaster,r_MasterConfig,strValue If IsUsableArray (strValue) Then For Each i In strValue If Len(Hex(i)) = 1 Then strHexNumber = CInt("0") & Hex(i) Else strHexNumber = Hex(i) End If strPSTGuid = strPSTGuid + strHexNumber If Len(strPSTGuid) = 32 Then If IsAPST(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid) Then Wscript.Echo PSTFileName(r_ProfilesRoot & "\" & p_profileName & "\" & _ PSTlocation(r_ProfilesRoot & "\" & p_profileName & "\" & strPSTGuid)) End If strPSTGuid = "" End If Next End If End Function '______________ '_____________________________________________________________________________________________________________________________ Function GetSize(zFile) Dim objFSO:Set objFSO = CreateObject("Scripting.FileSystemObject") dim objFile:Set objFile = objFSO.GetFile(zFile) GetSize = ConvertSize(objFile.Size) End Function '_____________________________________________________________________________________________________________________________ Function ConvertSize(Size) Do While InStr(Size,",") 'Remove commas from size CommaLocate = InStr(Size,",") Size = Mid(Size,1,CommaLocate - 1) & _ Mid(Size,CommaLocate + 1,Len(Size) - CommaLocate) Loop Dim Suffix:Suffix = " Bytes" If Size >= 1024 Then suffix = " KB" If Size >= 1048576 Then suffix = " MB" If Size >= 1073741824 Then suffix = " GB" If Size >= 1099511627776 Then suffix = " TB" Select Case Suffix Case " KB" Size = Round(Size / 1024, 1) Case " MB" Size = Round(Size / 1048576, 1) Case " GB" Size = Round(Size / 1073741824, 1) Case " TB" Size = Round(Size / 1099511627776, 1) End Select ConvertSize = Size & Suffix End Function '_____________________________________________________________________________________________________________________________ Function IsAPST(p_PSTGuid) Dim x, P_PSTGuildValue Dim P_PSTCheck:P_PSTCheck=0 IsAPST=False oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTCheckFile,P_PSTGuildValue If IsUsableArray (P_PSTGuildValue) Then For Each x in (P_PSTGuildValue) P_PSTCheck = P_PSTCheck + Hex(x) Next End If If P_PSTCheck=20 Then IsAPST=True End Function '_____________________________________________________________________________________________________________________________ Function PSTlocation(p_PSTGuid) Dim y, P_PSTGuildValue oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTGuidLocation,P_PSTGuildValue If IsUsableArray (P_PSTGuildValue) Then For Each y In P_PSTGuildValue If Len(Hex(y)) = 1 Then PSTlocation = PSTlocation & CInt("0") & Hex(y) Else PSTlocation = PSTlocation & Hex(y) End If Next End If End Function '_____________________________________________________________________________________________________________________________ Function PSTFileName(p_PSTGuid) Dim z, P_PSTName Dim strString : strString = "" oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTFile,P_PSTName If IsUsableArray (P_PSTName) Then For Each z in P_PSTName If z > 0 Then strString = strString & Chr(z) Next End If PSTFileName = strString End Function '_________________________________________________________________________________________________________ Function ExpandEvnVariable(ExpandThis) Dim objWSHShell:Set objWSHShell = CreateObject("WScript.Shell") ExpandEvnVariable = objWSHShell.ExpandEnvironmentStrings("%" & ExpandThis & "%") End Function '_________________________________________________________________________________________________________ Function IsUsableArray(rvnt)'-- Use this function to test for a Null, Empty or an undimensioned array.'-- Useful b/c some interfaces can hold properties for which if they have a'-- value will be an Array but may also be Null or an undimensioned Array. '-- It assumes that a Null or Empty could potentially be an array but not yet dimensioned. '-- It returns -1 if it is passed a string, long, etc...'-- It returns 0 for an empty array or the number of elements in the first dimension. IsUsableArray = 0 If (VarType(rvnt) And 8192) = 8192 Then IsUsableArray = UBound(rvnt) - LBound(rvnt) + 1 Else If Not (IsEmpty(rvnt) Or IsNull(rvnt)) Then IsUsableArray = -1 End If End Function
The script works on my system if i correct the extra space at line 8 (Windows Messaging Subsystem) It is a big script for what it offers, see here for a smaller one which offers more using the free to download library Redemption at http://www.dimastr.com/redemption/home.htm which is what CDO should have been. set Session = CreateObject("Redemption.RDOSession") const skUnknown = 0, olStoreANSI = 1, olStoreUnicode = 2, skPrimaryExchangeMailbox = 3, skPublicFolders = 5, skDelegateExchangeMailbox = 4 Session.Logon for each Store in Session.Stores if (Store.StoreKind = olStoreANSI) then wscript.echo Store.Name & " - " & Store.PstPath & " " & Store.Name elseif (Store.StoreKind = olStoreUnicode) Then wscript.echo Store.Name & " - " & Store.PstPath ElseIf (Store.StoreKind = skPrimaryExchangeMailbox) or (Store.StoreKind = skDelegateExchangeMailbox) or (Store.StoreKind = skPublicFolders) Then wscript.echo Store.Name & " - " & Store.ServerDN Else wscript.echo Store.Name & " - " & Store.StoreKind End If next