' Dieser Codeteil kommt in ein Module
Option Explicit
 
Public Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type
 
Public Const OPEN_EXISTING = 3
Public Const GENERIC_READ = &H80000000
Public Const GENERIC_WRITE = &H40000000
Public Const GENERIC_EXECUTE = &H20000000
Public Const GENERIC_ALL = &H10000000
Public Const INVALID_HANDLE_VALUE = -1
Public Const FILE_SHARE_READ = &H1
Public Const FILE_SHARE_WRITE = &H2
Public Const FILE_ATTRIBUTE_NORMAL = &H80
 
Public Declare Function WriteFileSimple Lib "kernel32" _
Alias "WriteFile" (ByVal hFile As Long, ByVal lpBuffer _
As String, ByVal nNumberOfBytesToWrite As Long, _
lpNumberOfBytesWritten As Long, ByVal Zero As Long) As Long
 
Public Declare Function ReadFileSimple Lib "kernel32" _
Alias "ReadFile" (ByVal hFile As Long, ByVal lpBuffer As _
String, ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, ByVal Zero As Long) As Long
 
Public Declare Function CreateMailslot Lib "kernel32" _
Alias "CreateMailslotA" (ByVal lpName As String, _
ByVal nMaxMessageSize As Long, ByVal lReadTimeout As Long, _
lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
 
Public Declare Function GetMailslotInfo Lib "kernel32" _
(ByVal hMailslot As Long, lpMaxMessageSize As Long, _
lpNextSize As Long, lpMessageCount As Long, lpReadTimeout _
As Long) As Long
 
Public Declare Function CreateFile Lib "kernel32" Alias _
"CreateFileA" (ByVal lpFileName As String, ByVal _
dwDesiredAccess As Long, ByVal dwShareMode As Long, _
lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal _
dwCreationDisposition As Long, ByVal dwFlagsAndAttributes _
As Long, ByVal hTemplateFile As Long) As Long
 
Public Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
 
Public Declare Function CreateFileNoSecurity Lib "kernel32" _
Alias "CreateFileA" (ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _
ByVal Zero As Long, ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As _
Long) As Long

' Dieser Code kommt in Form1
' Bitte einen CommandButton und einen Timer auf dem
' Form anlegen !
Option Explicit
Dim MailSlot As String
Dim mailSlotHandle As Long
Dim tSA As SECURITY_ATTRIBUTES
 
Public Function MailslotCreate(MailSlotName As String, _
MessageSize As Long, MessageTime As Long) As Long
 
 MailSlot = MailSlotName
 
 mailSlotHandle = CreateMailslot(MailSlot, MessageSize, _
 MessageTime, tSA)
 
  If mailSlotHandle = -1 Then
   MailslotCreate = -1
   Exit Function
  Else
   MailslotCreate = mailSlotHandle
   Exit Function
  End If
 
End Function
 
Public Function MailSlotSend(SendTo As String, SendFrom _
As String, Message As String, Optional MailSlotPath As _
String) As Long
Dim Res As Long
Dim BytesWritten As Long
Dim MailSlotName As String
 
  If MailSlotPath = "" Then
  ' Kein MailSlot angegeben also wird der WinPopUp _
    Path gewaehlt
   MailSlotName = "\" & SendTo & "mailslotmessngr"
   Else
   MailSlotName = MailSlotPath
  End If
 
  Message = SendFrom & Chr(0) & SendTo & Chr(0) & _
  Message & Chr(0)
 
  MailSlot = CreateFileNoSecurity(MailSlotName, _
  GENERIC_WRITE, FILE_SHARE_READ, 0, OPEN_EXISTING, _
  FILE_ATTRIBUTE_NORMAL, 0)
 
  Res = WriteFileSimple(MailSlot, Message, _
  Len(Message), BytesWritten, 0)
 
  Res = CloseHandle(MailSlot)
  MailSlotSend = BytesWritten
End Function
 
Public Function MailSlotRead(msHandle As Long, _
BufferSize As Long) As String
Dim MsgText As String
Dim MsgCount As Long
Dim RC As Long
Dim BytesRead As Long
 
 MsgText = String(BufferSize, 0)
  RC = GetMailslotInfo(msHandle, 0, BufferSize, MsgCount, 0)
 
   If MsgCount > 0 Then
    RC = ReadFileSimple(msHandle, MsgText, _
    Len(MsgText) + 1, BytesRead, 0)
    MailSlotRead = MsgText
    DoEvents
   End If
 
End Function
 
Public Function MailslotClose(Handle As Long)
 CloseHandle (Handle)
End Function
 
Private Sub Command1_Click()
 MailSlotSend "MURPH", "HIER KANN IRGENDWAS STEHEN", _
 "Deine Nachricht"
 ' MURPH = Der Rechnername, an den die Nachricht geht
End Sub
 
Private Sub Form_Load()
 
 tSA.nLength = Len(tSA)
 tSA.lpSecurityDescriptor = 0
 tSA.bInheritHandle = False
 
 Command1.Caption = "Nachricht senden"
 Timer1.Interval = 1
 
 mailSlotHandle = MailslotCreate(".mailslotmessngr", _
 1000, 0)
 Debug.Print mailSlotHandle
  If mailSlotHandle <= 0 Then
   MsgBox ("Fehler. WinPOPUP oder Mailservice geladen ???")
   Unload Me
  End If
End Sub
 
Private Sub Form_QueryUnload(Cancel As Integer, _
UnloadMode As Integer)
 MailslotClose (mailSlotHandle)
End Sub
 
 
Private Sub Timer1_Timer()
Dim mailIN As String
Dim Msg() As String
Dim Posi As Long, Posi2 As Long, Pos2 As Long
ReDim Msg(2)
 
  mailIN = MailSlotRead(mailSlotHandle, 400)
 
  If mailIN <> "" Then
   mailIN = MailSlotRead(mailSlotHandle, 400)
   mailIN = Mid(mailIN, Pos2 + 5, Len(mailIN))
   Posi = InStr(1, mailIN, Chr(0))
   Msg(0) = Left$(mailIN, Posi - 1)
   Posi2 = InStr(Posi + 1, mailIN, Chr(0))
   Msg(1) = Mid(mailIN, Posi + 1, Posi2 - Posi - 1)
   Msg(2) = Mid(mailIN, Posi2 + 1, Len(mailIN))
   mailIN = ""
 
   MsgBox "Nachricht von " & Msg(0) & vbCrLf & _
   "Nachricht an " & Msg(1) & vbCrLf & _
   Msg(2), vbInformation, "Neue Nachricht :->"
 
  End If
 
End Sub