2017年4月27日木曜日

PHONETIC関数が効かない時

PHONETICという漢字をカタカナに変換してくれる関数があります。しかし何故か変換せれず漢字のまま出力されてしまう時があります。
その時は、マクロのチカラを借りる。
例えば漢字の列がA列の場合:

Range("A:A").SetPhonetic

実行後、隣の列で「=PHONETIC("A1")」で数式を入れると変換されます

2017年3月30日木曜日

INSERT INTO 複数VALUES時のON DUPLICATE KEY UPDATEの書き方

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);

ListBoxがマウスのスクロール対応していない?!

やってみたら本当だ。
幸いソリューションは既にありました。ありがとうございます。
参照: https://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
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

2017年3月15日水曜日

VBA DLL を正しく呼び出せません (エラー 49)

SubもFunctionもパラメーターの前にByValかByRefかをきちんと書こう!

2017年2月15日水曜日

VBA Arrayの論理計算、交集、並集(AND OR)(Intersection And Union)(Logical disjunction Logical conjunction)

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


2017年1月31日火曜日

PHPにアップロードできるファイルサイズの上限を決めるupload_max_filesizeとpost_max_size

upload_max_filesize を50Mにするだけは取りない、post_max_sizeも忘れるな!
php.iniの中にある。
アプリのConfigにも制限あるかもしれないので、要注意

2016年12月6日火曜日

ADOレコーダーがあるのに、RecordCountが「-1」の場合の対処

レコーダーがあるのに、RecordCountが「-1」の場合の対処

connect.CursorLocation = 3 'クライアントカーソルにする
Set rs = execQuery(cn, sql, , adOpenKeyset, adLockOptimistic)
debug.print rs.RecordCount