Copy Notes URL Link to Clipboard

Ever had the need to embed a link to the current document into a non-Notes email or product?  I don't mean an HTTP URL.  I'm talking about a URL that will open the document in your Lotus Notes client al-la "notes://server/db/view/document".  Here is some code that can be added to an action button to do just that.  Once you've clicked the button, a URL will be in the clipboard read for pasting into another application!

 %REM
    Copy Data to Clipboard  
%END REM
 
Option Declare
Const GMEM_MOVEABLE = &H40
Const GMEM_ZEROINIT = &H2
Const CF_TEXT = &H01

Declare Function OpenClipboard Lib "user32" Alias "OpenClipboard" (Byval hwnd As Long) As Long
Declare Function CloseClipboard Lib "user32" Alias "CloseClipboard" () As Long
Declare Function EmptyClipboard Lib "user32" Alias "EmptyClipboard" () As Long
Declare Function GetClipboardData Lib "user32" Alias "GetClipboardData" (Byval wFormat As Long) As Long
Declare Function SetClipboardData Lib "user32" Alias "SetClipboardData" (Byval wFormat As Long, Byval hMem As Long) As Long
Declare Function IsClipboardFormatAvailable Lib "user32" Alias "IsClipboardFormatAvailable" (Byval wFormat As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" Alias "GlobalAlloc" (Byval wFlags As Long, Byval dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" Alias "GlobalLock" (Byval hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" Alias "GlobalUnlock" (Byval hMem As Long) As Long
Declare Function GlobalSize Lib "kernel32" Alias "GlobalSize" (Byval hMem As Long) As Long
Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (Byval lpString1 As Long, Byval lpString2 As String) As Long
Declare Function NEMGetCurrentSubprogramWindow Lib "nnotesws.dll" () As Long
Sub SetClipboardText(Text As String)
  
    Dim hwnd As Long
    Dim hGlobalMemory As Long
    Dim lpGlobalMemory As Long
    Dim ret As Long
  
    On Error Goto error_handler
  
    ' Get a handle to current window
    hwnd = NEMGetCurrentSubProgramWindow()
    If hwnd Then
      
        ' Allocate memory
        hGlobalMemory = GlobalAlloc(Clng(GMEM_MOVEABLE Or GMEM_ZEROINIT), Clng(Len(Text)+1))
        If hGlobalMemory Then
            lpGlobalMemory = GlobalLock(hGlobalMemory)
            If lpGlobalMemory Then
                ret = lstrcpy(lpGlobalMemory, Text)
                Call GlobalUnlock(hGlobalMemory)
                If OpenClipboard(hwnd) Then
                    ret = EmptyClipboard()
                    ret = SetClipboardData(CF_TEXT, hGlobalMemory)
                    ret = CloseClipboard()
                End If
            Else
                Msgbox "Can't allocated global memory pointer.", 32, "Error"
            End If
        Else
            Msgbox "Can't allocated global memory handle.", 32, "Error"
        End If
    Else
        Msgbox "Can't get window handle.", 32, "Error"
    End If
    Exit Sub
  
error_handler:
    Print "Error: " + Error$(Err)
    Resume Next
  
End Sub
Sub Click(Source As Button)
    Dim s As New NotesSession
    Dim ws As New NotesUIWorkspace
    Dim db As NotesDatabase
    Dim uiDoc As NotesUIDocument
    Dim plainText As String
    Dim x As String
  
    Set db = s.CurrentDatabase
    Set uiDoc = ws.CurrentDocument
    plainText = uiDoc.Document.NotesURL 'Get the Notes URL for the Document  
    setclipboardtext(plainText)
    Msgbox "Document URL copied to clipboard.", 0+64, "Successful"  
End Sub