【VBA】Excelのユーザーフォームをフェードイン、フェードアウトさせてみた

はじめに

Windows では、Windows 2000 Professional 以降のバージョンで、ウインドウに対して、特定の拡張ウインドウスタイルを適用し、レイヤード ウィンドウ化することで、

• アルファブレンドによる、ウィンドウの半透過状態
• カラーキーによる、特定色部の透過

を行うことが出来るようになりました。

今回は、エクセルのユーザーフォームに対し、アルファブレンドを設定し、ユーザーフォームのフェードイン、フェードアウトを行ってみます。

Twitter に載せたやつを、少し修正したものです。

昨日の透過を使って、フォームのフェードイン、フェードアウトをやってみた。

Forループで、SetLayeredWindowAttributes の bAlpha を増減しているだけ。 pic.twitter.com/Jz0LULXGIP

— 空腹おやじ (@Z1000R_LR) 2020年5月12日

処理の概要

簡単に言えば、以下の通り。
ただし、その処理を行うために、いくつかの準備等は必要です。

1. ユーザーフォームに対し、拡張スタイルを適用
2. アルファブレンド値を徐々に変化させる。

使用するAPI

FindWindow

ユーザーフォームのウィンドウハンドルを取得します。

HWND FindWindowA(
  LPCSTR lpClassName,
  LPCSTR lpWindowName
);

今回は、手っ取り早く
lpClassNameには、vbNullString
lpWindowNameには、ユーザーフォームのCaptionを指定します。

docs.microsoft.com

GetWindowLongPtr

指定したウィンドウのスタイルを取得します。

LONG_PTR GetWindowLongPtrA(
  HWND hWnd,
  int  nIndex
);

hWndには、FindWindowで取得した、ユーザーフォームのウインドウハンドルを指定します。
nIndexには、GWL_EXSTYLE を指定することで、ユーザーフォームに設定されている拡張ウィンドウスタイルを取得することができます。

SetWindowLongPtrA

指定したウィンドウに、スタイルを設定します。

LONG_PTR SetWindowLongPtrA(
  HWND     hWnd,
  int      nIndex,
  LONG_PTR dwNewLong
);

dwNewLong に、「GetWindowLongPtr で取得した拡張ウィンドウスタイルに対し、WS_EX_LAYEREDを追加した値を設定」することで、レイヤードウィンドウとすることができます。

SetLayeredWindowAttributes

今回の主役です。
ウィンドウの不透明度を設定します。
今回は使用しませんが、指定した色を透過させる事もできます。

BOOL SetLayeredWindowAttributes(
  HWND     hwnd,
  COLORREF crKey,
  BYTE     bAlpha,
  DWORD    dwFlags
);

crKeyには、レイヤードウィンドウを合成するときに使われる透明色キーを指定します。

bAlphaには、レイヤード ウィンドウの不透明度を表現するために使用されるアルファ値を指定します。
値は、0 から 255 の範囲で、0を指定すると、ウィンドウは完全に透明になり、255を指定すると、ウィンドウは不透明になります。

dwFlagsには、LWA_ALPHA 、LWA_COLORKEY のいずれかひとつ、または両方を指定できます。
LWA_COLORKEY を指定すると、透過させる色の指定が有効になります。
LWA_ALPHA を指定すると、ウィンドウの不透明度の指定が有効になります。

拡張ウィンドウスタイル

拡張ウィンドウスタイルには、多数のスタイルがあり、今回はその中から、WS_EX_LAYERED を使用します。
docs.microsoft.com

コード

事前準備

予め、frmFade というユーザーフォームを作っておき、
Caption に、FadeForm という文字列を設定しておきます。

標準モジュール

掲載しているのは、64bit版のコードです。

32bit版で使用する場合には、いくつかの修正が必要です。
32bit環境がないので、未確認ですが、最低でも以下の修正が必要と思われます。

• Declare の PtrSafe 削除
• GetWindowLongPtr ==> GetWindowLong
• GetWindowLongPtr のreturn LongPtr ==> Long
• SetWindowLongPtr ==>SetWindowLong
• SetWindowLongPtr の dwNewLong の型 LongPtr ==> Long
• hwnd の型 LongPtr ==> Long
• lExStyle の型 LongPtr ==> Long

Option Explicit

Private Const WS_EX_LAYERED = &H80000
Private Const LWA_COLORKEY = &H1&
Private Const LWA_ALPHA = &H2&
Private Const GWL_EXSTYLE = -20&

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
       (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As LongPtr

Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" _
       (ByVal hwnd As LongPtr, _
        ByVal nIndex As Long) As LongPtr

Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" _
       (ByVal hwnd As LongPtr, _
        ByVal nIndex As Long, _
        ByVal dwNewLong As LongPtr) As LongPtr

Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" _
       (ByVal hwnd As LongPtr, _
        ByVal crKey As Long, _
        ByVal bAlpha As Long, _
        ByVal dwFlags As Long) As Long

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)


Public Sub showForm()

    Dim f           As frmFade
    Dim hwnd        As LongPtr
    Dim lExStyle    As LongPtr
    Dim lResult     As Long
    Dim i       As Long

    Set f = frmFade

    'いきなり f.Show とすると、表示されてしまうので、Load するだけ
    Load f

    'タイトルを使って、ウィンドウハンドルを取得する
    hwnd = FindWindow(vbNullString, "FadeForm")

    lExStyle = GetWindowLongPtr(hwnd, GWL_EXSTYLE)

    If (lExStyle And WS_EX_LAYERED) = 0 Then
        'WS_EX_LAYEREDが未設定なら、拡張スタイルに、WS_EX_LAYERED を付与する
        lExStyle = lExStyle Or WS_EX_LAYERED

        Call SetWindowLongPtr(hwnd, GWL_EXSTYLE, lExStyle)
    End If

    '初期は､完全透過状態で表示させる
    Call SetLayeredWindowAttributes(hwnd, 0, 0, LWA_ALPHA)

    f.Show

    For i = 5 To 255 Step 5
        '不透明度を、上げていく
        Call SetLayeredWindowAttributes(hwnd, 0, i, LWA_ALPHA)

        DoEvents

        Call Sleep(40)
    Next i

    Call Sleep(1000)

    For i = 255 To 0 Step -5
        '不透明度を、下げていく
        Call SetLayeredWindowAttributes(hwnd, 0, i, LWA_ALPHA)

        DoEvents

        Call Sleep(40)
    Next i

    Unload f

    Set f = Nothing

End Sub

実行サンプル

何かのネタに使えるようなら使ってみて下さい。

【VBA】Twitter お題「ねこちゃんの数を数える」を解いてみた

Twitter で、ほえほえ氏から提示されたお題「ねこちゃんの数を数える」を解いてみた。

少しお題を考えたので投稿してみます。お題のためのお題ということで少し不自然だし、簡単な解法があるかもしれませんがご容赦を。発展型で言ってみます。

お題　ねこちゃんの数を数える

です。（つづく）

— ほえほえ＠LWP (@hoehoe1234) 2020年2月23日

ざっくり言えば、「親猫」、「子猫」、「猫又」・・・といった文字が並んでいて、
それぞれ何匹いるのかを数えるというもの。

take 1からtake 7まであって、
それぞれに条件がついています。

Take	条件	文字列
1	親猫と子猫を数えて（数と種類を報告）ください。	親猫子猫子猫子猫子猫子猫子猫親猫親猫子猫子猫
2	簡潔に書くために同じ種類の猫が連続する場合は「猫」一文字で代用することにしました。 「親猫猫子猫猫」は、親猫が２匹、子猫が２匹です。	親猫猫猫子猫猫猫猫猫猫親猫子猫猫
3	せっかく簡潔に書く記法を開発したのに適当に書くやつが現れました。そのせいで繰り返しの代わりに元の記法もOKになりました。 親猫が３匹の場合下のいづれもOKとします。 親猫親猫親猫 親猫猫親猫 親猫猫猫	子猫猫子猫猫親猫猫子猫親猫子猫親猫子猫猫子猫
4	なんと列に「猫又」が混じってしまいました。親猫、子猫、猫又の数を数えてください。	子猫猫子猫猫親猫猫又猫猫猫又親猫猫猫猫又猫
5	いままでは親猫子猫猫又でしたがいろいろな種類の猫がが混じってしまいました。 ただし猫の名前は２文字で最後に「猫」がつくのは同じです。 例で白猫黒猫がいますが実際はもっとたくさんの種類がいます。（青猫、緑猫とか）	子猫猫白猫黒猫猫猫猫親猫猫又猫猫猫又親猫猫猫猫又猫
6	なんと不条理な上司！登場。あろうことか、「猫又が二匹現れたらその時点で猫の種類と数を報告して作業を終了せよ」といわれました。どうしよう。。。 上司によると猫又２匹とは「累計して２匹」現れたらとのことで、連続２匹ということではない模様です。 "子猫猫又親猫猫又" "子猫親猫猫又猫" はともに最後の猫又で「累計２匹」なのでそこで報告して作業終了です。	子猫猫白猫黒猫緑猫青猫猫猫猫親猫猫又猫猫猫又青猫親猫猫猫猫又猫
7	最後の試練。上司が逆ギレしています。どうやら先程の指示は上司の意図ではなかったようです。彼によると 「猫又が不吉なのは『きっちり２匹だけ並んだ』ときだけだ！」 とのことです。累計でもないしなんと猫又が３匹並んでもそれはOK（カウント継続）だそうです。数えられるかな、、、、

コード

手っ取り早いので、正規表現で・・・

メイン処理

参照設定は、いつものやつ。
Microsoft VBScript Regular Expressions 5.5

メイン処理で使っているパターンは、
親猫を数える場合を例に取ると

(?:親)(猫*?)(?=(?:猫又|[^猫]|$))

猫に続く猫又を分けなければいけないので
肯定先読みを使用している。

"親猫又"
がある場合には、
猫又
を優先している。

親猫を優先したい場合には、
"(猫*?)"を"(猫+?)"に変えればいい（はず）。

(?:親)(猫+?)(?=(?:猫又|[^猫]|$))

親の部分が変わるだけで、
Take 1 から、Take 7 まで全て同じパターンで処理している。

Public Function 猫5改2(ByVal sCats As String, ByRef sCatType() As String, ByRef lCatCount() As Long) As Long

    Dim re          As RegExp
    Dim mc          As MatchCollection
    Dim lCount      As Long
    Dim lNekomata   As Long
    Dim sResult     As String
    Dim sTypes()    As String
    Dim lElems      As Long
    Dim i       As Long
    Dim j       As Long

    ReDim sCatType(lCount)
    ReDim lCatCount(lCount)

    '猫又
    lNekomata = (Len(sCats) - Len(Replace$(sCats, "猫又", ""))) \ 2

    If lNekomata > 0 Then
        ReDim Preserve sCatType(lCount)
        sCatType(lCount) = "猫又"

        ReDim Preserve lCatCount(lCount)
        lCatCount(lCount) = lNekomata

        lCount = lCount + 1
    End If

    猫5改2 = lCount

    '猫と又を消して、猫の種類の文字のみにする
    sResult = Replace$(sCats, "猫", "")
    sResult = Replace$(sResult, "又", "")

    ReDim sTypes(0)

    lElems = -1

    '"猫"の前に付く文字を抜き出す（"又"は含まれない）
    Do Until Len(sResult) = 0
        lElems = lElems + 1

        ReDim Preserve sTypes(lElems)

        sTypes(lElems) = Left$(sResult, 1)

        sResult = Replace$(sResult, sTypes(lElems), "")
    Loop

    If lElems < 0 Then
        Exit Function
    End If

    Set re = New RegExp

    With re
        .Global = True

        For i = LBound(sTypes) To UBound(sTypes)
            .Pattern = "(?:" & sTypes(i) & ")(猫*?)(?=(?:猫又|[^猫]|$))"

            Set mc = .Execute(sCats)

            sResult = ""

            For j = 0 To mc.Count - 1
                sResult = sResult & mc.Item(j).SubMatches(0)
            Next j

CONTINUE_LOOP:
            If sCats Like "*" & sTypes(i) & "猫*" Then
                '"親子猫"のような場合、"親猫"は無いので出力しない
                If Not sCats Like "*" & sTypes(i) & "猫又*" Then
                    '"子猫又"のような場合、"子猫"を出力しない

                    ReDim Preserve sCatType(lCount)
                    sCatType(lCount) = sTypes(i) & "猫"

                    ReDim Preserve lCatCount(lCount)
                    lCatCount(lCount) = Len(sResult) - Len(Replace$(sResult, "猫", ""))

                    lCount = lCount + 1
                End If
            End If
        Next i
    End With

    猫5改2 = lCount

End Function

Take 6、Take 7用補助処理

Public Function get猫6Source(ByVal sCats As String) As String

    Dim re      As RegExp
    Dim mc      As MatchCollection
    Dim sSource As String
    Dim lResult As Long
    Dim i       As Long

    Set re = New RegExp

    With re
        .Pattern = "^(.*?猫又){2}"
        .Global = False

        Set mc = .Execute(sCats)
        
        If mc.Count > 0 Then
            sSource = mc.Item(0)
        Else
            sSource = sCats
        End If
    End With

    get猫6Source = sSource

End Function

Public Function get猫7Source(ByVal sCats As String) As String

    Dim re      As RegExp
    Dim mc      As MatchCollection
    Dim sSource As String

    Set re = New RegExp

    With re
        .Pattern = "^.*?[^又]猫又猫又(?!猫又)"
        .Global = True

        Set mc = .Execute(sCats)
        
        If mc.Count > 0 Then
            sSource = mc.Item(0)
        Else
            sSource = sCats
        End If
    End With

    get猫7Source = sSource

End Function

テスト

Public Sub 猫てすと()

    Dim sCatType()  As String
    Dim lCatCount() As Long

    Dim sCats       As String
    Dim lResult     As Long

    '----- take1 -----
    Erase sCatType, lCatCount

    sCats = "親猫子猫子猫子猫子猫子猫子猫親猫親猫子猫子猫"
    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 2
    Debug.Assert sCatType(0) = "親猫"
    Debug.Assert lCatCount(0) = 3
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 8

    '----- take2 -----
    Erase sCatType, lCatCount

    sCats = "親猫猫猫子猫猫猫猫猫猫親猫子猫猫"
    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 2
    Debug.Assert sCatType(0) = "親猫"
    Debug.Assert lCatCount(0) = 4
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 8

    '----- take3 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫子猫猫親猫猫子猫親猫子猫親猫子猫猫子猫"
    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 2
    Debug.Assert sCatType(0) = "子猫"
    Debug.Assert lCatCount(0) = 9
    Debug.Assert sCatType(1) = "親猫"
    Debug.Assert lCatCount(1) = 4

    '----- take4 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫子猫猫親猫猫又猫猫猫又親猫猫猫猫又猫"
    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 3
    Debug.Assert sCatType(0) = "猫又"
    Debug.Assert lCatCount(0) = 3
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 4
    Debug.Assert sCatType(2) = "親猫"
    Debug.Assert lCatCount(2) = 4

    '----- take5 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫白猫黒猫猫猫猫親猫猫又猫猫猫又親猫猫猫猫又猫"
    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 5
    Debug.Assert sCatType(0) = "猫又"
    Debug.Assert lCatCount(0) = 3
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 2
    Debug.Assert sCatType(2) = "白猫"
    Debug.Assert lCatCount(2) = 1
    Debug.Assert sCatType(3) = "黒猫"
    Debug.Assert lCatCount(3) = 4
    Debug.Assert sCatType(4) = "親猫"
    Debug.Assert lCatCount(4) = 4

    '----- take6-1 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫白猫黒猫緑猫青猫猫猫猫親猫猫又猫猫猫又青猫親猫猫猫猫又猫"
    sCats = get猫6Source(sCats)

    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 7
    Debug.Assert sCatType(0) = "猫又"
    Debug.Assert lCatCount(0) = 2
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 2
    Debug.Assert sCatType(2) = "白猫"
    Debug.Assert lCatCount(2) = 1
    Debug.Assert sCatType(3) = "黒猫"
    Debug.Assert lCatCount(3) = 1
    Debug.Assert sCatType(4) = "緑猫"
    Debug.Assert lCatCount(4) = 1
    Debug.Assert sCatType(5) = "青猫"
    Debug.Assert lCatCount(5) = 4
    Debug.Assert sCatType(6) = "親猫"
    Debug.Assert lCatCount(6) = 1

    '----- take6-12 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫白猫黒猫緑猫青猫猫猫猫親猫猫又猫猫青猫親猫猫猫猫"
    sCats = get猫6Source(sCats)

    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 7
    Debug.Assert sCatType(0) = "猫又"
    Debug.Assert lCatCount(0) = 1
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 2
    Debug.Assert sCatType(2) = "白猫"
    Debug.Assert lCatCount(2) = 1
    Debug.Assert sCatType(3) = "黒猫"
    Debug.Assert lCatCount(3) = 1
    Debug.Assert sCatType(4) = "緑猫"
    Debug.Assert lCatCount(4) = 1
    Debug.Assert sCatType(5) = "青猫"
    Debug.Assert lCatCount(5) = 5
    Debug.Assert sCatType(6) = "親猫"
    Debug.Assert lCatCount(6) = 5

    '----- take7-1 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫白猫黒猫緑猫青猫猫猫猫親猫猫又猫猫猫又青猫親猫猫猫猫又猫"
    sCats = get猫7Source(sCats)

    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 7
    Debug.Assert sCatType(0) = "猫又"
    Debug.Assert lCatCount(0) = 3
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 2
    Debug.Assert sCatType(2) = "白猫"
    Debug.Assert lCatCount(2) = 1
    Debug.Assert sCatType(3) = "黒猫"
    Debug.Assert lCatCount(3) = 1
    Debug.Assert sCatType(4) = "緑猫"
    Debug.Assert lCatCount(4) = 1
    Debug.Assert sCatType(5) = "青猫"
    Debug.Assert lCatCount(5) = 5
    Debug.Assert sCatType(6) = "親猫"
    Debug.Assert lCatCount(6) = 4

    '----- take7-2 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫白猫黒猫緑猫青猫猫猫猫親猫猫又猫又青猫親猫猫猫猫又猫"
    sCats = get猫7Source(sCats)

    lResult = 猫5改2(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 7
    Debug.Assert sCatType(0) = "猫又"
    Debug.Assert lCatCount(0) = 2
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 2
    Debug.Assert sCatType(2) = "白猫"
    Debug.Assert lCatCount(2) = 1
    Debug.Assert sCatType(3) = "黒猫"
    Debug.Assert lCatCount(3) = 1
    Debug.Assert sCatType(4) = "緑猫"
    Debug.Assert lCatCount(4) = 1
    Debug.Assert sCatType(5) = "青猫"
    Debug.Assert lCatCount(5) = 4
    Debug.Assert sCatType(6) = "親猫"
    Debug.Assert lCatCount(6) = 1

    Debug.Print "Done."

End Sub

Debug.Assert で済ませたので、イミディエイトウィンドウに

Done.

と出て、終わり。

ちなみに、イミディエイトウィンドウに出力すると、こんな感じ。

以上。

「改2」は、バージョンです。ツッコまないでくださいwww

正規表現を使わないバージョン（2020/3/1追加）

• Take 1～5 限定です。
• 正規表現バージョンより、精度が低いです。
• お題で提示されているデータは、クリアしますが、元になる猫データが変わると、要件をクリアできない場合があります。
• 正規表現バージョンとは、出力順が違います。

コード

Public Function 猫猫(ByVal sCats As String, ByRef sCatType() As String, ByRef lCatCount() As Long) As Long

    Dim dicCount    As Dictionary
    Dim lLength     As Long
    Dim lStartPos   As Long
    Dim lOffset     As Long
    Dim sCurrentType    As String
    Dim sType       As String
    Dim lCount      As Long

    lLength = Len(sCats)

    If lLength < 2 Then
        Exit Function
    End If

    Set dicCount = New Dictionary

    'グループ開始位置
    lStartPos = 1
    lOffset = 0

    '現在の猫の種類
    sCurrentType = ""
    sType = Mid$(sCats, lStartPos, 1)

    Do While True
        Select Case sType
        Case "猫"
            If Mid$(sCats, lStartPos + lOffset + 1, 1) <> "又" Then
                '猫又ではない
                lCount = lCount + 1
                lOffset = lOffset + 1
            Else
                '猫又
                lStartPos = lStartPos + lOffset + 2
                lOffset = 0

                If dicCount.Exists("又") = True Then
                    dicCount.Item("又") = dicCount.Item("又") + 1
                Else
                    dicCount.Add "又", 1
                End If

                If Len(sCurrentType) > 0 Then
                    If dicCount.Exists(sCurrentType) = True Then
                        dicCount.Item(sCurrentType) = dicCount.Item(sCurrentType) + lCount
                    End If
                End If

                sCurrentType = ""
            End If
        Case Else
            If sCurrentType <> sType Then
                '猫の種類が変わった
                lStartPos = lStartPos + lOffset + 1
                lOffset = 0

                If dicCount.Exists(sCurrentType) = True Then
                    'カウントアップ
                    dicCount.Item(sCurrentType) = dicCount.Item(sCurrentType) + lCount
                End If

                If Len(sType) > 0 Then
                    If dicCount.Exists(sType) = False Then
                        '新しい猫の種類を追加
                        dicCount.Add sType, 0
                    End If
                End If

                '現在の猫の種類を更新
                sCurrentType = sType

                'カウントクリア
                lCount = 0
            Else
                lOffset = lOffset + 1
            End If
        End Select

        sType = Mid$(sCats, lStartPos + lOffset, 1)

        '終了判定（lStartPos + lOffset > lLength で、sType = ""となる）
        If Len(sType) = 0 Then
            If Len(sCurrentType) > 0 Then
                '有効データならカウントアップ
                dicCount.Item(sCurrentType) = dicCount.Item(sCurrentType) + lCount
            End If

            Exit Do
        End If
    Loop

'--------------------------------------------------
    Dim v As Variant
    Dim lElems  As Long

    ReDim sCatType(dicCount.Count - 1)
    ReDim lCatCount(dicCount.Count - 1)

    For Each v In dicCount
        If Len(v) > 0 Then
            If dicCount.Item(v) > 0 Then
                If v <> "又" Then
                    sCatType(lElems) = v & "猫"
                Else
                    sCatType(lElems) = "猫" & v
                End If
                lCatCount(lElems) = dicCount.Item(v)

                lElems = lElems + 1
            End If
        End If
    Next v

    If dicCount.Count <> lElems Then
        '未登録データが有れば、排除
        ReDim Preserve sCatType(lElems - 1)
        ReDim Preserve lCatCount(lElems - 1)
    End If

    猫猫 = lElems

End Function

テスト

Public Sub 猫猫テスト()

    Dim sCatType()  As String
    Dim lCatCount() As Long

    Dim sCats       As String
    Dim lResult     As Long

    '----- take1 -----
    Erase sCatType, lCatCount

    sCats = "親猫子猫子猫子猫子猫子猫子猫親猫親猫子猫子猫"
    lResult = 猫猫(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 2
    Debug.Assert sCatType(0) = "親猫"
    Debug.Assert lCatCount(0) = 3
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 8

    '----- take2 -----
    Erase sCatType, lCatCount

    sCats = "親猫猫猫子猫猫猫猫猫猫親猫子猫猫"
    lResult = 猫猫(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 2
    Debug.Assert sCatType(0) = "親猫"
    Debug.Assert lCatCount(0) = 4
    Debug.Assert sCatType(1) = "子猫"
    Debug.Assert lCatCount(1) = 8

    '----- take3 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫子猫猫親猫猫子猫親猫子猫親猫子猫猫子猫"
    lResult = 猫猫(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 2
    Debug.Assert sCatType(0) = "子猫"
    Debug.Assert lCatCount(0) = 9
    Debug.Assert sCatType(1) = "親猫"
    Debug.Assert lCatCount(1) = 4

    '----- take4 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫子猫猫親猫猫又猫猫猫又親猫猫猫猫又猫"
    lResult = 猫猫(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 3
    Debug.Assert sCatType(0) = "子猫"
    Debug.Assert lCatCount(0) = 4
    Debug.Assert sCatType(1) = "親猫"
    Debug.Assert lCatCount(1) = 4
    Debug.Assert sCatType(2) = "猫又"
    Debug.Assert lCatCount(2) = 3

    '----- take5 -----
    Erase sCatType, lCatCount

    sCats = "子猫猫白猫黒猫猫猫猫親猫猫又猫猫猫又親猫猫猫猫又猫"
    lResult = 猫猫(sCats, sCatType, lCatCount)

    Debug.Assert lResult = 5
    Debug.Assert sCatType(0) = "子猫"
    Debug.Assert lCatCount(0) = 2
    Debug.Assert sCatType(1) = "白猫"
    Debug.Assert lCatCount(1) = 1
    Debug.Assert sCatType(2) = "黒猫"
    Debug.Assert lCatCount(2) = 4
    Debug.Assert sCatType(3) = "親猫"
    Debug.Assert lCatCount(3) = 4
    Debug.Assert sCatType(4) = "猫又"
    Debug.Assert lCatCount(4) = 3

    Debug.Print "Done."

End Sub

【VBA】導関数を求める

Twitter でのお題
「y = 5x^3 + 2x^2 + 7x + 5」の導関数を求めろ！
を解いてみた。

正規表現を使って、必要なデータを取り出して、ゴニョゴニョしました。

使用したパターンは、以下の通り。
"([+-]?)(\d*)x(\^([+-]?\d+))?"

大雑把な説明
x に対して、

[+-]?	符号 + または、- が付く場合がある
\d*	任意の正の整数の係数が付く場合がある
(\^([+-]?\d+))?	冪乗指数が付く場合がある
[+-]?	冪乗指数には、符号 + または、- が付く場合がある
\d+	冪乗指数は、正の整数である

係数、指数を
正の整数
としているのは、
符号部と数値部を別に判定しているためです。

参照設定は、お約束の通り。

Private Type xItem
    xiSign   As String
    xiCoefficient   As Long
    xiPower         As Long
End Type

Public Sub hoge()

    Dim sFormula    As String

    sFormula = "y = 5x^3 + 2x^2 + 7x + 5"
    Debug.Print sFormula
    Debug.Print getDerivative改(sFormula)
    Debug.Assert getDerivative改(sFormula) = "y=15x^2+4x+7"

    sFormula = "y = 7x - 5x^3 + 2x^2"
    Debug.Print sFormula
    Debug.Print getDerivative改(sFormula)
    Debug.Assert getDerivative改(sFormula) = "y=7-15x^2+4x"

    sFormula = "y = 7x^+9-3x^5+12x^-3-x^2+10x+4"
    Debug.Print sFormula
    Debug.Print getDerivative改(sFormula)
    Debug.Assert getDerivative改(sFormula) = "y=63x^8-15x^4-36x^-4-2x+10"

    sFormula = "y = 7x^9-3x^5-22x^-3+4x^2+x+4"
    Debug.Print sFormula
    Debug.Print getDerivative改(sFormula)
    Debug.Assert getDerivative改(sFormula) = "y=63x^8-15x^4+66x^-4+8x+1"

    sFormula = "y = 5"
    Debug.Print sFormula
    Debug.Print getDerivative改(sFormula)
    Debug.Assert getDerivative改(sFormula) = ""

End Sub

Private Function getDerivative改(ByVal sFormula As String) As String

    Dim xi()        As xItem
    Dim sFormulaW   As String
    Dim sItem       As String
    Dim sSign       As String
    Dim sResult     As String
    Dim i           As Long

    sFormulaW = Replace$(sFormula, " ", "")

    If Not getItemInfo改(sFormulaW, xi) Then
        Debug.Print "Not matched."

        Exit Function
    End If

    For i = 0 To UBound(xi)
        With xi(i)
            If (.xiSign = "-") Eqv (Sgn(.xiPower) < 0) Then
                sSign = "+"
            Else
                sSign = "-"
            End If

            sItem = sSign & CStr(.xiCoefficient * Abs(.xiPower)) & "x"

            '指数部の値による処理の振り分け
            Select Case .xiPower
            Case 0
                '何も付加しない
            Case 1
                '符号、係数部のみ使用し、"x"および指数部は付加しない
                sResult = sResult & .xiSign & CStr(.xiCoefficient)
            Case 2
                '指数部は１なので、"^"以降は省略する
                sResult = sResult & sItem
            Case Else
                '指数部が２より大きい or ０未満
                sResult = sResult & sItem & "^" & CStr(.xiPower - 1)
            End Select
        End With
    Next i

    If Left$(sResult, 1) = "+" Then
        sResult = Mid$(sResult, 2)
    End If

    getDerivative改 = "y=" & sResult

End Function

Private Function getItemInfo改(ByVal sFormula As String, ByRef xi() As xItem) As Boolean

    Dim re  As New RegExp
    Dim mc  As MatchCollection
    Dim i   As Long

    With re
        .Global = True
        .MultiLine = False
        .IgnoreCase = True
        .Pattern = "([+-]?)(\d*)x(\^([+-]?\d+))?"
    End With

    Set mc = re.Execute(sFormula)

    If mc.Count = 0 Then
        Exit Function
    End If

    ReDim xi(mc.Count - 1)

    For i = 0 To mc.Count - 1
        With xi(i)
            .xiSign = mc.Item(i).SubMatches(0)

            If mc.Item(i).SubMatches(1) = "" Then
                .xiCoefficient = 1
            Else
                .xiCoefficient = CLng(mc.Item(i).SubMatches(1))
            End If

            If mc.Item(i).SubMatches(3) = "" Then
                .xiPower = 1
            Else
                .xiPower = CLng(mc.Item(i).SubMatches(3))
            End If
        End With
    Next i

    getItemInfo改 = True

End Function

実行結果

y = 5x^3 + 2x^2 + 7x + 5
y=15x^2+4x+7
y = 7x - 5x^3 + 2x^2
y=7-15x^2+4x
y = 7x^+9-3x^5+12x^-3-x^2+10x+4
y=63x^8-15x^4-36x^-4-2x+10
y = 7x^9-3x^5-22x^-3+4x^2+x+4
y=63x^8-15x^4+66x^-4+8x+1
y = 5
Not matched.

Not matched.

ちなみに、同じく正規表現を使用た方法は、こちらにも。
infoment.hatenablog.com

ExcelのVBAで使えるDLLを、C++（Visual Studio 2017）で作る。・・・その６ デバッグ編

初めに

DLLを作ってきましたが、作ったからには、動作確認が必要です。
今回は、DLLのデバッグ方法についてです。

このシリーズの記事を読んでくださった方は、基本的にVBAのデバッグ経験者と思います。
ブレークポイントを設定して、ステップ実行したり・・・
基本的な部分は、DLLのデバッグでも同様です。

私の場合、VBAのコードから、DLLのコードにどうやって入っていくのかが
最初の時、わからなかったのでそのあたりについて説明します。
（VBAでのデバッグ経験があることを前提に、類似した細かい部分は、端折ります。）

キーワード

アタッチ

アタッチとは、

デバッガーがプロセスやタスクを監視対象にすること

https://www.wdic.org/w/TECH/%E3%82%A2%E3%82%BF%E3%83%83%E3%83%81

今回の場合、Excelに接続して、監視できるようにするといった感じでしょうか。

デタッチ

こちらは、アタッチの逆。
アタッチした対象を監視下から外して、切り離すことです。

実際にやってみる

操作の流れ

1. DLLを呼び出すExcelファイルの起動
2. Visual Studio（DLLソリューション）の起動
3. アタッチ
4. DLL側コードへのブレークポイント設定
5. VBAからDLL関数の呼び出し
6. DLLコードのステップ実行
7. デタッチ

アタッチ

1. 対象のExcelファイルと、DLLソリューションを開く。
   • Visual Studioのソリューション構成が「Debug」になっているか、確認しておくこと。
     
   • DLLのプロジェクトがビルド済みであること。
2. Visual Studioのメニューから、プロセスにアタッチを選択。
   • 「デバッグ」-「プロセスにアタッチ」をクリック
     
3. プロセスにアタッチダイアログから、DLLの呼び出し元となるExcelを探して、選択し、アタッチボタンをクリック。
   

ブレークポイント

デバッグを開始する部分に、ブレークポイントを設定する。
F9キーで、ブレークポイントの設定、解除ができます。
ブレークポイントを設定したら、VBA側からDLLの関数を呼び出すコードを実行します。

ステップイン

１コードステートメントを実行します。
対象コードステートメントが、関数の呼び出しの場合、呼び出し先の関数の中の行へ入っていきます。
ショートカットキーは、F11キーです。

ステップオーバー

１コードステートメントを実行します。
ステップインと違うのは、対象行が、関数の呼び出しの場合、
呼び出し先の関数を実行しますが、呼び出し先関数の内部コードをステップ実行しません。
ショートカットキーは、F10キーです。

ステップアウト

ステップインとは逆に、ステップインした関数から抜ける場合に使用します。
ショートカットキーは、Shift + F11キーです。

続行

次のブレークポイントがある場合には、次のブレークポイントまで実行します。
次のブレークポイントがない場合、最後まで処理を続行します。
ショートカットキーは、F5キーです。

デバッグの停止

全てデタッチ

プロセスに再アタッチ

一度アタッチしたプロセスをデタッチした後に、再度同じプロセスにアタッチしたい場合には、プロセスに再アタッチを選択すると、アタッチするプロセスを選択する手間が省けます。
ショートカットキーは、Shift + Alt + P です。

ウォッチ

変数を右クリックして、ウォッチの追加をクリック

確認してみる。

自動変数

ウォッチのように自分で追加しなくても、スコープに応じて表示される変数が変わっていく。

ローカル

ウォッチのように自分で追加しなくても、スコープに応じて表示される変数が変わっていく。

メモリ

変数のアドレスを指定したり、アドレスを直接指定して、該当アドレスのメモリ状態を確認することが出来ます。
構造体の回で、packの指定有無で、データの配置を確認したときは、この方法を使用しました。

変数ppsaを選択する様子

選択した変数のアドレスのメモリ状態

アドレスを指定しなければいけないので、ポインタ変数の場合はそのまま指定できますが、
通常の変数の場合には、先頭に & を付けて指定する必要があります。
例えば、
int hoge;
の場合には、
&hoge
と指定します。

ポインタ変数の場合には、ローカルウィンドウなどからドラッグ・アンド・ドロップでも指定できます。

主なショートカットキー

VBA と Visual Studio では、微妙にショートカットキーが違うので・・・

VBE でF8キーを押して、Visula Studio に入っても、F8キーを押して、
「あれ、進まない？あっ、F10だった。」とかよくやってますwww

項目	VBA	Visual Studio	備考
ブレークポイントの設定/解除	F9	F9
全てのブレークポイントの解除	Ctrrl + Shift + F9	Ctrrl + Shift + F9
ステップイン	F8	F11
ステップオーバー	Shift + F8	F10
ステップアウト	Ctrl + Shift + F8	Shift + F11
カーソル行の前まで実行	Ctrl + F8	Ctrl + F10
デバッグの停止		Shift + F5

その他（情報提供依頼）

Rubberduckというアドインがあって、便利そうだのだけど、
こいつをインストールしたところ、Visual Studioでアタッチしても、ExcelのVBEから入っていけない（デバッグできない）現象に遭遇。
現状アンイストールしか対応方法がわからずじまい。
解決策をご存知の方、いらっしゃいましたら教えてください。

最後に

今回で、VBAで使えるDLL作成に関する記事は終了です。
後半は、手抜き気味のような気もしますが、参考になれば幸いです。

関連リンク

docs.microsoft.com
docs.microsoft.com
docs.microsoft.com

www.excel-chunchun.com

ExcelのVBAで使えるDLLを、C++（Visual Studio 2017）で作る。・・・その５ 構造体の受け渡し

初めに

これまで、数値、文字列、配列、バリアントと各種の型の受け渡しとやってきましたが、今回は、構造体です。

構造体は、VBAとDLLのそれぞれでの定義を間違えると、

• 正しいデータの受け渡しが出来ない
• 正しくデータを読み込めない
• 正しくデータを更新できない

といった事になりかねません。
VBA側、DLL側の両方で、正しい定義を行い、十分な確認をすることが必要です。

事前準備

アライメント

構造体を扱う場合、注意が必要なのはアライメントです。

アライメントについては、以下のサイトに詳しく書かれているので、参考にしてください。
www7b.biglobe.ne.jp
www5d.biglobe.ne.jp

アライメントを調整する方法としては、

• #pragma pack(n) を使用する
• 構造体のメンバーに、アライメントを調整するためのダミーメンバーを加える

などがあります。

#pragma pack の使用については、Microsoft のサイト内に、以下のような記述があります。

VBA では、ユーザー定義データ型のデータ要素は 4 バイト境界にパッキングされます。
Visual Studio では、このデータ要素が既定で 8 バイト境界にパッキングされます。
そのため、C/C++ 構造体の定義は

#pragma pack(4)
//ここに構造体を定義
#pragma pack()

ブロックで囲んで要素の配置がずれないようにする必要があります。

https://docs.microsoft.com/ja-jp/office/client-developer/excel/how-to-access-dlls-in-excel#argument-types-in-cc-and-vba

#pragma pac による要素の配置への影響の確認

以下のような構造体を定義。
VBA

Private Type SampleType
    iValue  As Integer
    dValue  As Double
    lValue  As Long
End Type

Private Type SampleTypeWithDummy
    iValue      As Integer
    byDummy(0 To 5)  As Byte
    dValue      As Double
    lValue      As Long
End Type

Private Type SampleTypeWithDummy2
    iValue      As Integer
    byDummy(0 To 5)  As Byte
    dValue      As Double
    lValue      As Long
    lDummy      As Long
End Type

DLL

struct SampleNoPack
{
    short   nValue;
    double  dValue;
    long    lValue;
};

struct SampleNoPackWithDummy
{
    short   nValue;
    char    cDummy[6];
    double  dValue;
    long    lValue;
};

struct SampleNoPackWithDummy2
{
    short   nValue;
    char    cDummy[6];
    double  dValue;
    long    lValue;
    long    lDummy;
};

#pragma pack(4)
struct SamplePack
{
    short   nValue;
    double  dValue;
    long    lValue;
};
#pragma pack()

VBAから、DLLの関数に渡してみる。

    __declspec(dllexport) void WINAPI SetStructP(SamplePack* pst);
    __declspec(dllexport) void WINAPI SetStructNP(SampleNoPack* pst);
    __declspec(dllexport) void WINAPI SetStructNPWD(SampleNoPackWithDummy* pst);
    __declspec(dllexport) void WINAPI SetStructNPWD2(SampleNoPackWithDummy2* pst);

なお、各構造体のメンバーには、以下の値を設定しました。

メンバー	値	色（下図）
iValue	0x1234	黄
dValue	3.5	マゼンタ
lValue	0x56789ABC	シアン

それぞれのDLL内でのメモリ上の状態は、以下のようになりました。

pacあり、ダミーメンバーなし

配置は同一となった
VBAから渡した場合 （SampleType → SamplePack）

DLL内で宣言した場合

pacなし、ダミーメンバーなし

配置は異なる
というか、構造体のサイズ自体が異なる。

• LenB(SampleType):16
• sizeof(SampleNoPack):24

このため、正しい値を渡すことが出来ない。

VBAから渡した場合（SampleType → SampleNoPack）

DLL内で宣言した場合

プロシージャを抜ける際に、以下のエラーメッセージが表示された。

pacなし、ダミーメンバーあり

配置は同一となったように見える
こちらも、構造体のサイズ自体が異なる。

• LenB(SampleTypeWithDummy):20
• sizeof(SampleNoPackWithDummy):24

前述のパターンと違い、こちらの場合は、メンバーの配置が同一のため、値の受け渡しは出来た。

VBAから渡した場合（SampleTypeWithDummy → SampleNoPackWithDummy）

DLL内で宣言した場合

pacなし、ダミーメンバーあり２

配置は同一となった
こちらは、構造体のサイズが同じ。

• LenB(SampleTypeWithDummy2):24
• sizeof(SampleNoPackWithDummy2):24

VBAから渡した場合（SampleTypeWithDummy2 → SampleNoPackWithDummy2）

DLL内で宣言した場合

VBAから渡した方の最後の部分4Byteが0x00 × 4 でないのは、VBA側で値を設定したためなので、ここは気にしないで下さい。

メモ

アライメントの調整によりメンバー間に発生する領域は、

• VBAから渡された場合、0x00で埋められている。
• DLLで生成した変数の場合、0xCCで埋められている。（Visual Studio C++ では、未初期化の場合、この値になるようです。）

となり、全く同じにはなっていない。（DLL側で、変数宣言時に、0x00で初期化すれば、VBAと同じ状態にすることは可能）

構造体の構成によっては、アライメントの調整は不要となる場合もありえるが、後々変更が発生する可能性があるのであれば、予め対応しておいた方が良さそう。

コード

DLL

AccessibleFromVBA.h

#pragma once

extern "C"
{
#define ACCESSIBLEFROMVBA_API __declspec(dllexport)

//中略
#pragma pack(4)
    struct SamplePack
    {
        short   nValue;
        double  dValue;
        long    lValue;
    };
#pragma pack()

    ACCESSIBLEFROMVBA_API void WINAPI GetStructP(SamplePack* pst);
    ACCESSIBLEFROMVBA_API void WINAPI GetStructPArray(LPSAFEARRAY* ppsa);

    ACCESSIBLEFROMVBA_API void WINAPI SetStructP(const SamplePack* pst);
    ACCESSIBLEFROMVBA_API void WINAPI SetStructPArray(const LPSAFEARRAY* ppsa);
}

AccessibleFromVBA.cpp

追加分

ACCESSIBLEFROMVBA_API void WINAPI SetStructP(const SamplePack* pst)
{
    std::wstringstream ss;

    ss << pst->nValue << L"\n"
       << pst->dValue << L"\n"
       << pst->lValue << L"\n";

    MessageBox(NULL, ss.str().c_str(), L"SetStructP", MB_OK | MB_ICONINFORMATION);

    return;
}

ACCESSIBLEFROMVBA_API void WINAPI SetStructPArray(const LPSAFEARRAY* ppsa)
{
    //格納されているデータ型の確認
    VARTYPE vt;
    HRESULT hResult = SafeArrayGetVartype(*ppsa, &vt);

    if (SUCCEEDED(hResult))
    {
        //VBAから構造体を渡した場合、hResult は、E_INVALIDARG が返るので
        //FAILED(hResult) で弾かない。
        return;
    }

    //要素のサイズ
    UINT uiElemBytes = SafeArrayGetElemsize(*ppsa);

    if (uiElemBytes != sizeof(SamplePack))
    {
        //構造体のサイズと異なる場合、処理しない。
        return;
    }

    //次元数
    UINT uiDims = SafeArrayGetDim(*ppsa);

    std::wstringstream ss;

    for (UINT i = 1; i <= uiDims; ++i)
    {
        LONG lLBound, lUBound;
        hResult = SafeArrayGetLBound(*ppsa, i, &lLBound);
        hResult = SafeArrayGetUBound(*ppsa, i, &lUBound);

        ss << i << L"次元\n"
           << L"　LBound：" << lLBound << L"\n"
           << L"　UBound：" << lUBound << L"\n";
    }

    ss << L"データ型：SamplePack\n";

    if (uiDims == 1)
    {
        LONG lIndex;

        LONG lLBound;
        LONG lUBound;

        hResult = SafeArrayGetLBound(*ppsa, 1, &lLBound);
        hResult = SafeArrayGetUBound(*ppsa, 1, &lUBound);

        for (LONG i = lLBound; i <= lUBound; ++i)
        {
            SamplePack sp;
            hResult = SafeArrayGetElement(*ppsa, &i, &sp);

            ss << sp.nValue << L"\n"
               << sp.dValue << L"\n"
               << sp.lValue << L"\n"
               << L"\n";
        }
    }

    MessageBox(NULL, ss.str().c_str(), L"SetStructPArray", MB_OK | MB_ICONINFORMATION);

    return;
}

ACCESSIBLEFROMVBA_API void WINAPI GetStructP(SamplePack* pst)
{
    pst->nValue *= 2;
    pst->dValue *= 2;
    pst->lValue *= 2;

    return;
}

ACCESSIBLEFROMVBA_API void WINAPI GetStructPArray(LPSAFEARRAY* ppsa)
{
    //格納されているデータ型の確認
    VARTYPE vt;
    HRESULT hResult = SafeArrayGetVartype(*ppsa, &vt);

    if (SUCCEEDED(hResult))
    {
        //VBAから構造体を渡した場合、hResult は、E_INVALIDARG が返るので
        //FAILED(hResult) で弾かない。
        return;
    }

    //要素のサイズ
    UINT uiElemBytes = SafeArrayGetElemsize(*ppsa);

    if (uiElemBytes != sizeof(SamplePack))
    {
        //構造体のサイズと異なる場合、処理しない。
        return;
    }

    //次元数
    UINT uiDims = SafeArrayGetDim(*ppsa);

    if (uiDims == 1)
    {
        LONG lLBound;
        LONG lUBound;

        hResult = SafeArrayGetLBound(*ppsa, 1, &lLBound);
        hResult = SafeArrayGetUBound(*ppsa, 1, &lUBound);

        for (LONG i = lLBound; i <= lUBound; ++i)
        {
            SamplePack sp;
            hResult = SafeArrayGetElement(*ppsa, &i, &sp);

            sp.nValue *= 2;
            sp.dValue *= 2;
            sp.lValue *= 2;

            hResult = SafeArrayPutElement(*ppsa, &i, &sp);
        }
    }

    return;
}

AccessibleFromVBA.def

LIBRARY AccessibleFromVba

EXPORTS
    DoNothing
    GetNumberI
    GetNumberI2
    SetString
    SetStringS
    GetStringByParam
    GetStringByParamS
    GetStringByRetVal
    GetStringByRetValS
    GetArrayPE
    GetArrayAD
    GetArray2
    SetArrayGE
    SetArrayAD
    GetArrayV
    SetArrayV
    GetStructP
    GetStructPArray
    SetStructP
    SetStructPArray

VBA

Private Type SampleType
    iValue  As Integer
    dValue  As Double
    lValue  As Long
End Type

Private Declare Sub SetStructP Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\ForTest\AccessibleFromVBA.dll" (ByRef udtSample As SampleType)
Private Declare Sub SetStructPArray Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\ForTest\AccessibleFromVBA.dll" (ByRef udtSample() As SampleType)

Private Declare Sub GetStructP Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\ForTest\AccessibleFromVBA.dll" (ByRef udtSample As SampleType)
Private Declare Sub GetStructPArray Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\ForTest\AccessibleFromVBA.dll" (ByRef udtSample() As SampleType)


Public Sub DllTestSetStruct()

    Dim udtSample   As SampleType

    udtSample.iValue = 18
    udtSample.dValue = 3.5
    udtSample.lValue = 52

    Call SetStructP(udtSample)

End Sub

Public Sub DllTestSetStructArray()

    Dim udtSample(1)   As SampleType

    udtSample(0).iValue = 1234
    udtSample(0).dValue = 3.5
    udtSample(0).lValue = 56789

    udtSample(1).iValue = 3456
    udtSample(1).dValue = 4.5
    udtSample(1).lValue = 7890

    Call SetStructPArray(udtSample)

End Sub

Public Sub DllTestGetStruct()

    Dim udtSample   As SampleType

    udtSample.iValue = 1000
    udtSample.dValue = 3.5
    udtSample.lValue = 200000

    Debug.Print "Before"
    Debug.Print udtSample.iValue, udtSample.dValue, udtSample.lValue

    Call GetStructP(udtSample)

    Debug.Print "After"
    Debug.Print udtSample.iValue, udtSample.dValue, udtSample.lValue

End Sub

Public Sub DllTestGetStructArray()

    Dim udtSample(1)    As SampleType
    Dim i               As Long

    udtSample(0).iValue = 1000
    udtSample(0).dValue = 3.5
    udtSample(0).lValue = 2000000

    udtSample(1).iValue = 3000
    udtSample(1).dValue = 4.5
    udtSample(1).lValue = 6000000

    Debug.Print "Before"
    For i = LBound(udtSample) To UBound(udtSample)
        Debug.Print udtSample(i).iValue, udtSample(i).dValue, udtSample(i).lValue
    Next i

    Call GetStructPArray(udtSample)

    Debug.Print "After"
    For i = LBound(udtSample) To UBound(udtSample)
        Debug.Print udtSample(i).iValue, udtSample(i).dValue, udtSample(i).lValue
    Next i

End Sub

実行結果

DllTestSetStruct

DllTestSetStructArray

DllTestGetStruct

Before
 1000          3.5           200000 
After
 2000          7             400000 

DllTestGetStructArray

Before
 1000          3.5           2000000 
 3000          4.5           6000000 
After
 2000          7             4000000 
 6000          9             12000000 

まとめ

構造体の受け渡しでは、アライメントに十分に気をつける必要があることが確認できました。

構造体の配列の受け渡しは、SAFEARRAYで処理しようとした場合、これまでのやり方のように、vtで型を判断することが出来ず、構造体のサイズで判断しました。
調べていると、VT_RECORD というキーワードが出てくるが、VBAではなく、VBでの処理であり、いろいろと面倒な手続きがあるようで、VBAでの方法を見つけられず、上記のような処理で妥協していまいました。

次回予告

次回はDLLのデバッグの方法を簡単に説明して、このシリーズを終了とするつもりです。

過去掲載分

z1000s.hatenablog.com
z1000s.hatenablog.com
z1000s.hatenablog.com
z1000s.hatenablog.com
z1000s.hatenablog.com
z1000s.hatenablog.com
z1000s.hatenablog.com

ExcelのVBAで使えるDLLを、C++（Visual Studio 2017）で作る。・・・その４．３（非配列Variant型変数による配列受け渡し編）

初めに

前回の予告通り、今回は非配列のVariant型変数に配列を格納して、DLLとの受け渡しをしてみます。

処理

処理方法は、これまでにやってきた事の組み合わせで出来ます。

DLL側でVariant型を受け取る処理は、文字列の受け渡しを行った時と同じ。
受け取ってから、VARIANT型変数のvtを見て、配列かどうかの判断を行います。
配列であることの確認できれば、VARIANT型変数のparrayに目的のSAFEARRAYがあります。
SAFEARRAYがわかれば、あとは、前回の処理を使えます。

コード

DLL

AccessibleFromVBA.h

追加分

    ACCESSIBLEFROMVBA_API void WINAPI GetArrayV(LPVARIANT pv);
    ACCESSIBLEFROMVBA_API void WINAPI SetArrayV(const LPVARIANT pv);

AccessibleFromVBA.cpp

▶クリックで展開

ACCESSIBLEFROMVBA_API void WINAPI GetArrayV(LPVARIANT pv)
{
    if (!(pv->vt & VT_ARRAY))
    {
        //配列でなければ処理終了
        return;
    }

    UINT uiDims = SafeArrayGetDim(pv->parray);

    if (uiDims != 1)
    {
        return;
    }

    HRESULT hResult;
    long lUbound;
    long lLbound;

    hResult = SafeArrayGetLBound(pv->parray, 1, &lLbound);
    hResult = SafeArrayGetUBound(pv->parray, 1, &lUbound);

    //データ型判定を簡略化するために、VT_ARRAYフラグをOFFする
    unsigned short vt = pv->vt ^ VT_ARRAY;

    if (vt == VT_I4)
    {
        for (long i = lLbound; i <= lUbound; ++i)
        {
            long lValue;
            hResult = SafeArrayGetElement(pv->parray, &i, &lValue);

            if (lValue != 0)
                lValue *= 2;
            else
                lValue = -1;

            hResult = SafeArrayPutElement(pv->parray, &i, &lValue);
        }
    }
    else if (vt == VT_BSTR)
    {
        for (long i = lLbound; i <= lUbound; ++i)
        {
            BSTR bstr = SysAllocString(L"");

            hResult = SafeArrayGetElement(pv->parray, &i, &bstr);

            std::wstring ws = std::wstring(bstr, SysStringLen(bstr));

            ws += L" GetArrayV ";
            ws += std::to_wstring(i);

            SysReAllocString(&bstr, ws.c_str());

            hResult = SafeArrayPutElement(pv->parray, &i, bstr);

            SysFreeString(bstr);
        }
    }

    return;
}

ACCESSIBLEFROMVBA_API void WINAPI SetArrayV(const LPVARIANT pv)
{
    if (pv == nullptr || !(pv->vt & VT_ARRAY))
    {
        //配列でなければ処理終了
        return;
    }

    std::wstringstream ss;

    UINT uiDims = SafeArrayGetDim(pv->parray);
    ss << L"次元数：" << uiDims << L"\n";

    HRESULT hResult;
    long* plUbound = new long[uiDims];
    long* plLbound = new long[uiDims];

    for (UINT i = 0; i < uiDims; ++i)
    {
        hResult = SafeArrayGetLBound(pv->parray, i + 1, &plLbound[i]);
        hResult = SafeArrayGetUBound(pv->parray, i + 1, &plUbound[i]);

        ss << i + 1 << L"次元：" << L"\n"
            << L"  LBound:" << plLbound[i] << L"\n"
            << L"  UBound:" << plUbound[i] << L"\n";
    }

    //データ型判定を簡略化するために、VT_ARRAYフラグをOFFする
    unsigned short vt = pv->vt ^ VT_ARRAY;
    
    ss << L"データ型：";

    if (vt == VT_I4)
    {
        ss << L"Long\n";

        if (uiDims == 2)
        {
            long lIndex[] = { 0, 0 };

            for (long i = plLbound[0]; i <= plUbound[0]; ++i)
            {
                lIndex[0] = i;

                for (long j = plLbound[1]; j <= plUbound[1]; ++j)
                {
                    lIndex[1] = j;
                    int iValue(0);
                    hResult = SafeArrayGetElement(pv->parray, lIndex, &iValue);

                    ss << iValue << L"\n";
                }
            }
        }
        else
        {
            long* plIndex = new long[uiDims];

            for (UINT i = 0; i <= uiDims; ++i)
            {
                plIndex[i] = plLbound[i];
            }

            for (long i = plLbound[0]; i <= plUbound[0]; ++i)
            {
                plIndex[0] = i;

                int iValue(0);
                hResult = SafeArrayGetElement(pv->parray, plIndex, &iValue);

                ss << iValue << L"\n";
            }

            delete[] plIndex;
        }
    }
    else if (vt == VT_BSTR)
    {
        ss << L"String\n";

        if (uiDims == 1)
        {
            for (long i = plLbound[0]; i <= plUbound[0]; ++i)
            {
                BSTR bstr = SysAllocString(L"");

                SafeArrayGetElement(pv->parray, &i, &bstr);

                std::wstring ws = std::wstring(bstr, SysStringLen(bstr));

                ss << ws.c_str() << L"\n";

                SysFreeString(bstr);
            }
        }
        else
        {
            ss << L"not 1 Dimensions.\n";
        }
    }
    else
    {
        ss << L"Other Data Type.\n";
    }

    delete[] plUbound;
    delete[] plLbound;

    MessageBox(NULL, ss.str().c_str(), L"SetArrayV", MB_OK | MB_ICONINFORMATION);

    return;
}

AccessibleFromVBA.def

LIBRARY AccessibleFromVba

EXPORTS
    DoNothing
    GetNumberI
    GetNumberI2
    SetString
    SetStringS
    GetStringByParam
    GetStringByParamS
    GetStringByRetVal
    GetStringByRetValS
    GetArrayPE
    GetArrayAD
    GetArray2
    SetArrayGE
    SetArrayAD
    GetArrayV
    SetArrayV

VBA

Private Declare Sub SetArrayV Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\ForTest\AccessibleFromVBA.dll" (ByRef v As Variant)
Private Declare Sub GetArrayV Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\ForTest\AccessibleFromVBA.dll" (ByRef v As Variant)

Public Sub DllTestSetArrayV()

    Dim v   As Variant
    Dim lArray(3, 1)  As Long
    Dim sArray()    As String
    Dim dArray(2)   As Double
    Dim i   As Long
    Dim j   As Long

    ReDim sArray(2)

    sArray(0) = "Z1000"
    sArray(1) = "ZX-10R"
    sArray(2) = "Kawasaki"

    v = sArray

    Call SetArrayV(v)

    ReDim sArray(2, 2)

    v = sArray

    Call SetArrayV(v)

    For i = LBound(lArray, 1) To UBound(lArray, 1)
        For j = LBound(lArray, 2) To UBound(lArray, 2)
            lArray(i, j) = (i + 1) * 10 + j
        Next j
    Next i

'Arrayを使った場合、DLL側では、vt が VT_VARIANT | VT_ARRAY になるので注意が必要
'以下のコメントしたコードでは、VT_I4 | VT_ARRAY にはならない。
'    v = Array(1&, 2&, 3&, 4&)
    v = lArray

    Call SetArrayV(v)

    v = dArray

    Call SetArrayV(v)

End Sub

Public Sub DllTestGetArrayV()

    Dim vL  As Variant
    Dim vS  As Variant
    Dim i   As Long

    ReDim vL(3) As Long

    vL(0) = 100
    vL(1) = 200
    vL(2) = 300
    vL(3) = 400

    Debug.Print "Before"

    For i = LBound(vL) To UBound(vL)
        Debug.Print i, vL(i)
    Next i

    Call GetArrayV(vL)

    Debug.Print vbCrLf & "After"

    For i = LBound(vL) To UBound(vL)
        Debug.Print i, vL(i)
    Next i

    Debug.Print ""

    ReDim vS(2) As String

    vS(0) = "Z1000"
    vS(1) = "ZX-10R"
    vS(2) = "Ninja 900R"

    Debug.Print "Before"

    For i = LBound(vS) To UBound(vS)
        Debug.Print i, vS(i)
    Next i

    Call GetArrayV(vS)

    Debug.Print vbCrLf & "After"

    For i = LBound(vS) To UBound(vS)
        Debug.Print i, vS(i)
    Next i

End Sub

実行結果

DllTestSetArrayV

DllTestGetArrayV

Before
 0             100 
 1             200 
 2             300 
 3             400 

After
 0             200 
 1             400 
 2             600 
 3             800 

Before
 0            Z1000
 1            ZX-10R
 2            Ninja 900R

After
 0            Z1000 GetArrayV 0
 1            ZX-10R GetArrayV 1
 2            Ninja 900R GetArrayV 2

まとめ

今回は、過去の応用のようなものなので、サクッと簡単に終わらせてしまいました。

今後の予定は、

• 構造体の受け渡し
• DLLのデバッグ方法

をまとめられればいいなと思っています。

過去掲載分

z1000s.hatenablog.com
z1000s.hatenablog.com
z1000s.hatenablog.com
z1000s.hatenablog.com
z1000s.hatenablog.com
z1000s.hatenablog.com
z1000s.hatenablog.com

ExcelのVBAで使えるDLLを、C++（Visual Studio 2017）で作る。・・・その４．２（配列編）

初めに

前回は、予定を変更して、String型の受け渡しをする方法についてまとめました。

今回は、SAFEARRAYについてどのようなものか調べた前々回の続編です。
実際に配列データの受け渡しを行います。

SAFEARRAYに関する追加情報

配列要素のデータ型

前回の記事で、気が付いた人もいるかもしれないが、SAFEARRAY構造体のメンバーには配列要素の型情報がない。
fFeatures に、VARIANT型およびBSTR型の場合に立つフラグがあるが、それ以外の型の場合、構造体メンバーだけでは判断ができない。

これについては、後述する型判定関数があるので、基本的な型であれば問題ない。

引数

VBAでは、配列はByValでは引数に指定できないので、ByRef指定となる。
そのため、DLL側では、SAFEARRAYの受け渡しをするために、引数は、
SAFEARRAYを指すポインタ（SAFEARRAY*）ではなく、
SAFEARRAYを指すポインタへのポインタ（SAFEARRAY**）とする。

一方、呼び出すVBA側では、Declare で受け渡しをする引数をどの様に書けばいいのか？
VBAには、SAFEARRYなるデータ型はない。
結論から言えば、通常のプロシージャと同様で、下記のようになる。

Declare Sub 関数名 Lib "DLL名" (ByRef 配列変数名() As データ型)

As Byteだろうが
As Longだろうが
As Variantだろうが
構わない。

言い換えれば、下記のように、Declare でAlias を設定すれば、DLLのひとつの関数で異なるデータ型の受け渡しも可能となる。
DLLの関数宣言

__declspec(dllexport) void WINAPI FuncX(LPSAFEARRAY* ppsa);

VBA側の宣言
上記のDLLの関数宣言に対し、以下の宣言は、いずれも問題ない。

Declare Sub XByte Lib "DLL名" Alias "FuncX" (ByRef 配列変数名() As Byte)
Declare Sub XLong Lib "DLL名" Alias "FuncX" (ByRef 配列変数名() As Long)
Declare Sub XVariant Lib "DLL名" Alias "FuncX" (ByRef 配列変数名() As Variant)

主な処理と使用する関数

HRESULTを返す関数の成否判定

いくつかの関数は復帰値の型が、HRESULTとなっている。
これらの関数は、成功すると S_OK （0x00000000）を返す。
成功を判定するマクロとして、SUCCEEDED マクロがあり、
失敗を判定するマクロとして、FAILED マクロがあるので、必要に応じて使えばよい。

使用例

HRESULT hResult = SafeArrayAccessData(*ppsa, (void**)&piValue);

if (FAILED(hResult))
    return;

HRESULT が取る値（抜粋？）については、こちらに記載されている。

SAFEARRAYに格納されている要素のデータ型分類値の取得

SafeArrayGetVartype

HRESULT SafeArrayGetVartype(
  SAFEARRAY *psa,
  VARTYPE   *pvt
);

VBAから渡した場合、VERTYPEは、以下のような値を取る。

項目	データ型		値	備考
	VBA	C++
VT_I2	Integer	short	0x0002
VT_I4	Long	int	0x0003
VT_R4	Single	float	0x0004
VT_R8	Double	double	0x0005
VT_CY	Currency	CY	0x0006
VT_DATE	Date	DATE	0x0007
VT_BSTR	String	BSTR	0x0008
VT_BOOL	Boolean	BOOL	0x00B
VT_VARIANT	Variant	VARIANT	0x00C
VT_UI1	Byte	unsigned char	0x0011
VT_I8	LongLong	long long	0x0014	64bit版のみ

docs.microsoft.com

配列の次元数の取得

SafeArrayGetDim

UINT SafeArrayGetDim(
  SAFEARRAY *psa
);

docs.microsoft.com

配列の１要素のサイズの取得

SafeArrayGetElemsize

UINT SafeArrayGetElemsize(
  SAFEARRAY *psa
);

例えば、VBA側で、

Dim arryL(2) As Long
Dim arryV(2) As Variant
Dim arryS(2) As String

と宣言されていた場合、
arryLは、Longのサイズになるので、4 (Byte)が返る。
arryVは、Variantのサイズになるので、16 (Byte)が返る。
arrySは、Stringのポインタサイズ（？）になるので、4 (Byte)が返る。

docs.microsoft.com

指定した次元のインデックスの指定可能最小値(LBound)の取得

SafeArrayGetLBound

HRESULT SafeArrayGetLBound(
  SAFEARRAY *psa,
  UINT      nDim,
  LONG      *plLbound
);

nDim は、対象となる次元。
左端の次元が１となり、右に行くと増えていく。
指定方法が、SAFEARRAY メンバーの rgsabound[n].lLbound とは異なるので、何らかの理由で両関数を使い分ける必要がある場合には注意が必要。

Dim arryL(1 To 2, 3 To 5) As Long

の場合、

nDim	Lbound
1	1
2	3

となる。

SAFEARRAYのメンバー、rgsabound[n].lLbound を参照して取得する方法もある。
指定方法は、前回のrgsaboundの説明を参照。
SafeArrayGetLBound の方が、直感的に指定しやすい。

docs.microsoft.com

指定した次元のインデックスの指定可能最大値(UBound)の取得

SafeArrayGetUBound

HRESULT SafeArrayGetUBound(
  SAFEARRAY *psa,
  UINT      nDim,
  LONG      *plUbound
);

SafeArrayGetLBound と同様。

こちらは、SAFEARRAYに直接取得できるメンバーはない。
rgsabound[n].lLbound + rgsabound[n].cElements - 1
で計算はできる。

docs.microsoft.com

配列のロックカウントをインクリメントと、配列データへのポインターの取得

SafeArrayAccessData

HRESULT SafeArrayAccessData(
  SAFEARRAY  *psa,
  void HUGEP **ppvData
);

ポインタを使って、要素にアクセスする場合に使用するものらしい。
配列データへのポインタを返すのと同時に、SafeArrayへのロックを行う。

SAFEARRAY ppvData 使用後、SafeArrayUnaccessData を呼び出さなければいけない。

SafeArrayGetElement および SafeArrayPutElement を使用するよりも高速に処理ができるらしい。

This approach is faster than using SafeArrayGetElement and SafeArrayPutElement.

https://docs.microsoft.com/ja-jp/windows/win32/api/oleauto/nf-oleauto-safearrayaccessdata?f1url=https%3A%2F%2Fmsdn.microsoft.com%2Fquery%2Fdev15.query%3FappId%3DDev15IDEF1%26l%3DJA-JP%26k%3Dk(OLEAUTO%2FSafeArrayAccessData)%3Bk(SafeArrayAccessData)%3Bk(DevLang-C%2B%2B)%3Bk(TargetOS-Windows)%26rd%3Dtrue#examples

多次元配列の場合、前回の記事に記載の通り、ポインタのインクリメントと配列のインデックスに注意が必要。

HUGEP は正直なところ、よくわかっていない。
１６bit時代（？）に使われていたみたいだが・・・
省略して、単に void** にキャストしても、データは取得できた。
とりあえず、使わない方向で行くことに・・・

docs.microsoft.com

配列のロックカウントをデクリメントと、SafeArrayAccessDataによって取得されたポインターの無効化

SafeArrayUnaccessData

HRESULT SafeArrayUnaccessData(
  SAFEARRAY *psa
);

SafeArrayAccessData によりロックした配列のアンロックを行う。

docs.microsoft.com

配列記述子と配列内のすべてのデータの破棄

SafeArrayDestroy

HRESULT SafeArrayDestroy(
  SAFEARRAY *psa
);

配列の単一の要素の取得

SafeArrayGetElement

HRESULT SafeArrayGetElement(
  SAFEARRAY *psa,
  LONG      *rgIndices,
  void      *pv
);

rgIndices

配列の各次元のインデックスのベクトル。
右端（最下位）の次元はrgIndices [0]
左端の次元は、rgIndices [psa-> cDims – 1]

２次元以上の配列の場合、要素数が配列の次元数のlong型の配列を用意して、
取得したい要素の各次元のインデックスを格納して、関数に渡す。

Dim  arry(3, 3, 3) As Long

という配列があり、arry(1, 2, 3) の要素を取得したい場合には、以下のようにすればよい。

long  lIndex[] = {1, 2, 3};
int iValue;
SafeArrayGetElement(*ppsa, lIndex, &iValue);

pv

取得した要素を格納する変数

docs.microsoft.com

データ要素を配列内の指定された場所に保存

SafeArrayPutElement

HRESULT SafeArrayPutElement(
  SAFEARRAY *psa,
  LONG      *rgIndices,
  void      *pv
);

使い方は、SafeArrayGetElementと同様。（pvは、書き込むデータ）

long lValue = getSomeValue();
SafeArrayPutElement(*ppsa, &lIndex, &lValue);

ただし、BSTRの場合は注意が必要。

BSTR bstr;
bstr = SysAllocStringByteLen(pszReturn, lenByte);
//&bstrではないので注意！！！(& は不要)
SafeArrayPutElement(*ppsa, &lIndex, bstr);

docs.microsoft.com

配列内のすべてのデータの破棄

SafeArrayDestroy

HRESULT SafeArrayDestroy(
  SAFEARRAY *psa
);

既存の配列記述子と配列内のすべてのデータを破棄します。オブジェクトが配列に格納されている場合、配列内の各オブジェクトでReleaseが呼び出されます。
docs.microsoft.com

VBAからDLLへ渡す

VBAから渡された配列の値を、メッセージボックスで表示してみました。

処理の流れ

1. 格納されているデータ型の確認
2. 配列の次元数の確認
3. 各次元の要素数、インデックスの上下限の確認
4. データ読み込み
5. 後処理

DLLからVBAへ返す

VBAから受け取った配列に、何らかの値を格納して返してみました。

処理の流れ

1. 格納されているデータ型の確認
2. 配列の次元数の確認
3. 各次元の要素数、インデックスの上下限の確認
4. データ書き込み
5. 後処理

コード

DLL

AccessibleFromVBA.h

▶クリックで展開

extern "C"
{
#define ACCESSIBLEFROMVBA_API __declspec(dllexport) 

	ACCESSIBLEFROMVBA_API void WINAPI DoNothing();
	ACCESSIBLEFROMVBA_API int  WINAPI GetNumberI(int i);
	ACCESSIBLEFROMVBA_API void WINAPI GetNumberI2(int* pi);

	ACCESSIBLEFROMVBA_API void WINAPI SetString(VARIANT vString);
	ACCESSIBLEFROMVBA_API void WINAPI SetStringS(const BSTR sString);

	ACCESSIBLEFROMVBA_API void WINAPI GetStringByParam(VARIANT* pvString);
	ACCESSIBLEFROMVBA_API void WINAPI GetStringByParamS(BSTR* pbstr);
	ACCESSIBLEFROMVBA_API VARIANT WINAPI GetStringByRetVal();
	ACCESSIBLEFROMVBA_API BSTR WINAPI GetStringByRetValS();

	ACCESSIBLEFROMVBA_API void WINAPI SetArrayGE(const LPSAFEARRAY* ppsa);
	ACCESSIBLEFROMVBA_API void WINAPI SetArrayAD(const LPSAFEARRAY* ppsa);

	ACCESSIBLEFROMVBA_API void WINAPI GetArrayPE(LPSAFEARRAY* ppsa);
	ACCESSIBLEFROMVBA_API void WINAPI GetArrayAD(LPSAFEARRAY* ppsa);
}

AccessibleFromVBA.cpp

追加部分のみ

プロトタイプ宣言

std::wstring	convMbc2Wstr(const char* lpcszSrc);
std::wstring	convMbcBstr2Wstr(const BSTR& bstr);

DLLに配列を渡す処理

▶クリックで展開

• GE：SafeArrayGetElementを使用して読み込む処理
• AD：SafeArrayAccessDataで取得したポインタを使用して読み込む処理

ACCESSIBLEFROMVBA_API void WINAPI SetArrayGE(const LPSAFEARRAY* ppsa)
{
    //格納されているデータ型の確認
    VARTYPE vt;
    HRESULT hResult = SafeArrayGetVartype(*ppsa, &vt);

    if (FAILED(hResult))
    {
        //VARIANTに格納できない（？）データの配列の場合、この判定ではNG
        return;
    }

    //次元数
    UINT uiDims = SafeArrayGetDim(*ppsa);

    std::wstringstream ss;

    for (UINT i = 1; i <= uiDims; ++i)
    {
        LONG lLBound, lUBound;
        hResult = SafeArrayGetLBound(*ppsa, i, &lLBound);
        hResult = SafeArrayGetUBound(*ppsa, i, &lUBound);

        ss << i << L"次元\n"
            << L"　LBound：" << lLBound << L"\n"
            << L"　UBound：" << lUBound << L"\n";
    }

    if (vt == VT_I4)
    {
        ss << L"データ型：Long\n";

        if (uiDims == 2)
        {
            LONG lIndex[2];

            LONG lLBound[2];
            LONG lUBound[2];

            hResult = SafeArrayGetLBound(*ppsa, 1, &lLBound[0]);
            hResult = SafeArrayGetUBound(*ppsa, 1, &lUBound[0]);

            for (LONG i = lLBound[0]; i <= lUBound[0]; ++i)
            {
                hResult = SafeArrayGetLBound(*ppsa, 2, &lLBound[1]);
                hResult = SafeArrayGetUBound(*ppsa, 2, &lUBound[1]);

                lIndex[0] = i;

                for (LONG j = lLBound[1]; j <= lUBound[1]; ++j)
                {
                    lIndex[1] = j;

                    int iValue;
                    hResult = SafeArrayGetElement(*ppsa, lIndex, &iValue);

                    ss << iValue << L"\n";
                }
            }
        }
    }
    else if (vt == VT_BSTR)
    {
        ss << L"データ型：String\n";

        if (uiDims == 1)
        {
            LONG lLBound;
            LONG lUBound;

            hResult = SafeArrayGetLBound(*ppsa, 1, &lLBound);
            hResult = SafeArrayGetUBound(*ppsa, 1, &lUBound);

            for (LONG lIndex = lLBound; lIndex <= lUBound; ++lIndex)
            {
                BSTR bstr;

                SafeArrayGetElement(*ppsa, &lIndex, &bstr);

                ss << convMbcBstr2Wstr(bstr) << L"\n";

                SysFreeString(bstr);
            }
        }
    }
    else if (vt == VT_VARIANT)
    {
        ss << L"データ型：Variant\n";

        if (uiDims == 1)
        {
            LONG lLBound;
            LONG lUBound;

            hResult = SafeArrayGetLBound(*ppsa, 1, &lLBound);
            hResult = SafeArrayGetUBound(*ppsa, 1, &lUBound);

            for (LONG lIndex = lLBound; lIndex <= lUBound; ++lIndex)
            {
                VARIANT vValue;
                VariantInit(&vValue);
                hResult = SafeArrayGetElement(*ppsa, &lIndex, &vValue);

                switch (vValue.vt)
                {
                case VT_I4:
                    ss << std::to_wstring(vValue.intVal) << L"\n";
                    break;
                case VT_R8:
                    ss << std::to_wstring(vValue.dblVal) << L"\n";
                    break;
                case VT_BSTR:
                    ss << vValue.bstrVal << L"\n";
                    break;
                case VT_BSTR | VT_BYREF:
                    ss << vValue.pbstrVal << L"\n";
                    break;
                default:
                    break;
                } ;

                VariantClear(&vValue);
            }
        }

    }
    else
    {
        MessageBox(NULL, L"No Data Type matched.", L"SetArrayGE", MB_OK | MB_ICONINFORMATION);

        return;
    }

    MessageBox(NULL, ss.str().c_str(), L"SetArrayGE", MB_OK | MB_ICONINFORMATION);

    return;
}

ACCESSIBLEFROMVBA_API void WINAPI SetArrayAD(const LPSAFEARRAY* ppsa)
{
    //格納されているデータ型の確認
    VARTYPE vt;
    HRESULT hResult = SafeArrayGetVartype(*ppsa, &vt);

    if (FAILED(hResult))
    {
        //VARIANTに格納できない（？）データの配列の場合、この判定ではNG
        return;
    }

    //次元数
    UINT uiDims = SafeArrayGetDim(*ppsa);

    std::wstringstream ss;

    for (UINT i = 1; i <= uiDims; ++i)
    {
        LONG lLBound, lUBound;
        hResult = SafeArrayGetLBound(*ppsa, i, &lLBound);
        hResult = SafeArrayGetUBound(*ppsa, i, &lUBound);

        ss << i << L"次元\n"
            << L"　LBound：" << lLBound << L"\n"
            << L"　UBound：" << lUBound << L"\n";
    }

    if (vt == VT_I4)
    {
        ss << L"データ型：Long\n";

        //全要素数
        ULONG ulElems(1);
        for (ULONG i = 0; i < uiDims; ++i)
        {
            ulElems *= (*ppsa)->rgsabound[i].cElements;
        }

        int* piValue(0);

        hResult = SafeArrayAccessData(*ppsa, (void**)&piValue);

        for (ULONG i = 0; i < ulElems; ++i)
        {
            ss << L"0x" << std::setfill(L'0') << std::right << std::setw(8) << std::hex << *piValue << L"\n";

            ++piValue;
        }

        hResult = SafeArrayUnaccessData(*ppsa);
    }
    else if (vt == VT_BSTR)
    {
        ss << L"データ型：String\n";

        BSTR* pbstr(0);

        hResult = SafeArrayAccessData(*ppsa, (void**)&pbstr);

        std::wstring ws = convMbcBstr2Wstr(*pbstr);

        for (ULONG i = 0; i < (*ppsa)->rgsabound[0].cElements; ++i)
        {
            ws = convMbcBstr2Wstr(*pbstr);
            ss << ws << L"\n";

            ++pbstr;
        }

        hResult = SafeArrayUnaccessData(*ppsa);
    }
    else if (vt == VT_VARIANT)
    {
        ss << L"データ型：Variant\n";

        VARIANT* pv(0);
        
        hResult = SafeArrayAccessData(*ppsa, (void**)&pv);

        for (ULONG i = 0; i < (*ppsa)->rgsabound[0].cElements; ++i)
        {
            switch (pv->vt)
            {
            case VT_I4:
                ss << std::to_wstring(pv->intVal) << L"\n";
                break;
            case VT_R8:
                ss << std::to_wstring(pv->dblVal) << L"\n";
                break;
            case VT_BSTR:
                ss << convVstr2Wstr(*pv) << L"\n";
                break;
            default:
                break;
            }

            ++pv;
        }

        hResult = SafeArrayUnaccessData(*ppsa);
    }
    else
    {
        MessageBox(NULL, L"No Data Type matched.", L"SetArrayAD", MB_OK | MB_ICONINFORMATION);

        return;
    }

    MessageBox(NULL, ss.str().c_str(), L"SetArrayAD", MB_OK | MB_ICONINFORMATION);

    return;
}

DLLで配列を更新して返す処理

▶クリックで展開

• PE：SafeArrayPutElementを使用して書き換える処理
• AD：SafeArrayAccessDataで取得したポインタを使用して書き換える処理

ACCESSIBLEFROMVBA_API void WINAPI GetArrayPE(LPSAFEARRAY* ppsa)
{
    //格納されているデータ型の確認
    VARTYPE vt;
    HRESULT hResult = SafeArrayGetVartype(*ppsa, &vt);

    if (FAILED(hResult))
    {
        //VARIANTに格納できない（？）データの配列の場合、この判定ではNG
        return;
    }

    //次元数
    UINT uiDims = SafeArrayGetDim(*ppsa);

    LONG* plLBound = new LONG[uiDims];
    LONG* plUBound = new LONG[uiDims];

    for (UINT i = 0; i < uiDims; ++i)
    {
        SafeArrayGetLBound(*ppsa, i + 1, &plLBound[i]);
        SafeArrayGetUBound(*ppsa, i + 1, &plUBound[i]);
    }

    if (vt == VT_I4)
    {
        if (uiDims == 2)
        {
            LONG* plIndex = new LONG[uiDims];

            for (LONG i = plLBound[0]; i <= plUBound[0]; ++i)
            {
                plIndex[0] = i;

                for (LONG j = plLBound[1]; j <= plUBound[1]; ++j)
                {
                    plIndex[1] = j;

                    long lValue;
                    SafeArrayGetElement(*ppsa, plIndex, &lValue);
                    lValue *= 2;
                    SafeArrayPutElement(*ppsa, plIndex, &lValue);
                }
            }
        }
    }
    else if (vt == VT_R8)
    {
        if (uiDims == 1)
        {
            LONG lIndex;

            for (LONG i = plLBound[0]; i <= plUBound[0]; ++i)
            {
                lIndex = i;

                double dValue;
                SafeArrayGetElement(*ppsa, &lIndex, &dValue);
                dValue /= 2.0;
                SafeArrayPutElement(*ppsa, &lIndex, &dValue);
            }
        }
    }
    else if (vt == VT_VARIANT)
    {
        if (uiDims == 1)
        {
            LONG lIndex;

            for (LONG i = plLBound[0]; i <= plUBound[0]; ++i)
            {
                VARIANT vOrg;
                VariantInit(&vOrg);

                lIndex = i;
                SafeArrayGetElement(*ppsa, &lIndex, &vOrg);

                VARIANT vOut;
                VariantInit(&vOut);
                if (vOrg.vt == VT_EMPTY)
                {
                    vOut.vt = VT_BSTR;
                }
                else
                {
                    vOut.vt = vOrg.vt;
                }

                switch (vOrg.vt)
                {
                case VT_I4:
                    vOut.intVal = vOrg.intVal * 2;
                    SafeArrayPutElement(*ppsa, &lIndex, &vOut);
                    break;
                case VT_R8:
                    vOut.dblVal = vOrg.dblVal / 2.0;
                    SafeArrayPutElement(*ppsa, &lIndex, &vOut);
                    break;
                case VT_BSTR:
                {
                    std::wstring ws = L"GetArrayPE";
                    ws += std::to_wstring(lIndex);
                    SysReAllocString(&vOut.bstrVal, ws.c_str());
                    SafeArrayPutElement(*ppsa, &lIndex, &vOut);
                    SysFreeString(vOut.bstrVal);
                }
                    break;
                default:
                    break;
                }

                VariantClear(&vOrg);
                VariantClear(&vOut);
            }
        }
    }
    else if (vt == VT_BSTR)
    {
        if (uiDims == 1)
        {
            LONG lIndex;

            for (LONG i = plLBound[0]; i <= plUBound[0]; ++i)
            {
                lIndex = i;

                std::string sReturn = "GetArrayPE:";
                sReturn += std::to_string(i + 1);
                size_t lenByte = sReturn.length();

                BSTR bstr = SysAllocStringByteLen(sReturn.c_str(), lenByte);
                //&bstrではないので注意！！！(& は不要)
                SafeArrayPutElement(*ppsa, &lIndex, bstr);

                SysFreeString(bstr);
            }
        }
    }
    
    delete[] plLBound;
    delete[] plUBound;

    return;
}

ACCESSIBLEFROMVBA_API void WINAPI GetArrayAD(LPSAFEARRAY* ppsa)
{
    //格納されているデータ型の確認
    VARTYPE vt;
    HRESULT hResult = SafeArrayGetVartype(*ppsa, &vt);

    if (FAILED(hResult))
    {
        //VARIANTに格納できない（？）データの配列の場合、この判定ではNG
        return;
    }

    //次元数
    UINT uiDims = SafeArrayGetDim(*ppsa);

    //全要素数
    ULONG ulElems(1);
    for (ULONG i = 0; i < uiDims; ++i)
    {
        ulElems *= (*ppsa)->rgsabound[i].cElements;
    }

    if (vt == VT_I4)
    {
        int* piValue;
        SafeArrayAccessData(*ppsa, (void**)&piValue);
        for (ULONG i = 0; i < ulElems; ++i)
        {
            *piValue *= 3;

            ++piValue;
        }
        SafeArrayUnaccessData(*ppsa);
    }
    else if (vt == VT_BSTR)
    {
        BSTR* pbstr;
        SafeArrayAccessData(*ppsa, (void**)&pbstr);
        for (ULONG i = 0; i < ulElems; ++i)
        {
            std::string ws("GetArrayAD");
            ws += std::to_string(i);
            UINT lenByte = ws.length();

            SysFreeString(*pbstr);
            *pbstr = SysAllocStringByteLen(ws.c_str(), lenByte);

            ++pbstr;
        }
        SafeArrayUnaccessData(*ppsa);
    }
    else if (vt == VT_VARIANT)
    {
        VARIANT* pv;
        SafeArrayAccessData(*ppsa, (void**)&pv);
        for (ULONG i = 0; i < ulElems; ++i)
        {
            switch (pv->vt)
            {
            case VT_I4:
                pv->intVal *= 4;
                break;
            case VT_EMPTY:
            {
                std::wstring ws(L"GetArrayAD_EMPTY");
                ws += std::to_wstring(i);
                pv->vt = VT_BSTR;
                pv->bstrVal = SysAllocString(ws.c_str());
            }
                break;
            case VT_BSTR:
            {
                std::wstring ws(L"GetArrayAD_BSTR");
                ws += std::to_wstring(i);
                SysReAllocString(&(pv->bstrVal), ws.c_str());
            }
                break;
            default:
                break;
            }

            ++pv;
        }
        SafeArrayUnaccessData(*ppsa);
    }

    return;
}

文字列変換処理

▶クリックで展開

std::wstring    convMbc2Wstr(const char* lpcszSrc)
{
    if (!lpcszSrc)
    {
        return std::wstring(L"");
    }

    //必要なバッファサイズ取得

    /*
    cbMultiByte（第４引数）
    lpMultiByteStrパラメーターで示される文字列のサイズ（バイト単位）。 
    または、文字列がヌルで終了する場合、このパラメーターを-1に設定できます。 
    cbMultiByteが0の場合、関数は失敗することに注意してください。
    
    このパラメーターが-1の場合、関数は終端のヌル文字を含む入力文字列全体を処理します。 
    したがって、結果のUnicode文字列には終端のヌル文字が含まれ、
    関数によって返される長さにはこの文字が含まれます。

    このパラメーターが正の整数に設定されている場合、
    関数は指定されたバイト数を正確に処理します。 
    指定されたサイズに終端のヌル文字が含まれていない場合、
    結果のUnicode文字列はヌル終端されず、
    返される長さにはこの文字は含まれません。 
    */
    int iNeedBufferElems = MultiByteToWideChar(CP_ACP, 0, lpcszSrc, -1, nullptr, 0);

    wchar_t* pwsz = new wchar_t[iNeedBufferElems];

    int iResult = MultiByteToWideChar(CP_ACP, 0, lpcszSrc, -1, pwsz, iNeedBufferElems);

    std::wstring ws(pwsz);

    delete[] pwsz;

    return ws;
}

std::wstring    convMbcBstr2Wstr(const BSTR& bstr)
{
    return convMbc2Wstr((const char*)bstr);
}

AccessibleFromVBA.def

▶クリックで展開

LIBRARY AccessibleFromVba

EXPORTS
    DoNothing
    GetNumberI
    GetNumberI2
    SetString
    SetStringS
    GetStringByParam
    GetStringByParamS
    GetStringByRetVal
    GetStringByRetValS
    SetArrayGE
    SetArrayAD
    GetArrayPE
    GetArrayAD

VBA

▶クリックで展開

Private Declare Sub getArrayPEL Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\AccessibleFromVBA\Debug\AccessibleFromVBA.dll" Alias "GetArrayPE" (ByRef lArray() As Long)
Private Declare Sub getArrayPES Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\AccessibleFromVBA\Debug\AccessibleFromVBA.dll" Alias "GetArrayPE" (ByRef sArray() As String)
Private Declare Sub getArrayPEV Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\AccessibleFromVBA\Debug\AccessibleFromVBA.dll" Alias "GetArrayPE" (ByRef vArray() As Variant)

Private Declare Sub getArrayADL Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\AccessibleFromVBA\Debug\AccessibleFromVBA.dll" Alias "GetArrayAD" (ByRef lArray() As Long)
Private Declare Sub getArrayADS Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\AccessibleFromVBA\Debug\AccessibleFromVBA.dll" Alias "GetArrayAD" (ByRef sArray() As String)
Private Declare Sub getArrayADV Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\AccessibleFromVBA\Debug\AccessibleFromVBA.dll" Alias "GetArrayAD" (ByRef vArray() As Variant)



Private Declare Sub setArrayGEL Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\AccessibleFromVBA\Debug\AccessibleFromVBA.dll" Alias "SetArrayGE" (ByRef lArray() As Long)
Private Declare Sub setArrayGES Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\AccessibleFromVBA\Debug\AccessibleFromVBA.dll" Alias "SetArrayGE" (ByRef sArray() As String)
Private Declare Sub setArrayGED Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\AccessibleFromVBA\Debug\AccessibleFromVBA.dll" Alias "SetArrayGE" (ByRef dArray() As Double)
Private Declare Sub setArrayGEV Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\AccessibleFromVBA\Debug\AccessibleFromVBA.dll" Alias "SetArrayGE" (ByRef vArray() As Variant)

Private Declare Sub setArrayADL Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\AccessibleFromVBA\Debug\AccessibleFromVBA.dll" Alias "SetArrayAD" (ByRef lArray() As Long)
Private Declare Sub setArrayADS Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\AccessibleFromVBA\Debug\AccessibleFromVBA.dll" Alias "SetArrayAD" (ByRef sArray() As String)
Private Declare Sub setArrayADD Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\AccessibleFromVBA\Debug\AccessibleFromVBA.dll" Alias "SetArrayAD" (ByRef dArray() As Double)
Private Declare Sub setArrayADV Lib "C:\Datas\MyDatas\Developer\VisualStudioComunity2017\DllForVBA\AccessibleFromVBA\Debug\AccessibleFromVBA.dll" Alias "SetArrayAD" (ByRef vArray() As Variant)

Public Sub getArrayADTest()

    Dim lArray(2 To 5, 3 To 4)  As Long
    Dim sArray(2 To 6)   As String
    Dim vArray(3)   As Variant
    Dim i           As Long
    Dim j           As Long

    For i = LBound(lArray, 1) To UBound(lArray, 1)
        For j = LBound(lArray, 2) To UBound(lArray, 2)
            lArray(i, j) = i * &H10 + j
            Debug.Print i, j, "0x" & Hex(lArray(i, j))
        Next j
    Next i

    Debug.Print ""

    Call getArrayADL(lArray)

    For i = LBound(lArray, 1) To UBound(lArray, 1)
        For j = LBound(lArray, 2) To UBound(lArray, 2)
            Debug.Print i, j, "0x" & Hex(lArray(i, j))
        Next j
    Next i

    Debug.Print ""

    Call getArrayADS(sArray)

    For i = LBound(sArray) To UBound(sArray)
        Debug.Print sArray(i)
    Next i

    Debug.Print ""

    vArray(0) = ""
    vArray(1) = 1&

    Call getArrayADV(vArray)

    For i = LBound(vArray) To UBound(vArray)
        Debug.Print vArray(i)
    Next i

End Sub

Public Sub getArrayPETest()

    Dim lArray(2 To 5, 3 To 4)  As Long
    Dim sArray(4)   As String
    Dim vArray(3)   As Variant
    Dim i           As Long
    Dim j           As Long

    For i = LBound(lArray, 1) To UBound(lArray, 1)
        For j = LBound(lArray, 2) To UBound(lArray, 2)
            lArray(i, j) = i * 100 + j
        Next j
    Next i

    Call getArrayPEL(lArray)

    For i = LBound(lArray, 1) To UBound(lArray, 1)
        For j = LBound(lArray, 2) To UBound(lArray, 2)
            Debug.Print i, j, lArray(i, j)
        Next j
    Next i

    Call getArrayPEV(vArray)

    For i = LBound(vArray) To UBound(vArray)
        Debug.Print vArray(i)
    Next i


    Call getArrayPES(sArray)

    For i = LBound(sArray) To UBound(sArray)
        Debug.Print sArray(i)
    Next i

End Sub


Public Sub setArrayTest()

    Dim lArray(3 To 8, 1 To 3) As Long
    Dim sArray(2 To 5)  As String
    Dim dArray(4 To 5)  As Double
    Dim vArray(5 To 8)  As Variant
    Dim i           As Long
    Dim j           As Long

    For i = LBound(lArray, 1) To UBound(lArray, 1)
        For j = LBound(lArray, 2) To UBound(lArray, 2)
            lArray(i, j) = i * &H1000 + j * &H10
        Next j
    Next i

    For i = LBound(sArray) To UBound(sArray)
        sArray(i) = String(i, CStr(i))
    Next i

    For i = LBound(dArray) To UBound(dArray)
        If i <> 0 Then
            dArray(i) = 100 / i
        Else
            dArray(i) = -1
        End If
    Next i

    vArray(8) = 0.2
    vArray(6) = &H1000&
    vArray(7) = "VariantArray"
    vArray(5) = 16

    Call setArrayGEV(vArray)
    Call setArrayGED(dArray)
    Call setArrayGES(sArray)
    Call setArrayGEL(lArray)

    Call setArrayADV(vArray)
    Call setArrayADD(dArray)
    Call setArrayADS(sArray)
    Call setArrayADL(lArray)

End Sub

実行結果

getArrayPETest

 2             3             406 
 2             4             408 
 3             3             606 
 3             4             608 
 4             3             806 
 4             4             808 
 5             3             1006 
 5             4             1008 

GetArrayPE:1
GetArrayPE:2
GetArrayPE:3
GetArrayPE:4
GetArrayPE:5

getArrayADTest

 2             3            0x23
 2             4            0x24
 3             3            0x33
 3             4            0x34
 4             3            0x43
 4             4            0x44
 5             3            0x53
 5             4            0x54

 2             3            0x69
 2             4            0x6C
 3             3            0x99
 3             4            0x9C
 4             3            0xC9
 4             4            0xCC
 5             3            0xF9
 5             4            0xFC

GetArrayAD0
GetArrayAD1
GetArrayAD2
GetArrayAD3
GetArrayAD4

GetArrayAD_BSTR0
 4 
GetArrayAD_EMPTY2
GetArrayAD_EMPTY3

setArrayADTest

SetArrayGE

SetArrayAD

次回予告

次回は、Variant型の非配列変数に、配列を格納して、DLLと受け渡しをする予定です。

過去掲載分

z1000s.hatenablog.com
z1000s.hatenablog.com
z1000s.hatenablog.com
z1000s.hatenablog.com
z1000s.hatenablog.com
z1000s.hatenablog.com
z1000s.hatenablog.com