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

Resources