'MacroName:SirsiCopyUnicode
'MacroDescription:Copy a field to the Clipboard in a format suitable for pasting into a SirsiDynix Workflows with Unicode
'Macro written by: Joel Hahn, Niles Public Library District
'Macro last modified: 9 February 2017

Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function OpenClipboard Lib "user32" Alias "OpenClipboard" (ByVal hwnd As Long) As Long
Declare Function GetClipboardData Lib "user32" Alias "GetClipboardData" (ByVal wFormat As Long) As Long
Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function CloseClipboard Lib "user32" Alias "CloseClipboard" () As Long
Declare Function GlobalAlloc Lib "kernel32" (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 lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)
Declare Function EmptyClipboard Lib "user32" () As Long

Option Explicit

Declare Function GetClip() As String
Declare Function PointerToStringA(lpStringA As Long) As String
Declare Sub SetClip(ByRef Buffer() As Integer)
Declare Function ConvertText(UCode)

Sub Main

   Dim CopyWhich
   'Select whether to always copy the entire field or just the selected text
   
   CopyWhich = 0 'Copy entire field
   'CopyWhich = 1 'Copy only selected text

   Dim CS As Object
   On Error Resume Next
   Set CS  = GetObject(,"Connex.Client")
   On Error GoTo 0
   If CS  Is Nothing Then
      Set CS  = CreateObject("Connex.Client")
   End If
   
   Dim sField, place, place2, UCode
   Dim OldField, NewField, TransChar
   dim numUCode, sFieldTest, bool
      Dim d As Integer
      Dim lt As String
      Dim rt As String
      Dim md As String

   'Handle non-Unicode fields
   ' ### Note: currently doesn't translate diacritics from ANSEL to Unicode
   ' ### GetClip omits left & right diacritics, so it's not 100% reliable
   ' ### This text would have to be be parsed into an array and have diacritics "fixed" then sent to SetClip
   If CopyWhich = 0 Then
      bool = CS.GetFieldLine(CS.CursorRow, sField)
   Else
      bool = CS.GetSelectedText(sField)
   End If
   If sField <> "Data contains non-latin script" Then
      If CopyWhich = 0 Then
         sField = Mid(sField, 6)
      End If
      Do While InStr(sField, Chr(223))
         place = InStr(sField, Chr(223))
         If place > 1 Then
            sField = RTrim(Left(sField, place-1)) & "|" & Mid(sField, place+1, 1) & LTrim(Mid(sField, place + 2))
         Else
            sField = "|" & Mid(sField, place+1, 1) & LTrim(Mid(sField, place + 2))
         End If
      Loop
      
      'Switch diacritics to Unicode versions
      d = 1
      Dim bb, cc
      Do While d <= Len(sField)
        If d > 1 Then lt = Left(sField, d - 1) Else lt = ""
        rt = Mid(sField, d + 1)
        bb = Asc(Mid(sField, d, 1))
        cc = Mid(sField, d, 1)
        Select Case Asc(Mid(sField, d, 1))
          Case 226 'Acute
             md = "~~301~~"
          Case 181 'ae lowercase
             md = "~~E6~~"
          Case 165 'AE uppercase
             md = "~~C6~~"
          Case 174 'Alif
             md = "~~2BC~~"
          Case 176 'Ayn
             md = "~~2BB~~"
          Case 230 'Breve
             md = "~~306~~"
          Case 185 'British pound
             md = "~~A3~~"
          Case 239 'Candrabindu
             md = "~~310~~"
          Case 240 'Cedilla
             md = "~~327~~"
          Case 234 'Circle above letter
             md = "~~30A~~"
          Case 244 'Circle below letter
             md = "~~325~~"
          Case 227 'Circumflex, non-spacing
             md = "~~302~~"
          Case 202 'Copyright
             md = "~~169~~"
          Case 179 'd with crossbar, lowercase
             md = "~~111~~"
          Case 163 'D with crossbar, uppercase / Eth, uppercase
             md = "~~110~~"
          Case 158 'Degree sign
             md = "~~B0~~"
          Case 242 'Dot below letter
             md = "~~323~~"
          Case 168 'Dot in center of line
             md = "~~B7~~"
          Case 238 'Double acute
             md = "~~30B~~"
          Case 243 'Double dot below letter
             md = "~~324~~"
          Case 250 'Double tilde (left half)
             md = "~~FE22~~"
          Case 251 'Double tilde (right half)
             md = "~~FE23~~"
          Case 245 'Double underscore
             md = "~~333~~"
          Case 159 'Eszett
             md = "~~DF~~"
          Case 186 'Eth, lowercase
             md = "~~F0~~"
          Case 160 'Euro
             md = "~~20AC~~"
          Case 252 'Fill character
             md = "~~220E~~"
          Case 225 'Grave, non-spacing
             md = "~~300~~"
          Case 233 'Hacek
             md = "~~30C~~"
          Case 254 'High comma, centered
             md = "~~313~~"
          Case 237 'High comma, off center
             md = "~~315~~"
          Case 248 'Inverted cedilla
             md = "~~31C~~"
          Case 201 'Inverted exclamation point
             md = "~~A1~~"
          Case 200 'Inverted question mark
             md = "~~BF~~"
          Case 177 'l with slash, lowercase
             md = "~~142~~"
          Case 161 'L with slash, uppercase
             md = "~~141~~"
          Case 247 'Left hook
             md = "~~321~~"
          Case 235 'Ligature (left half)
             md = "~~FE20~~"
          Case 236 'Ligature (right half)
             md = "~~FE21~~"
          Case 229 'Macron
             md = "~~304~~"
          Case 167 'Miagkii znak / Prime
             md = "~~2032~~"
          Case 169 'Musical flat
             md = "~~266D~~"
          Case 204 'Musical sharp
             md = "~~266F~~"
          Case 188 'o with hook, lowercase
             md = "~~1A1~~"
          Case 172 'O with hook, uppercase
             md = "~~1A0~~"
          Case 178 'o with slash, lowercase
             md = "~~F8~~"
          Case 162 'O with slash, uppercase
             md = "~~D8~~"
          Case 182 'oe, lowercase
             md = "~~153~~"
          Case 166 'OE, uppercase
             md = "~~152~~"
          Case 203 'Phonogram copyright mark
             md = "~~2117~~"
          Case 171 'Plus/minus
             md = "~~B1~~"
          Case 224 'Pseudo question mark
             md = "~~309~~"
          Case 241 'Right hook
             md = "~~328~~"
          Case 190 'Script lowercase L
             md = "~~2113~~"
          Case 144 'Subscript 0
             md = "~~2080~~"
          Case 145 'Subscript 1
             md = "~~2081~~"
          Case 146 'Subscript 2
             md = "~~2082~~"
          Case 147 'Subscript 3
             md = "~~2083~~"
          Case 148 'Subscript 4
             md = "~~2084~~"
          Case 149 'Subscript 5
             md = "~~2085~~"
          Case 150 'Subscript 6
             md = "~~2086~~"
          Case 151 'Subscript 7
             md = "~~2087~~"
          Case 152 'Subscript 8
             md = "~~2088~~"
          Case 153 'Subscript 9
             md = "~~2089~~"
          Case 154 'Subscript left parenthesis
             md = "~~208D~~"
          Case 156 'Subscript minus
             md = "~~208B~~"
          Case 170 'Subscript patent mark / registered trademark
             md = "~~AE~~"
          Case 157 'Subscript plus
             md = "~~208A~~"
          Case 155 'Subscript right parenthesis
             md = "~~208E~~"
          Case 231 'Superior dot
             md = "~~307~~"
          Case 128 'Superscript 0
             md = "~~2070~~"
          Case 129 'Superscript 1
             md = "~~2071~~"
          Case 130 'Superscript 2
             md = "~~2072~~"
          Case 131 'Superscript 3
             md = "~~2073~~"
          Case 132 'Superscript 4
             md = "~~2074~~"
          Case 133 'Superscript 5
             md = "~~2075~~"
          Case 134 'Superscript 6
             md = "~~2076~~"
          Case 135 'Superscript 7
             md = "~~2077~~"
          Case 136 'Superscript 8
             md = "~~2078~~"
          Case 137 'Superscript 9
             md = "~~2079~~"
          Case 138 'Superscript left parenthesis
             md = "~~207D~~"
          Case 141 'Superscript minus
             md = "~~207B~~"
          Case 140 'Superscript plus
             md = "~~207A~~"
          Case 139 'Superscript right parenthesis
             md = "~~207E~~"
          Case 180 'Thorn, lowercase
             md = "~~FE~~"
          Case 164 'Thorn, uppercase
             md = "~~DE~~"
          Case 228 'Tilde, non-spacing
             md = "~~303~~"
          Case 184 'Turkish i without dot, lowercase
             md = "~~131~~"
          Case 183 'Tverdyi znak / double prime
             md = "~~2033~~"
          Case 189 'u with hook, lowercase
             md = "~~1B0~~"
          Case 173 'U with hook, uppercase
             md = "~~1AF~~"
          Case 232 'Umlaut
             md = "~~308~~"
          Case 246 'Underscore, non-spacing
             md = "~~332~~"
          Case 249 'Upadhmaniya
             md = "~~32E~~"
          Case Else
            md = Mid(sField, d, 1)
        End Select
        d = d + 1
        If md <> Mid(sField, d, 1) Then d = d + Len(md) - 1
        sField = lt & md & rt
      Loop

If InStr(sField, "~~") = 0 Then
      Clipboard.Clear
      Clipboard.Settext sField
Else

  Dim i As Integer
  Dim j As Integer
  Dim bStrArray() As Integer
  ReDim bStrArray(0)
  
   OldField = sField
   i = 0 : j = 0
   Do
      ReDim Preserve bStrArray(j)
      place = 1  'InStr(sField, "|")
      If Mid(sField, place, 2) <> "~~" Then
         'process non-Unicode characters
         'NewField = NewField & Left(sField, place - 1)
         If Mid(sField, place, 1) <> " " Then
            bStrArray(j) = Asc(Mid(sField, place, 1))
            j = j + 1
            sField = Mid(sField, 2)
         Else
           'check for delimiters
           'If Mid(sField, place + 1, 5) = "|1C2|" Then
           '  bStrArray(j) = Asc("|")
           '  bStrArray(j+1) = Asc(Mid(sField, place + 6, 1))
           '  j = j + 2
           '  sField = Mid(sField, 7)
           'End If
           If UBound(bStrArray) > 1 Then
      '        If bStrArray(j-2) = 124 Then
      '           'Omit space following subfield code
      '        Else
                bStrArray(j) = Asc(Mid(sField, place, 1))
                j = j + 1
      '        End If
           End If
           sField = Mid(sField, 2)
         End If
      Else
         'process Unicode characters
         place2 = InStr(place + 1, sField, "~~")
         UCode = Mid(sField, place + 2, place2 - place - 2)
         sField = Mid(sField, place2 + 2)

         If UCode = "1C2" Then
            If j > 1 Then
              If bStrArray(j-1) = 32 Then
                bStrArray(j-1) = Asc("|")
              Else
                bStrArray(j) = Asc("|")
                j = j + 1
              End If
            Else
               bStrArray(j) = Asc("|")
               j = j + 1
            End If
         Else
           'TransChar = ConvertText(UCode)
           bStrArray(j) = Val("&H" & UCode)
           j = j + 1       
         End If
      End If

   Loop While Len(sField) > 0  'i <= Len(sField)
   If bStrArray(UBound(bStrArray)) <> Chr(0) Then ReDim Preserve bStrArray(UBound(bStrArray) + 1)
  
   Call SetClip(bStrArray())
End If

      Exit Sub
   End If

   If CopyWhich = 0 Then
     'CS.CopyField
     bool = CS.GetFieldLineUnicode(CS.CursorRow, sField)
   ElseIf CopyWhich = 1 Then
     CS.CopySelected
     sField = GetClip()
   Else
     MsgBox "Invalid CopyWhich value. Exiting..."
     Exit Sub
   End If
   'Omit the tag & indicators if copying entire field
   If CopyWhich = 0 Then sField = Mid(sField, 6)

If InStr(sField, "|") = 0 And InStr(sField, "&#x") = 0 And InStr(sField, "1C2") = 0 And InStr(sField, Chr(223)) = 0 Then
   'No subfields, diacritics, or Unicode characters, so already-copied data is sufficient
   'Just trim off the tag & indicators if they're present
   'If CopyWhich = 0 Then
   '   Clipboard.Clear
   '   Clipboard.Settext sField
   'Else
      Dim Cliptext
      Cliptext = Clipboard.GetText()
      Cliptext = Mid(Cliptext, 6)
      Clipboard.Clear
      Clipboard.Settext Cliptext
   'End If

   Exit Sub
Else

  ' ### GetClip omits left & right ligatures, so any present in the text will have to be put back manually, but other diacritics should go to the Unicode handler
  ' ### The following Do...Loop works around that when copying an entire field, via GetFieldLineUnicode, but there is no equivalent for selected text
  
  ' ### GetFieldLineUnicode sometimes messes up diacritics in fields with Unicode, and leaves them as is rather than converting to HTML entities
  ' It seems to primarily affect most (but not all) special characters, and not diacritics; for example:
  ' ae-lowercase => Chr(181)
  ' AE-uppercase => Chr(165)
  ' British pound => Chr(185)
  ' Copyright => Chr(202)
  ' Degree sign => Chr(158)
  ' Dot in middle
  ' Eszett
  ' eth, lowercase
  ' Eth, uppercase / D with crossbar => correct
  ' Euro => correct
  ' Inverted exclamation
  ' Inverted question
  ' Fill => correct
  ' l with slash, lowercase => correct
  ' L with slash, lowercase => correct
  ' Miyagkii znak / prime => correct
  ' Musical flat => correct
  ' Musical sharp => correct
  ' o with hook, lowercase => correct
  ' o with hook, uppercase => correct
  ' o with slash, lowercase
  ' O with slash, uppercase
  ' oe-ligature => correct
  ' OE-ligature => correct
  ' Plus-minus
  ' script L => correct
  ' subscript 0-9 => correct
  ' superscript 0, 4-9 => correct
  ' superscript 1 => Chr(129)
  ' superscript 2 = Chr(130)
  ' superscript 3 => Chr(131)
  ' Registered TM => Chr(170)
  ' thorn, lowercase
  ' Thorn, uppercase
  ' Turkish i => correct
  ' Tverdyii znak / double prime => correct
  ' u with horn => correct
  ' U with horn => correct
  Do While InStr(sField, "&#x") 
    place = InStr(sField, "&#x")
    Mid(sField, place + 7, 1) = "|"
    If place > 1 Then
      lt = Left(sField, place - 1)
    Else
      lt = ""
    End If
    rt = Mid(sField, place + 3)
    sField = lt & "|" & rt
  Loop

  'Dim i As Integer
  'Dim j As Integer
  'Dim bStrArray() As Integer
  ReDim bStrArray(0)
  
   OldField = sField
   i = 0 : j = 0
   Do
      ReDim Preserve bStrArray(j)
      place = 1  'InStr(sField, "|")
      If Mid(sField, place, 1) <> "|" Then
         'process non-Unicode characters
         'NewField = NewField & Left(sField, place - 1)
         If Mid(sField, place, 1) <> " " Then
            bStrArray(j) = Asc(Mid(sField, place, 1))
            j = j + 1
            sField = Mid(sField, 2)
         Else
           'check for delimiters
           If Mid(sField, place+1, 6) = "|01C2|"  Then
             'ReDim Preserve bStrArray(j+1)
             bStrArray(j) = Asc("|")
             'bStrArray(j+1) = Asc(Mid(sField, place + 7, 1))
             j = j + 1 '2
             sField = Mid(sField, 7)
           End If
           If UBound(bStrArray) > 1 Then
              If bStrArray(j-2) = 124 Then
                 'Omit space following subfield code
              'Else
              '  bStrArray(j) = Asc(Mid(sField, place, 1))
              '  j = j + 1
              End If
           End If
           sField = Mid(sField, 2)
         End If
      Else
         'process Unicode characters
         place2 = InStr(place + 1, sField, "|")
         UCode = Mid(sField, place + 1, place2 - place - 1)
         sField = Mid(sField, place2 + 1)

         If UCode = "1C2" Then
            If j > 1 Then
              If bStrArray(j-1) = 32 Then
                bStrArray(j-1) = Asc("|")
              Else
                bStrArray(j) = Asc("|")
                j = j + 1
              End If
            Else
               bStrArray(j) = Asc("|")
               j = j + 1
            End If
         Else
           'TransChar = ConvertText(UCode)
           bStrArray(j) = Val("&H" & UCode)
           j = j + 1       
         End If
      End If

   Loop While Len(sField) > 0  'i <= Len(sField)
   If bStrArray(UBound(bStrArray)) <> Chr(0) Then ReDim Preserve bStrArray(UBound(bStrArray) + 1)
  
   Call SetClip(bStrArray())
End If
    
End Sub

'################################################################################

Function GetClip() As String
   Dim CF_DSPTEXT As Integer
   Dim CF_OEMTEXT As Integer
   Dim CF_TEXT As Integer
   Dim CF_UNICODETEXT As Integer
   Dim hwnd As Long
   Dim bool As Long
   Dim retval As String

   CF_DSPTEXT = &H81
   CF_OEMTEXT = 7
   CF_TEXT = 1
   CF_UNICODETEXT = 13

   hwnd = GetActiveWindow()
   bool = OpenClipboard(hwnd)
   Dim hData as Long
   Dim lpData as Long
   
   hData = GetClipboardData(CF_UNICODETEXT)
         'If hData Then
            lpData = GlobalLock(hData)
               retval = PointerToStringA(lpData)
            Call GlobalUnlock(hData)
        ' End If
   bool = CloseClipboard()
   GetClip = retval
End Function

'################################################################################

Function PointerToStringA(lpStringA As Long) As String
   Dim Buffer() As Integer
   Dim nLen As Long
   Dim i As Long
   Dim psa As String
   
   'If lpStringA Then
      nLen = lstrlen(lpStringA)
      If nLen Then
         ReDim Buffer(0 To (nLen - 1) * 2) As Integer
         CopyMemory Buffer(0), ByVal lpStringA, nLen * 2
         for i = 0 to (nLen-1) * 2
           if Buffer(i) < 128 and Buffer(i) > 0 Then
             psa = psa & Chr(Buffer(i))
           Elseif Buffer(i) > 128 Then
             psa = psa & "|" & Hex(Buffer(i)) & "|" 'Chr(Buffer(i))
           End If
           'If len(psa) > 80 Then psa = psa & Chr(10)
         Next
         PointerToStringA = psa 'StrConv(Buffer, vbUnicode)
      End If
   'End If
End Function

'################################################################################

Sub SetClip(ByRef Buffer() As Integer)
   Dim CF_TEXT As Integer
   Dim CF_UNICODETEXT As Integer
   Dim GMEM_FIXED As Integer
   Dim hwnd As Long
   Dim bool As Long
   Dim i As Long
   Dim SetText As Long
   Dim LenBuff As Long
   
      CF_TEXT = 1
      CF_UNICODETEXT = 13
      GMEM_FIXED = &H0
      
      Dim hData As Long 
      Dim lpData As Long 
      Dim Buffer2() As Integer
      ReDim Buffer2(UBound(Buffer))

   hwnd = GetActiveWindow()
   bool = OpenClipboard(hwnd)

   bool = EmptyClipboard()
   
         ' Convert data to ANSI byte array. 
         For i = 0 to UBound(Buffer)
           If Buffer(i) < 255 then 
              Buffer2(i) = Buffer(i)
           Else
              Buffer2(i) = 63
           End If
         Next
         
         hData = GlobalAlloc(GMEM_FIXED, UBound(Buffer2) + 1) 
         If hData > 0 Then 
            ' Copy data to alloc'd memory. 
            lpData = GlobalLock(hData) 
            Call CopyMemory(ByVal lpData, Buffer2(0), UBound(Buffer2) + 1) 
            Call GlobalUnlock(hData) 
            ' Hand data off to clipboard 
            SetText = SetClipboardData(CF_TEXT, hData)
         End If 
         
         LenBuff = ((UBound(Buffer) + 1) * 2)  ' + 1
         
         ' Place Unicode text on clipboard, too. 
         ' Not strictly necessary, as Windows will 
         ' convert by default, with above code. 
         ' Already null-terminated, so just 
         ' allocate sufficient space for copy. 
         hData = GlobalAlloc(GMEM_FIXED, LenBuff) 'UBound(Buffer)*2 + 1)
         If hData >0 Then 
            ' Copy data to alloc'd memory. 
            lpData = GlobalLock(hData) 
            Call CopyMemory(ByVal lpData, Buffer(0), LenBuff) 'UBound(Buffer)*2 + 1)
            Call GlobalUnlock(hData) 
            ' Hand data off to clipboard 
            Call SetClipboardData(CF_UNICODETEXT, hData) 
         End If 
  bool = CloseClipboard()

End Sub

'################################################################################

Sub ConvertText(sField)
  Dim i As Integer
  Dim j As Integer
  Dim bStrArray() As Integer
  ReDim bStrArray(4)
  
  For i = 1 to 5
    If Asc(Mid(sField, i, 1)) = 252 Then
      bStrArray(i-1) = &H220E
    Else
      bStrArray(i-1) = Asc(Mid(sField, i, 1))
    End If

  Next

  i = 6 : j = 6
  Do
    If Mid(sField, i, 1) = Chr(223) Then
      ReDim Preserve bStrArray(UBound(bStrArray) + 2)
      bStrArray(j-1) = &H1C2
      bStrArray(j) = Asc(Mid(sField, i+1, 1))
      i = i + 2 : j = j + 2

    Else
       ReDim Preserve bStrArray(UBound(bStrArray) + 1)
       If InStr(" !@#$%^&*()[]{};:.,/?\=+", Mid(sField, i, 1)) Then
         bStrArray(j-1) = Asc(Mid(sField, i, 1))
       ElseIf InStr("1234567890", Mid(sField, i, 1)) Then
         bStrArray(j-1) = Asc(Mid(sField, i, 1))
         
       ElseIf Mid(sField, i, 1) = "-" Then
         If LCase(Mid(sField, i-1, 1)) Like "[a-z]" Or LCase(Mid(sField, i+1, 1)) Like "[a-z]" Then
           bStrArray(j-1) = &H5BE
         Else
           bStrArray(j-1) = Asc(Mid(sField, i, 1))
         End If
       ElseIf Mid(sField, i, 1) = "'" Then
         bStrArray(j-1) = &H5F3
       ElseIf Mid(sField, i, 1) = Chr(34) Then
         bStrArray(j-1) = &H5F4
       ElseIf Mid(sField, i, 1) = Chr(167) Then
         'Don't transliterate; just used as a break between consonants that might be digraphs but aren't in this case
         ReDim Preserve bStrArray(UBound(bStrArray) - 1)
         j = j - 1
       End If
     End If
'[...]
  Loop While i <= Len(sField)
  ReDim Preserve bStrArray(UBound(bStrArray) + 1)
  
  Call SetClip(bStrArray())
End Sub

'################################################################################