TrasfStringApp

Option Explicit

Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" (ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long

Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long

Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Const WM_SETTEXT = &HC
Private txtLoops As TextBox
Private lblLoops As Label
Private WithEvents cmdSendMessages As CommandButton

Private Function GetControlHandle(ByVal WhichType As String, ByVal WindowTitle As String)
Dim wndHandle As Long, TheType As String, FormType As String

If InIDE Then
'search for an interpreted form

FormType = "ThunderFormDC"
If WhichType = "textbox" Then
TheType = "ThunderTextBox"
ElseIf WhichType = "button" Then
TheType = "ThunderCommandButton"
End If
Else
'search for a compiled form

FormType = "ThunderRT6FormDC"
If WhichType = "textbox" Then
TheType = "ThunderRT6TextBox"
ElseIf WhichType = "button" Then
TheType = "ThunderRT6CommandButton"
End If
End If
wndHandle = FindWindowEx(0, 0, FormType, WindowTitle)
GetControlHandle = FindWindowEx(wndHandle, 0, TheType, vbNullString)
End Function

Public Function InIDE() As Boolean
'This function determines whether or not you're in development mode.

Static TheValue As Boolean
Static RanAlready As Boolean
If RanAlready = True Then
InIDE = TheValue
Else
RanAlready = True
On Error Resume Next
Debug.Print (1 / 0)
TheValue = (Err.Number <> 0)
InIDE = TheValue
End If
End Function

Private Sub cmdSendMessages_Click()
Dim i As Long, max As Long, RetVal As Long, s As String, Result As Long
Dim TheWnd As Long, StartTime As Long, ElapsedTime As String
StartTime = timeGetTime
TheWnd = GetControlHandle("textbox", "SendMessage Receiver")
If TheWnd = 0 Then
MsgBox "Unable To Get hWnd of target!", vbCritical
Else
Screen.MousePointer = vbHourglass
max = Val(txtLoops.Text)
For i = 1 To max
s = "This is message " & i & "."
RetVal = SendMessage(TheWnd, WM_SETTEXT, ByVal 0&, ByVal s)
Next i
Screen.MousePointer = vbDefault
ElapsedTime = Format((timeGetTime - StartTime) / 1000, "#.00")
MsgBox max & " strings sent in " & ElapsedTime & " seconds."
End If
End Sub

Private Sub Form_Load()
'Set the form sizing to pixels

ScaleMode = vbPixels
Caption = "SendMessage Sender"
Height = 900: Width = 4350
'Add textbox

Set txtLoops = Controls.Add("VB.TextBox", "txtLoops")
With txtLoops
.Visible = True
.Move 30, 0, 70, 20
.Text = "1000"
End With
'Add label

Set lblLoops = Controls.Add("VB.Label", "lblLoops")
With lblLoops
.Visible = True
.Move 0, 5, 500, 20
.Caption = "Sendmessages"
End With
'Add button

Set cmdSendMessages = Controls.Add("VB.CommandButton", "cmdSendMessages")
With cmdSendMessages
.Visible = True
.Move 200, 0
.Caption = "Send"
End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set txtLoops = Nothing
Set lblLoops = Nothing
Set cmdSendMessages = Nothing
End Sub

'------------------------------------

'CODE FOR FORM OF 'RECEIVING' PROJECT

'------------------------------------


Option Explicit
Dim Buffer() As String
Private WithEvents txtIncoming As TextBox
Private WithEvents lstDisplay As ListBox

Private Sub Form_Load()
'Adjust form

ScaleMode = vbPixels
Caption = "SendMessage Receiver"
Height = 5000: Width = 9000
'Initialize the string buffer to prevent errors later.

'Though allocated, entry 0 is never used

ReDim Buffer(0 To 0)
'Add 'incoming' textbox

Set txtIncoming = Controls.Add("VB.TextBox", "txtIncoming")
With txtIncoming
.Visible = True
.Height = 20
.Text = ""
End With
'Add 'display' listbox

Set lstDisplay = Controls.Add("VB.ListBox", "lstDisplay")
With lstDisplay
.Visible = True
.AddItem "Click here To refresh the listbox With the received items."
End With
Form_Resize
End Sub

Private Sub Form_Resize()
'Resize the controls inside the form.

If Visible = True Then
txtIncoming.Move 0, 0, ScaleWidth, txtIncoming.Height
lstDisplay.Move 0, txtIncoming.Height, ScaleWidth, ScaleHeight - txtIncoming.Height
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set txtIncoming = Nothing
Set lstDisplay = Nothing
End Sub

Private Sub lstDisplay_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Fill the listbox with all the strings received so far.

Dim i As Long, max As Long, s As String
max = UBound(Buffer, 1)
With lstDisplay
.Clear
For i = 1 To max
.AddItem Buffer(i)
Next i
End With
ReDim Buffer(0 To 0)
End Sub

Private Sub txtIncoming_Change()
'Retrieve incoming data, append to the string array called 'buffer'.

Dim s As String, BufferCtr As Long
s = txtIncoming.Text
BufferCtr = UBound(Buffer, 1) + 1
ReDim Preserve Buffer(0 To BufferCtr)
Buffer(BufferCtr) = s
End Sub