'MacroName:CopyMultiple 'MacroDescription:Copy multiple fields from the current record to the clipboard 'Macro written by: Joel Hahn, Niles Public Library District 'Last modified: 30 August 2007 Declare Function GetActiveWindow Lib "user32" () As Long Declare Function OpenClipboard Lib "user32" Alias "OpenClipboard" (ByVal hwnd 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 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 Option Compare Binary Declare Sub SetClip(ByRef Buffer() As Integer) Declare Function DlgFuncFieldsToCopy( WhichControl$, action%, suppvalue& ) As Integer Declare Sub TransAnsel(sField as String) Dim CurFields$() Dim CopyFields$() Sub Main Dim CS As Object Set CS = CreateObject("Connex.Client") Dim i,j As Integer Dim retval As Integer Dim sTitle as String Dim sFieldData As String Dim sCopyData As String Select Case CS.ItemType Case 5 To 13, 15, 16, 21 To 25 MsgBox "Not viewing a MARC record. Exiting..." Exit Sub Case -1 retval = CS.GetWindowTitle(-1, sTitle) If InStr(sTitle, "Online Institution Record") = 0 Then MsgBox "Not viewing a MARC record. Exiting..." Exit Sub End If End Select ReDim CopyFields$(1 to 1) i = 1 Do While CS.GetFieldLineUnicode(i, sFieldData) ReDim Preserve CurFields$(1 to i) CurFields$(i) = Mid(sFieldData, 1, 3) & " " & Mid(sFieldData, 4, 2) & " " & Mid(sFieldData, 6) i = i + 1 Loop Begin Dialog newdlg2 463, 202, "Copy Fields", .DlgFuncFieldsToCopy Text 5, 5, 88, 12, "Select fields to copy:" ListBox 5, 15, 200, 160, CurFields$(), .CurFields ListBox 240, 15, 200, 160, CopyFields$(), .CopyFields PushButton 215, 60, 15, 15, ">>", .AddToCopyList PushButton 215, 80, 15, 15, "<<", .DelFromCopyList OkButton 170, 180, 50, 14, .Ok CancelButton 225, 180, 50, 14, .Cancel End Dialog Dim ChangeInfo as newdlg2 retval = Dialog (ChangeInfo) If retval = -1 Then '***Note: -1 = OK, 0 = Cancel If CopyFields$(1) <> "" Then j = 1 Do While j <= UBound(CopyFields$) sCopyData = sCopyData & Mid(CopyFields$(j), 1, 3) & Mid(CopyFields$(j), 5, 2) & Mid(CopyFields$(j), 8) & Chr(13) & Chr(10) j = j + 1 Loop TransAnsel( sCopyData ) End If End If End Sub Function DlgFuncFieldsToCopy( WhichControl$, action%, suppvalue& ) As Integer Dim k,m As Integer Select Case action% Case 1 ' set up initial values displayed in dialog box Case 2 ' what to do if button or control value was changed (by clicking it) Select Case WhichControl$ Case "AddToCopyList" DlgFuncFieldsToCopy = TRUE If DlgValue("CurFields") > -1 Then If Left(CurFields$(DlgValue("CurFields") + 1), 1) <> "*" Then If CopyFields$(1) <> "" Then ReDim Preserve CopyFields$(1 To UBound(CopyFields$) + 1) Else ReDim Preserve CopyFields$(1 To 1) End If CopyFields$(UBound(CopyFields$)) = CurFields$(DlgValue("CurFields") + 1) CurFields$(DlgValue("CurFields") + 1) = "* " & CurFields$(DlgValue("CurFields") + 1) DlgListBoxArray "CopyFields", CopyFields$ DlgListBoxArray "CurFields", CurFields$ End If End If Case "DelFromCopyList" DlgFuncFieldsToCopy = TRUE If DlgValue("CopyFields") > -1 Then k = 0 Do Until "* " & CopyFields$(DlgValue("CopyFields") + 1) = CurFields$(k + 1) k = k + 1 Loop CurFields$(k + 1) = Mid(CurFields$(k + 1), 3) DlgListBoxArray "CurFields", CurFields$ CopyFields$(DlgValue("CopyFields") + 1) = "" m = DlgValue("CopyFields") + 1 Do While m < UBound(CopyFields$) CopyFields$(m) = CopyFields$(m + 1) m = m + 1 Loop If UBound(CopyFields$) > 1 Then ReDim Preserve CopyFields$(1 To UBound(CopyFields$) - 1) Else ReDim Preserve CopyFields$(1 To 1) End If DlgListBoxArray "CopyFields", CopyFields$ End If End Select Case 3 ' what to do if text box [or list/combo box?] was changed (by clicking it or by typing in it) Case 4 ' what to do if control focus was changed (by leaving it and clicking elsewhere) Case 5 ' what to do while idle (repeated many times/sec) End Select End Function Sub SetClip(ByRef Buffer() As Integer) 'Dim 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 SetText = SetClipboardData(CF_UNICODETEXT, hData) End If bool = CloseClipboard() End Sub Sub TransAnsel(sField as String) Dim i As Long Dim j As Integer Dim place As Integer Dim sHexcode As String Dim bStrArray() As Integer ReDim bStrArray(1) i = 1 : j = 1 Do ReDim Preserve bStrArray(UBound(bStrArray) + 1) If Mid(sField, i, 3) = "&#x" Then '#Unicode place = InStr(i, sField, ";") sHexcode = Mid(sField, i+3, place - (i + 3)) bStrArray(j-1) = Val("&H" & sHexcode) i = place ElseIf (Asc(Mid(sField, i, 1)) > 31 And Asc(Mid(sField, i, 1)) < 128) Or (Asc(Mid(sField, i, 1)) = 13 Or Asc(Mid(sField, i, 1)) = 10) Then bStrArray(j-1) = Asc(Mid(sField, i, 1)) Else If Mid(sField, i, 1) = Chr(226) Then 'Acute bStrArray(j-1) = &H301 ElseIf Mid(sField, i, 1) = Chr(181) Then 'ae, lowercase bStrArray(j-1) = &HE6 ElseIf Mid(sField, i, 1) = Chr(165) Then 'AE, uppercase bStrArray(j-1) = &HC6 ElseIf Mid(sField, i, 1) = Chr(174) Then 'Alif bStrArray(j-1) = &H2BC ElseIf Mid(sField, i, 1) = Chr(176) Then 'Ayn bStrArray(j-1) = &H2BB ElseIf Mid(sField, i, 1) = Chr(230) Then 'Breve bStrArray(j-1) = &H306 ElseIf Mid(sField, i, 1) = Chr(185) Then 'British pound bStrArray(j-1) = &HA3 ElseIf Mid(sField, i, 1) = Chr(239) Then 'Candrabindu bStrArray(j-1) = &H310 ElseIf Mid(sField, i, 1) = Chr(240) Then 'Cedilla bStrArray(j-1) = &H327 ElseIf Mid(sField, i, 1) = Chr(234) Then 'Circle above letter bStrArray(j-1) = &H30A ElseIf Mid(sField, i, 1) = Chr(244) Then 'Circle below letter bStrArray(j-1) = &H325 ElseIf Mid(sField, i, 1) = Chr(227) Then 'Circumflex, non-spacing bStrArray(j-1) = &H302 ElseIf Mid(sField, i, 1) = Chr(202) Then 'Copyright sign bStrArray(j-1) = &HA9 ElseIf Mid(sField, i, 1) = Chr(179) Then 'd with crossbar, lowercase bStrArray(j-1) = &H111 ElseIf Mid(sField, i, 1) = Chr(163) Then 'D with crossbar, uppercase bStrArray(j-1) = &H110 ElseIf Mid(sField, i, 1) = Chr(158) Then 'Degree sign bStrArray(j-1) = &HB0 ElseIf Mid(sField, i, 1) = Chr(223) Then 'Delimiter bStrArray(j-1) = &H1C2 ElseIf Mid(sField, i, 1) = Chr(242) Then 'Dot below letter bStrArray(j-1) = &H323 ElseIf Mid(sField, i, 1) = Chr(168) Then 'Dot in center of line bStrArray(j-1) = &HB7 ElseIf Mid(sField, i, 1) = Chr(238) Then 'Double acute bStrArray(j-1) = &H30B ElseIf Mid(sField, i, 1) = Chr(243) Then 'Double dot below letter bStrArray(j-1) = &H324 ElseIf Mid(sField, i, 1) = Chr(250) Then 'Double tilde (left half) bStrArray(j-1) = &HFE22 ElseIf Mid(sField, i, 1) = Chr(251) Then 'Double tilde (right half) bStrArray(j-1) = &HFE23 ElseIf Mid(sField, i, 1) = Chr(245) Then 'Double underscore bStrArray(j-1) = &H333 ElseIf Mid(sField, i, 1) = Chr(159) Then 'Eszett bStrArray(j-1) = &HDF ElseIf Mid(sField, i, 1) = Chr(186) Then 'Eth, lowercase bStrArray(j-1) = &HF0 ElseIf Mid(sField, i, 1) = Chr(163) Then 'Eth, uppercase bStrArray(j-1) = &H110 ElseIf Mid(sField, i, 1) = Chr(160) Then 'Euro bStrArray(j-1) = &H20AC ElseIf Mid(sField, i, 1) = Chr(252) Then 'Fill character bStrArray(j-1) = &H220E ElseIf Mid(sField, i, 1) = Chr(225) Then 'Grave, non-spacing bStrArray(j-1) = &H300 ElseIf Mid(sField, i, 1) = Chr(233) Then 'Hacek bStrArray(j-1) = &H30C ElseIf Mid(sField, i, 1) = Chr(254) Then 'High comma, centered bStrArray(j-1) = &H313 ElseIf Mid(sField, i, 1) = Chr(237) Then 'High comma, off center bStrArray(j-1) = &H315 ElseIf Mid(sField, i, 1) = Chr(248) Then 'Inverted cedilla bStrArray(j-1) = &H31C ElseIf Mid(sField, i, 1) = Chr(201) Then 'Inverted exclamation point bStrArray(j-1) = &HA1 ElseIf Mid(sField, i, 1) = Chr(200) Then 'Inverted question mark bStrArray(j-1) = &HBF ElseIf Mid(sField, i, 1) = Chr(177) Then 'l with slash, lowercase bStrArray(j-1) = &H142 ElseIf Mid(sField, i, 1) = Chr(161) Then 'L with slash, uppercase bStrArray(j-1) = &H141 ElseIf Mid(sField, i, 1) = Chr(247) Then 'Left hook bStrArray(j-1) = &H326 ElseIf Mid(sField, i, 1) = Chr(235) Then 'Ligature (left half) bStrArray(j-1) = &HFE20 ElseIf Mid(sField, i, 1) = Chr(236) Then 'Ligature (right half) bStrArray(j-1) = &HFE21 ElseIf Mid(sField, i, 1) = Chr(229) Then 'Macron bStrArray(j-1) = &H304 ElseIf Mid(sField, i, 1) = Chr(167) Then 'Miagkii znak bStrArray(j-1) = &H2032 ElseIf Mid(sField, i, 1) = Chr(169) Then 'Musical flat bStrArray(j-1) = &H266D ElseIf Mid(sField, i, 1) = Chr(204) Then 'Musical sharp bStrArray(j-1) = &H266F ElseIf Mid(sField, i, 1) = Chr(188) Then 'o with hook, lowercase bStrArray(j-1) = &H1A1 ElseIf Mid(sField, i, 1) = Chr(172) Then 'O with hook, uppercase bStrArray(j-1) = &H1A0 ElseIf Mid(sField, i, 1) = Chr(178) Then 'o with slash, lowercase bStrArray(j-1) = &HF8 ElseIf Mid(sField, i, 1) = Chr(162) Then 'O with slash, uppercase bStrArray(j-1) = &HD8 ElseIf Mid(sField, i, 1) = Chr(182) Then 'oe, lowercase bStrArray(j-1) = &H153 ElseIf Mid(sField, i, 1) = Chr(166) Then 'OE, uppercase bStrArray(j-1) = &H152 ElseIf Mid(sField, i, 1) = Chr(203) Then 'Phonogram copyright mark bStrArray(j-1) = &H2117 ElseIf Mid(sField, i, 1) = Chr(171) Then 'Plus/minus bStrArray(j-1) = &HB1 ElseIf Mid(sField, i, 1) = Chr(224) Then 'Pseudo question mark bStrArray(j-1) = &H309 ElseIf Mid(sField, i, 1) = Chr(241) Then 'Right hook (ogonek) bStrArray(j-1) = &H328 ElseIf Mid(sField, i, 1) = Chr(190) Then 'Script lowercase L bStrArray(j-1) = &H2113 ElseIf Mid(sField, i, 1) = Chr(144) Then 'Subscript 0 bStrArray(j-1) = &H2080 ElseIf Mid(sField, i, 1) = Chr(145) Then 'Subscript 1 bStrArray(j-1) = &H2081 ElseIf Mid(sField, i, 1) = Chr(146) Then 'Subscript 2 bStrArray(j-1) = &H2082 ElseIf Mid(sField, i, 1) = Chr(147) Then 'Subscript 3 bStrArray(j-1) = &H2083 ElseIf Mid(sField, i, 1) = Chr(148) Then 'Subscript 4 bStrArray(j-1) = &H2084 ElseIf Mid(sField, i, 1) = Chr(149) Then 'Subscript 5 bStrArray(j-1) = &H2085 ElseIf Mid(sField, i, 1) = Chr(150) Then 'Subscript 6 bStrArray(j-1) = &H2086 ElseIf Mid(sField, i, 1) = Chr(151) Then 'Subscript 7 bStrArray(j-1) = &H2087 ElseIf Mid(sField, i, 1) = Chr(152) Then 'Subscript 8 bStrArray(j-1) = &H2088 ElseIf Mid(sField, i, 1) = Chr(153) Then 'Subscript 9 bStrArray(j-1) = &H2089 ElseIf Mid(sField, i, 1) = Chr(154) Then 'Subscript left parenthesis bStrArray(j-1) = &H208D ElseIf Mid(sField, i, 1) = Chr(156) Then 'Subscript minus bStrArray(j-1) = &H208B ElseIf Mid(sField, i, 1) = Chr(170) Then 'Subscript patent mark (registered trademark) bStrArray(j-1) = &HAE ElseIf Mid(sField, i, 1) = Chr(157) Then 'Subscript plus bStrArray(j-1) = &H208A ElseIf Mid(sField, i, 1) = Chr(155) Then 'Subscript right parenthesis bStrArray(j-1) = &H208E ElseIf Mid(sField, i, 1) = Chr(231) Then 'Superior dot bStrArray(j-1) = &H307 ElseIf Mid(sField, i, 1) = Chr(128) Then 'Superscript 0 bStrArray(j-1) = &H2070 ElseIf Mid(sField, i, 1) = Chr(129) Then 'Superscript 1 bStrArray(j-1) = &HB9 ElseIf Mid(sField, i, 1) = Chr(130) Then 'Superscript 2 bStrArray(j-1) = &HB2 ElseIf Mid(sField, i, 1) = Chr(131) Then 'Superscript 3 bStrArray(j-1) = &HB3 ElseIf Mid(sField, i, 1) = Chr(132) Then 'Superscript 4 bStrArray(j-1) = &H2074 ElseIf Mid(sField, i, 1) = Chr(133) Then 'Superscript 5 bStrArray(j-1) = &H2075 ElseIf Mid(sField, i, 1) = Chr(134) Then 'Superscript 6 bStrArray(j-1) = &H2076 ElseIf Mid(sField, i, 1) = Chr(135) Then 'Superscript 7 bStrArray(j-1) = &H2077 ElseIf Mid(sField, i, 1) = Chr(136) Then 'Superscript 8 bStrArray(j-1) = &H2078 ElseIf Mid(sField, i, 1) = Chr(137) Then 'Superscript 9 bStrArray(j-1) = &H2079 ElseIf Mid(sField, i, 1) = Chr(138) Then 'Superscript left parenthesis bStrArray(j-1) = &H207D ElseIf Mid(sField, i, 1) = Chr(141) Then 'Superscript minus bStrArray(j-1) = &H207B ElseIf Mid(sField, i, 1) = Chr(140) Then 'Superscript plus bStrArray(j-1) = &H207A ElseIf Mid(sField, i, 1) = Chr(139) Then 'Superscript right parenthesis bStrArray(j-1) = &H207E ElseIf Mid(sField, i, 1) = Chr(180) Then 'Thorn, lowercase bStrArray(j-1) = &HFE ElseIf Mid(sField, i, 1) = Chr(164) Then 'Thorn, uppercase bStrArray(j-1) = &HDE ElseIf Mid(sField, i, 1) = Chr(228) Then 'Tilde, non-spacing bStrArray(j-1) = &H303 ElseIf Mid(sField, i, 1) = Chr(184) Then 'Turkish i without dot, lowercase bStrArray(j-1) = &H131 ElseIf Mid(sField, i, 1) = Chr(183) Then 'Tverdyi znak bStrArray(j-1) = &H2033 ElseIf Mid(sField, i, 1) = Chr(189) Then 'u with hook, lowercase bStrArray(j-1) = &H1B0 ElseIf Mid(sField, i, 1) = Chr(173) Then 'U with hook, uppercase bStrArray(j-1) = &H1AF ElseIf Mid(sField, i, 1) = Chr(232) Then 'Umlaut bStrArray(j-1) = &H308 ElseIf Mid(sField, i, 1) = Chr(246) Then 'Underscore, non-spacing bStrArray(j-1) = &H332 ElseIf Mid(sField, i, 1) = Chr(249) Then 'Upadhmaniya bStrArray(j-1) = &H32E Else bStrArray(j-1) = &H220E End If End If i = i + 1 : j = j + 1 Loop While i <= Len(sField) ReDim Preserve bStrArray(UBound(bStrArray) + 1) Call SetClip(bStrArray()) End Sub