その時は、マクロのチカラを借りる。
例えば漢字の列がA列の場合:
Range("A:A").SetPhonetic
実行後、隣の列で「=PHONETIC("A1")」で数式を入れると変換されます
Range("A:A").SetPhonetic
CREATE TABLE table_a ( a INT NOT NULL, b INT NOT NULL, c INT NOT NULL, UNIQUE (a, b) ); INSERT INTO table_a (a, b, c) VALUES (1, 2, 0),(3, 4, 5) ON DUPLICATE KEY UPDATE c = VALUES(c);
Private Sub ListBox1_MouseMove( _
ByVal Button As Integer, ByVal Shift As Integer, _
ByVal x As Single, ByVal y As Single)
' start tthe hook
HookListBoxScroll
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnhookListBoxScroll
End Sub
''''''' end Userform code
''''''' normal module code
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As Long
wHitTestCode As Long
dwExtraInfo As Long
End Type
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" ( _
ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As Long) As Long
Private Declare Function PostMessage Lib "user32.dll" _
Alias "PostMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) As Long
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private Const WM_LBUTTONDOWN As Long = &H201
Private mLngMouseHook As Long
Private mListBoxHwnd As Long
Private mbHook As Boolean
Sub HookListBoxScroll()
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Dim tPT As POINTAPI
GetCursorPos tPT
hwndUnderCursor = WindowFromPoint(tPT.x, tPT.y)
If mListBoxHwnd <> hwndUnderCursor Then
UnhookListBoxScroll
mListBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx( _
WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
mbHook = mLngMouseHook <> 0
End If
End If
End Sub
Sub UnhookListBoxScroll()
If mbHook Then
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mListBoxHwnd = 0
mbHook = False
End If
End Sub
Private Function MouseProc( _
ByVal nCode As Long, ByVal wParam As Long, _
ByRef lParam As MOUSEHOOKSTRUCT) As Long
On Error GoTo errH 'Resume Next
If (nCode = HC_ACTION) Then
If WindowFromPoint(lParam.pt.x, lParam.pt.y) = mListBoxHwnd Then
If wParam = WM_MOUSEWHEEL Then
MouseProc = True
If lParam.hwnd > 0 Then
PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
Else
PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
End If
PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
Exit Function
End If
Else
UnhookListBoxScroll
End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookListBoxScroll
End Function
Option Explicit
Sub testUnionAndIntersection()
'Intersection And Union
'Also called
'Logical disjunction Logical conjunction
'AND OR
Dim a As New Scripting.Dictionary
Dim b As New Scripting.Dictionary
Dim keysA As Variant
Dim keysB As Variant
Dim keysC As Variant
Dim keysD As Variant
a.Add "A", ""
a.Add "B", ""
a.Add "C", ""
b.Add "A", ""
b.Add "C", ""
b.Add "X", ""
keysA = a.Keys
keysB = b.Keys
keysC = getIntersectionSet(keysA, keysB)
Debug.Print Join(keysC, ",")
'A,C
keysD = getUnionSet(keysA, keysB)
Debug.Print Join(keysD, ",")
'A,B,C,X
Call DeleteElementAt(1, keysB)
Debug.Print Join(keysB, ",")
'A,X
End Sub
Function getIntersectionSet(arr1 As Variant, arr2 As Variant) As Variant
Dim vntTmp As Variant
Dim vntRst As Variant
If Not (IsArray(arr1) And IsArray(arr2)) Then
Exit Function
End If
For Each vntTmp In arr1
If IsInArray(CStr(vntTmp), arr2) Then
push vntTmp, vntRst
End If
Next
getIntersectionSet = vntRst
End Function
Function getUnionSet(arr1 As Variant, arr2 As Variant) As Variant
Dim vntTmp As Variant
Dim vntRst As Variant
If Not (IsArray(arr1) And IsArray(arr2)) Then
Exit Function
End If
vntRst = arr1
For Each vntTmp In arr2
If Not IsInArray(CStr(vntTmp), vntRst) Then
push vntTmp, vntRst
End If
Next
getUnionSet = vntRst
End Function
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Public Sub DeleteElementAt(ByVal index As Integer, ByRef prLst As Variant)
Dim i As Integer
For i = index + 1 To UBound(prLst)
prLst(i - 1) = prLst(i)
Next
ReDim Preserve prLst(UBound(prLst) - 1)
End Sub
Public Function push(ByVal val As Variant, ByRef arr As Variant, Optional ByVal unique As Boolean = False) As Integer
Dim lngX As Long
If unique Then
If Not IsEmpty(arr) Then
If IsArray(arr) Then
For lngX = LBound(arr) To UBound(arr)
If arr(lngX) = val Then
push = UBound(arr)
Exit Function
End If
Next
End If
End If
End If
If IsArray(arr) Then
On Error GoTo initArray
ReDim Preserve arr(UBound(arr) + 1)
Else
initArray:
ReDim arr(0)
End If
If VarType(val) = 9 Then '9 is object
Set arr(UBound(arr)) = val
Else
arr(UBound(arr)) = val
End If
push = UBound(arr)
End Function
connect.CursorLocation = 3 'クライアントカーソルにする
Set rs = execQuery(cn, sql, , adOpenKeyset, adLockOptimistic)
debug.print rs.RecordCount