Imports System.Runtime.InteropServices

Module m_NamedSharedMemory

  'Creating Named Shared Memory
  'https://msdn.microsoft.com/en-US/library/windows/desktop/aa366551(v=vs.85).aspx

  'Memory Management Functions

  'flProtect - Specifies the page protection of the file mapping object. All mapped views of the object must be compatible with this protection.
  Public Const PAGE_READWRITE As Integer = &H4

  Public Declare Unicode Function CreateFileMapping Lib "kernel32" _
   Alias "CreateFileMappingW" (ByVal hFile As IntPtr, _
   ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal flProtect As Integer, _
   ByVal dwMaximumSizeHigh As Integer, ByVal dwMaximumSizeLow As Integer, _
   ByVal lpName As String) As IntPtr

  'dwDesiredAccess - The type of access to a file mapping object, which determines the protection of the pages.
  Public Const FILE_MAP_WRITE = &H2
  Public Const FILE_MAP_READ = &H4

  Public Declare Unicode Function OpenFileMapping Lib "kernel32" _
   Alias "OpenFileMappingW" (ByVal dwDesiredAccess As Integer, _
   ByVal bInheritHandle As Boolean, _
   ByVal lpName As String) As IntPtr
  Public Declare Unicode Function MapViewOfFile Lib "kernel32" (ByVal hFileMappingObject As IntPtr, _
   ByVal dwDesiredAccess As Integer, _
   ByVal dwFileOffsetHigh As Integer, ByVal dwFileOffsetLow As Integer, _
   ByVal dwNumberOfBytesToMap As IntPtr) As IntPtr
  Public Declare Function UnmapViewOfFile Lib "kernel32" (ByVal lpBaseAddress As IntPtr) As Boolean

  'Handle and Object Functions
  Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As IntPtr) As Boolean

  Public Function CreateMapFile(ByVal f_name As String, Optional ByVal FullAccess As Boolean = False) As IntPtr
    Dim SA As SECURITY_ATTRIBUTES
    If FullAccess Then SA = CreateMailslotSecurityFullAccess()
    CreateMapFile = CreateFileMapping(INVALID_HANDLE_VALUE, SA, PAGE_READWRITE, 0, 256, f_name)
    If CreateMapFile = IntPtr.Zero Then
      'Debug.Print("CreateFileMapping Error " & RaiseAPIError())
    End If
  End Function

  Public Sub CloseMapFile(ByVal hMapFile As IntPtr)
    If hMapFile <> IntPtr.Zero Then CloseHandle(hMapFile)
  End Sub

  Public Sub WriteMapFileString(ByVal hMapFile As IntPtr, ByVal the_str As String)
    If hMapFile = IntPtr.Zero Then Exit Sub
    Dim pBuf As IntPtr
    pBuf = MapViewOfFile(hMapFile, FILE_MAP_WRITE, 0, 0, 256)
    If pBuf = IntPtr.Zero Then
      'Debug.Print("MapViewOfFile Error " & RaiseAPIError())
      Exit Sub
    End If

    Dim t_bData As Byte() = System.Text.Encoding.Unicode.GetBytes(the_str & Chr(0))
    Marshal.Copy(t_bData, 0, pBuf, t_bData.Length)

    UnmapViewOfFile(pBuf)
  End Sub

  Public Function ReadMapFileString(ByVal f_name As String) As String
    ReadMapFileString = ""

    Dim hMapFile As IntPtr
    Dim pBuf As IntPtr

    hMapFile = OpenFileMapping(FILE_MAP_READ, False, f_name)
    If hMapFile = IntPtr.Zero Then
      'Debug.Print("OpenFileMapping Error " & RaiseAPIError())
      Exit Function
    End If

    pBuf = MapViewOfFile(hMapFile, FILE_MAP_READ, 0, 0, 256)
    If pBuf = IntPtr.Zero Then
      'Debug.Print("MapViewOfFile Error " & RaiseAPIError())
      CloseHandle(hMapFile)
      Exit Function
    End If

    Dim bytData As Byte() = New Byte(255) {}
    Marshal.Copy(pBuf, bytData, 0, 256)
    Dim the_str = System.Text.Encoding.Unicode.GetString(bytData, 0, 256)
    If InStr(the_str, Chr(0)) > 0 Then
      the_str = Strings.Left(the_str, InStr(the_str, Chr(0)) - 1)
    End If
    ReadMapFileString = the_str

    UnmapViewOfFile(pBuf)
    CloseHandle(hMapFile)

  End Function

End Module

  Public Function CreateMailslotSecurityFullAccess() As SECURITY_ATTRIBUTES
    ' Define the SDDL for the security descriptor. 
    'DACL + OBJECT_INHERIT_ACE/CONTAINER_INHERIT_ACE + GENERIC_ALL (полный доступ) + SECURITY_WORLD_RID (группа "EveryOne")
    Dim sddl As String = "D:(A;OICI;GA;;;WD)"

    Dim pSecurityDescriptor As IntPtr
    Dim sa As New SECURITY_ATTRIBUTES
    If ConvertStringSecurityDescriptorToSecurityDescriptor(sddl, SDDL_REVISION_1, pSecurityDescriptor, IntPtr.Zero) Then
      sa.nLength = Marshal.SizeOf(sa)
      sa.lpSecurityDescriptor = pSecurityDescriptor
      sa.bInheritHandle = False
    End If

    Return sa
  End Function