PowerShellで画面を作成（画面から詳細画面を呼び出す）

Visual Studioみたいな開発環境をインストールできない環境でアプリを作りたい・・・

　色々と考えた結果「HTA」を使ってHTML＋JavaScriptでアプリを作ることにして、テキストエディタで頑張って作ったけど、やっぱり使い勝手が悪いのとデザインとかに凝るのがなかなか大変なのでWindowsフォームみたいな画面を作れないかいろいろと調べていた。

※デバッグできないのがつらい・・・。

　PowerShellでWindowsフォームを作れるところに行きついたけど、なかなか手が出せなかった。※HTAで十分事足りていたってのもあるけど

　ただ、HTAで作ったアプリに改修が入ったのでこの際に作り直そうと頑張った。

色々と調べると別にPowerShellなら外部ファイルも作れるし、別画面も作れるのがわかったのでサンプルを作った。

今のところ気を付けないといけなかったのは下記の二点

　１．ファイル内に関数は先に定義しておかないと画面から呼び出せない。

　　　関数の定義前に呼び出すと未定義関数ってエラーが出る

　　　※いつの時代のスクリプト言語なんだろう・・・

　２．外部ファイルを読み込むときには変数名や関数名を同じにしない

　　　※イメージ的には複数のファイルを一つにまとめてから実行している？？

２．に気づくまでは$FormDetailを$Formと定義していたせいで全然動かせんかった

作成物

　・Main.ps1　・・・大本のファイル。共通変数などはここに定義

　・frmMain.ps1　・・・　初期画面を定義

　・frmDetail.ps1　・・・　初期画面を定義

Main.ps1

　$CurrentDir  = Split-Path $MyInvocation.MyCommand.path

　$ScriptName = $MyInvocation.MyCommand.path

　$Basename    = $MyInvocation.MyCommand.Name

　# 外部ファイルを読み込み

　$Path = $CurrentDir + "\frmMain.ps1" 

　.$Path

　# frmMain.ps1に定義されている画面呼び出しを呼び出す

　OpenMainForm

frmMain.ps1

  #アセンブリの読み込み

  [void] [System.Reflection.Assembly]::LoadWithPartialName("System.Drawing")

  [void] [System.Reflection.Assembly]::LoadWithPartialName("System.Windows.Forms")

  

  # デバッグ用（Main.ps1で定義済）

  # $CurrentDir  = Split-Path $MyInvocation.MyCommand.path

  # $ScriptName = $MyInvocation.MyCommand.path

  # $Basename    = $MyInvocation.MyCommand.Name

  

  $Path = $CurrentDir + "\frmDetail.ps1" 

  .$Path

  

  

  #フォームの設定

  $Form = New-Object System.Windows.Forms.Form

  $Form.Size = New-Object System.Drawing.Size(800,600)

  $Form.Text = "メイン画面"

  

  

  

  #ボタンの設定

  $btnShowSubForm = New-Object System.Windows.Forms.Button

  $btnShowSubForm.Location = New-Object System.Drawing.Point(100,50)

  $btnShowSubForm.Size = New-Object System.Drawing.Size(200,100)

  $btnShowSubForm.Text = "詳細画面表示"

  $btnShowSubForm.Add_Click({

      OpenDetailForm("メイン画面から呼び出し引数")

  })

  

  $Form.Controls.Add($btnShowSubForm)

  

  #フォームの表示

  $Form.Add_Shown({$Form.Activate()})

  

  function OpenMainForm {

      [void] $Form.ShowDialog()

  }

frmDetail.ps1

  #アセンブリの読み込み

  [void] [System.Reflection.Assembly]::LoadWithPartialName("System.Drawing")

  [void] [System.Reflection.Assembly]::LoadWithPartialName("System.Windows.Forms")

   

  #フォームの設定

  $FormDetail = New-Object System.Windows.Forms.Form

  $FormDetail.Size = New-Object System.Drawing.Size(800,600)

  $FormDetail.Text = "詳細画面"

   

  #ボタンの設定

  $btnShowSubForm = New-Object System.Windows.Forms.Button

  $btnShowSubForm.Location = New-Object System.Drawing.Point(10,50)

  $btnShowSubForm.Size = New-Object System.Drawing.Size(100,70)

  $btnShowSubForm.Text = "画面を閉じる"

  $FormDetail.Controls.Add($btnShowSubForm)

  

  #テキストボックスの設定

  $txtHikisu = New-Object System.Windows.Forms.TextBox

  $txtHikisu.Location = New-Object System.Drawing.Point(130,50)

  $txtHikisu.Size = New-Object System.Drawing.Size(200,100)

  $txtHikisu.Text = ""

  $FormDetail.Controls.Add($txtHikisu)

  

  

  #フォームの表示

  $FormDetail.Add_Shown({$FormDetail.Activate()})

  

  function OpenDetailForm {

      [void] $FormDetail.Show()

  }

  

  function OpenDetailForm([String]$strKey) {

      $txtHikisu.Text=$strKey

      $FormDetail.Show()

  }

-------------

  

VBAでCSVを分割する（カンマ、改行対応）

 カンマ、改行を含むCSVファイルを取り込む処理を作ろうかと思っていたら、有名なアドオンRelaxTools Addinの作者の方がGitHubにすでに公開してくれていた。
ただ、自分の実力ではインターフェースの実装などで読み切れないところがあったので最小単位に分割してCSV分割機能だけを分離した。勉強のためにいったん載せておく。
なお、StringBuilderクラスについては、別のサイトから転記した
転記元：https://github.com/RelaxTools/Hidennotare/tree/master/src
　　　　http://dev-clips.com/clip/vba/stringbuilder-for-vba/

呼び出し元（モジュール）

********************

Public Sub CsvParser_Sample()
    Dim strBuf As String
    Dim Row As Collection
    Dim Col As Collection
    Dim v As Variant
    strBuf = "1, Watanabe, Fukushima, 36, ""カンマがあっても,OK""" & vbCrLf & "2, satoh, chiba, 24, ""改行があっても" & vbLf & "OKやで"""
    Dim IC As Object
    Set IC = New CharCursor
    
    Set Row = CsvParser(strBuf, True)
    For Each Col In Row
        For Each v In Col
            Debug.Print v
        Next
    Next
End Sub

'--------------------------------------------------------------
' CSVパーサー RFC4180準拠
' コーテーションの有無, デリミタ指定あり
'--------------------------------------------------------------
Public Function CsvParser(ByVal strBuf As String, Optional ByVal Quatation As Boolean = False, Optional ByVal Delimiter As String = ",") As Collection
    Const C_QUAT As String = """"
    Dim IC As CharCursor
    Dim sw As Boolean
    Dim blnLineBreak As Boolean
    Dim blnItemBreak As Boolean
    Dim Col As Collection
    Dim Row As Collection
    Dim lngQuot As Long
    lngQuot = 0
    sw = False
    Set Row = New Collection
    Set IC = New CharCursor
    Call IC.NewInstance(strBuf)
'
    Do Until IC.Eof
        '初期化
        Set Col = New Collection
        blnLineBreak = False
        Do Until IC.Eof Or blnLineBreak
            '初期化
            Dim SB As StringBuilder
            Set SB = New StringBuilder
            blnItemBreak = False
            Do Until IC.Eof Or blnLineBreak Or blnItemBreak
                Select Case IC.Item
                    Case C_QUAT
                        'コーテーションありの場合
                        If Quatation Then
                            lngQuot = lngQuot + 1
                            If sw Then
                                '次の文字がQuatation
                                If IC.Item(1) = C_QUAT Then
                                    lngQuot = lngQuot + 1
                                    SB.Append C_QUAT
                                    IC.MoveNext
                                Else
                                    sw = False
                                End If
                            Else
                                sw = True
                            End If
                        End If
                    Case vbCr
                        If sw Then
                            SB.Append IC.Item
                        End If
                    Case vbLf
                        If sw Then
                            SB.Append IC.Item
                        Else
                            blnLineBreak = True
                        End If
                    Case Delimiter
                        If sw Then
                            SB.Append IC.Item
                        Else
                            blnItemBreak = True
                        End If
                    Case Else
                        SB.Append IC.Item
                End Select
                IC.MoveNext
            Loop
            '列追加処理
            Col.Add SB.ToString
        Loop
        '行追加処理
        Row.Add Col
    Loop
    'ダブルコーテーションが偶数ではない場合
    If lngQuot Mod 2 <> 0 Then
'        Message.Throw 1, Me, "CsvParser", "Invalid Format(Quotation)"
    End If
    Set CsvParser = Row
    
End Function
********************

CharCursorクラス
********************
Private mBuf As String
Private mIndex As Long
Private Sub Class_Initialize()
    mIndex = 1
End Sub

Public Function NewInstance(ByVal Source As String) As CharCursor
    Dim p As CharCursor
    Set p = New CharCursor
    mBuf = Source
    Set NewInstance = p
    NewInstance.MoveFirst
End Function
Public Function Eof() As Boolean
    Eof = Len(mBuf) < mIndex
End Function
Public Sub MoveFirst()
    mIndex = 1
End Sub
Public Sub MoveNext()
    mIndex = mIndex + 1
End Sub
Public Function Item(Optional ByVal opt As Variant) As Variant
    Dim lngPos As Long
    If IsMissing(opt) Then
        opt = 0
    End If
    lngPos = mIndex + opt
    If lngPos < 1 Or lngPos > Len(mBuf) Then
        Item = ""
    Else
        Item = Mid$(mBuf, lngPos, 1)
    End If
End Function
-------------------------

StringBuilderクラス
-------------------------
'************************************************************************

'*-----------------------------------------------------------------------
'*  Name： StringBuilder (Class Module)
'*-----------------------------------------------------------------------
'*  Descriptioin：StringBuilder for VBA
'*-----------------------------------------------------------------------
'*  Copyright: HAYs  http://dev-clips.com , 2015 All Rights Reserved.
'*-----------------------------------------------------------------------
'*  <Update>
'*  Date        Version     Author     Memo
'*-----------------------------------------------------------------------
'*  2015.11.25  1.00        HAYs       New Release
'************************************************************************
' option
Option Explicit
'************************************************************************
'*  variable
'************************************************************************
Private pCapacity As Long
Private pLength As Long
Private mBuffer As String
'************************************************************************
'*  class event
'************************************************************************
'*-----------------------------------------------------------------------
'*  constructor
'*-----------------------------------------------------------------------
Private Sub Class_Initialize()
    pCapacity = 1023
    Me.Clear
End Sub
'*-----------------------------------------------------------------------
'*  destructor
'*-----------------------------------------------------------------------
Private Sub Class_Terminate()
    'clean up
    mBuffer = vbNullString
End Sub
'************************************************************************
'*  property
'************************************************************************
'*-----------------------------------------------------------------------
'*  Capacity
'*-----------------------------------------------------------------------
Friend Property Let Capacity(ByVal NewValue As Long)
    'ignore smaller NewValue
    If NewValue > pCapacity Then
        're-allocate
        mBuffer = mBuffer & String(NewValue - pCapacity, vbNullChar)
        'save new value
        pCapacity = NewValue
    End If
End Property
Friend Property Get Capacity() As Long
    Capacity = pCapacity
End Property
'*-----------------------------------------------------------------------
'*  Length
'*-----------------------------------------------------------------------
Friend Property Let Length(ByVal NewValue As Long)
    If NewValue < pLength Then
        Mid(mBuffer, NewValue + 1, pLength - NewValue) = _
            String$(pLength - NewValue, vbNullChar)
    End If
    pLength = NewValue
End Property
Friend Property Get Length() As Long
    Length = pLength
End Property

'************************************************************************
'*  method
'************************************************************************
'*-----------------------------------------------------------------------
'*  clear
'*-----------------------------------------------------------------------
Friend Function Clear() As StringBuilder
    'initialize length
    pLength = 0
    'allocate memory
    mBuffer = String$(pCapacity, vbNullChar)
    'return me
    Set Clear = Me
End Function
'*-----------------------------------------------------------------------
'*  append
'*-----------------------------------------------------------------------
Friend Function Append(ByRef StringValue As String) As StringBuilder
    Dim pos As Long
    Dim tmpCap As Long
    'set position
    pos = pLength + 1
    'add new length
    pLength = pLength + Len(StringValue)
    'check overflow
    If pLength > pCapacity Then
        'expand capacity *doubles up
        tmpCap = pCapacity
        Do While tmpCap < pLength
            tmpCap = tmpCap * 2
        Loop
        'save new capacity
        Me.Capacity = tmpCap
    End If
    'append
    Mid(mBuffer, pos) = StringValue
    'retrun me
    Set Append = Me
End Function
'*-----------------------------------------------------------------------
'*  insert
'*-----------------------------------------------------------------------
Friend Function Insert(ByRef StringValue As String, _
                        ByVal position As Long) As StringBuilder
    Dim tmpCap As Long
    Dim tmpLen As Long
    'check position
    Select Case position
        Case 1 To pLength
        Case Is < 1: position = 1
        Case Else
            Set Insert = Append(StringValue)
            Exit Function
    End Select
    'save length
    tmpLen = pLength
    'add new length
    pLength = pLength + Len(StringValue)
    'check overflow
    If pLength > pCapacity Then
        'expand Capacity *doubles up
        tmpCap = pCapacity
        Do While tmpCap < pLength
            tmpCap = tmpCap * 2
        Loop
        'save new capacity
        Me.Capacity = tmpCap
    End If
    'slide
    Mid(mBuffer, position + Len(StringValue) _
        ) = Mid$(mBuffer, position, tmpLen)
    'insert
    Mid(mBuffer, position) = StringValue
    'retrun me
    Set Insert = Me
End Function
'*-----------------------------------------------------------------------
'*  string value
'*-----------------------------------------------------------------------
Friend Function ToString() As String
    ToString = Left$(mBuffer, pLength)
End Function
********************

CSVデータをExcelファイルに取り込んで数式を設定するマクロ

 sqlite3のバッチで出力したCSVファイルを取り込んで、数式を設定し、一覧を作成するマクロを作成した。データも項目も適当・・・

・設定シート

・CSVデータ

・結果一覧

※設定シートの注文数×200を送金額という数式を設定してあって、数式を貼り付けているので結果一覧は計算された結果になっている
ソース
----------------------------------------------------------------------------

'最大で300項目まで処理
Private Const FINT_MAX_COL_COUNT As Integer = 300
Private Const FINT_CSV_DATA_STA_COLUMN As Integer = 3
Private Const FINT_CSV_DATA_STA_ROW As Integer = 4
Private Const FINT_TITLE_STA_COLUMN As Integer = 3
Private Const FINT_TITLE_STA_ROW As Integer = 5
Private Const FINT_DATA_STA_COLUMN As Integer = 3
Private Const FINT_DATA_STA_ROW As Integer = 6

Public Sub test()
    Application.ScreenUpdating = False
    
    Dim iMaxColumn As Integer
    iMaxColumn = GetMaxColumnCount(Sheet1.Name, FINT_TITLE_STA_ROW, FINT_TITLE_STA_COLUMN)
    Dim rdCsv As ADODB.Recordset
    Set rdCsv = New ADODB.Recordset
    'データ取り込み処理
    Call GetCsvData(rdCsv)
    Dim intColCount As Integer
    Dim iColTmp As Integer
    Dim rdResult As ADODB.Recordset
    Set rdResult = New ADODB.Recordset
    
    intColCount = iMaxColumn - FINT_TITLE_STA_COLUMN + 1
    ReDim strCsvDataColumnName(intColCount) As String
    ReDim strTitleDataColumnName(intColCount) As String
    For iColTmp = 0 To intColCount - 1
        strCsvDataColumnName(iColTmp) = ThisWorkbook.Sheets(Sheet1.Name).Cells(FINT_CSV_DATA_STA_ROW, FINT_CSV_DATA_STA_COLUMN + iColTmp)
        strTitleDataColumnName(iColTmp) = ThisWorkbook.Sheets(Sheet1.Name).Cells(FINT_TITLE_STA_ROW, FINT_TITLE_STA_COLUMN + iColTmp)
        rdResult.Fields.Append strTitleDataColumnName(iColTmp), adBSTR
    Next
    
    
    Dim iRowCnt As Long
    iRowCnt = 0
    rdResult.Open
    Do Until rdCsv.Eof
        rdResult.AddNew
        For iColTmp = 0 To intColCount - 1
            If strCsvDataColumnName(iColTmp) <> "" Then
                rdResult.Fields(strTitleDataColumnName(iColTmp)) = rdCsv.Fields(strCsvDataColumnName(iColTmp))
            Else
                rdResult.Fields(strTitleDataColumnName(iColTmp)) = ""
            End If
        Next
        rdResult.Update
        rdCsv.MoveNext
    Loop
    
    'データを削除する
    ThisWorkbook.Sheets(Sheet2.Name).Rows("1:100000").Delete
    'データを書き出す
    rdResult.MoveFirst
'    見出しは後で貼り付ける
'    For iColTmp = 1 To rdResult.Fields.Count
'        ThisWorkbook.Sheets(Sheet2.Name).Cells(1, iColTmp) = rdResult.Fields(iColTmp - 1).Name
'    Next
    ThisWorkbook.Sheets(Sheet2.Name).Range("A2").CopyFromRecordset rdResult
    
    Dim strRange As String
    Dim strRangeSta As String
    
    'タイトルを貼り付ける
    strRangeSta = Replace(Replace(ThisWorkbook.Sheets(Sheet1.Name).Cells(FINT_TITLE_STA_ROW, FINT_TITLE_STA_COLUMN).Address, "$" & FINT_TITLE_STA_ROW, ""), "$", "")
    strRange = Replace(Replace(ThisWorkbook.Sheets(Sheet1.Name).Cells(FINT_TITLE_STA_ROW, iMaxColumn).Address, "$" & FINT_TITLE_STA_ROW, ""), "$", "")
    ThisWorkbook.Sheets(Sheet1.Name).Range(strRangeSta & FINT_TITLE_STA_ROW & ":" & strRange & FINT_TITLE_STA_ROW).Copy
    ThisWorkbook.Sheets(Sheet2.Name).Select
    ThisWorkbook.Sheets(Sheet2.Name).Range("A1").Select
    ActiveSheet.Paste
    
    'データの書式を貼り付ける
    ThisWorkbook.Sheets(Sheet1.Name).Select
    ThisWorkbook.Sheets(Sheet1.Name).Range(strRangeSta & FINT_DATA_STA_ROW & ":" & strRange & FINT_DATA_STA_ROW).Copy
    strRange = Replace(Replace(ThisWorkbook.Sheets(Sheet2.Name).Cells(1, intColCount).Address, "$1", ""), "$", "")
    ThisWorkbook.Sheets(Sheet2.Name).Select
    ThisWorkbook.Sheets(Sheet2.Name).Range("A2:" & strRange & CLng(rdResult.RecordCount + 1)).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    '数式を貼り付ける
    For iColTmp = 0 To intColCount - 1
        If strCsvDataColumnName(iColTmp) = "" Then
            strRange = Replace(Replace(ThisWorkbook.Sheets(Sheet2.Name).Cells(1, iColTmp + 1).Address, "$1", ""), "$", "")
            
            ThisWorkbook.Sheets(Sheet1.Name).Cells(FINT_DATA_STA_ROW, FINT_DATA_STA_COLUMN + iColTmp).Copy
            ThisWorkbook.Sheets(Sheet2.Name).Select
            ThisWorkbook.Sheets(Sheet2.Name).Range(strRange & "2:" & strRange & CLng(rdResult.RecordCount + 1)).Select
            Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
    
    Next
    Application.ScreenUpdating = True
    
End Sub

'最大の列番号を取得する
Private Function GetMaxColumnCount(ByVal strSheetName As String, ByVal intStaCol As Integer, ByVal intStaRow As Integer) As Integer
    ThisWorkbook.Sheets(strSheetName).Select
    ThisWorkbook.Sheets(strSheetName).Cells(intStaCol, intStaRow).Select
    Selection.End(xlToRight).Select
    GetMaxColumnCount = Selection.Column
End Function

Public Sub GetCsvData(ByRef rdData As ADODB.Recordset)
    Dim varFileName As Variant
    Dim intFree As Integer
    Dim strRec As String
    Dim strSplit() As String
    Dim i As Long, j As Long, k As Long
    Dim lngQuote As Long
    Dim strCell As String
    varFileName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv", _
                                                Title:="CSVファイルの選択")
    If varFileName = False Then
        Exit Sub
    End If
'    intFree = FreeFile '空番号を取得
'    Open varFileName For Input As #intFree 'CSVファィルをオープン
  
    Dim rdReturn As ADODB.Recordset
    Set rdReturn = New ADODB.Recordset
    Dim blnFirst As Boolean
    blnFirst = True
    i = 0
    Dim itemCount As Integer
    
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile varFileName
        
        Do While Not (.EOS)
            strRec = .ReadText(adReadLine)
            i = i + 1
            j = 0
            lngQuote = 0
            itemCount = 0
            strCell = ""
            
            If blnFirst = False Then rdReturn.AddNew
                            
            For k = 1 To Len(strRec)
                Select Case Mid(strRec, k, 1)
                    Case "," '「"」が偶数なら区切り、奇数ならただの文字
                        If lngQuote Mod 2 = 0 Then
                            'Call PutCell(i, j, strCell, lngQuote)
                            If blnFirst = True Then
                                rdReturn.Fields.Append ConvertValue(strCell, lngQuote), adBSTR
                            Else
                                'データを格納
                                rdReturn.Fields(itemCount) = ConvertValue(strCell, lngQuote)
                                itemCount = itemCount + 1
                            End If
                        Else
                            strCell = strCell & Mid(strRec, k, 1)
                        End If
                    Case """" '「"」のカウントをとる
                        lngQuote = lngQuote + 1
                        strCell = strCell & Mid(strRec, k, 1)
                    Case Else
                        strCell = strCell & Mid(strRec, k, 1)
                End Select
            Next
            '最終列の処理
            
            If blnFirst = True Then
                rdReturn.Fields.Append ConvertValue(strCell, lngQuote), adBSTR
                blnFirst = False
                rdReturn.Open
            Else
                'データを格納
                rdReturn.Fields(itemCount) = ConvertValue(strCell, lngQuote)
                itemCount = itemCount + 1
                rdReturn.Update
            End If
            
        Loop
        
        .Close
        
    End With
    
    rdReturn.MoveFirst
    
    'ThisWorkbook.Sheets(Sheet3.Name).Range("A2").CopyFromRecordset rdReturn
    Set rdData = rdReturn
    
End Sub
Function ConvertValue(ByRef strCell As String, ByRef lngQuote As Long) As String
    j = j + 1
    '「""」を「"」で置換
    strCell = Replace(strCell, """""", """")
    '前後の「"」を削除
    If strCell = """" Then
        strCell = ""
    ElseIf Left(strCell, 1) = """" And Right(strCell, 1) = """" Then
        strCell = Mid(strCell, 2, Len(strCell) - 2)
    End If
    ConvertValue = strCell
    strCell = ""
    lngQuote = 0
End Function

VBAからsqlite3.exeを呼び出してdllやODBCを使用せずにsqlite3を利用する

VBAからsqlite3.exeを呼び出してdllやODBCを使用せずにsqlite3を利用する

バッチファイルを実行し、結果ファイルをHTMLのTableタグで出力し、出力した結果を開いてRecodesetへ取り込む。

-------------------------------------------------

Private Const SQLITE_EXE As String = "sqlite3.exe"
Private Const RESULT_FILENAME As String = "Result.xml"
Private Const EXEC_SQL As String = "ExecSQL.sql"
Private Const EXEC_BATCH As String = "ExecBatch.bat"
Private Const DB_PATH As String = "C:\Users\UserName\Desktop\PgUserName\DataBase\開発PJ.prj"
Private Const FOLDER_PATH As String = "C:\Users\UserName\Desktop\PgUserName\"
Private Const CHARSET_UTF8 As String = "UTF-8"
Private Const CHARSET_SJIS As String = "Shift-JIS"
'参照設定：Microsoft ActiveX Data Object Library 2.8
Private Function GetData(ByVal strSql As String, ByRef rdSet As ADODB.Recordset)
 
    'SQLを実行する
    Call ExecuteSqlite3(strSql)
    '出力結果のファイルを取得し、RecordSetに取り込む
    Dim strResultFilePath As String
    strResultFilePath = ThisWorkbook.Path & "\temp\" & RESULT_FILENAME
    Dim buf As String, Target As String, lngRow As Long, lngItem As Long
    Dim blnIsHeader As Boolean
    Dim strRows As Variant, strItems As Variant, j As Long
    Dim strSplitName As String
    
    blnIsHeader = True
    
    Dim rdResult As ADODB.Recordset
    Set rdResult = New ADODB.Recordset
    
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile strResultFilePath
        buf = .ReadText
        .Close
        '<TR>～</TR>で1行
        
        
        buf = Replace(buf, "<TR>", "")
        strRows = Split(buf, "</TR>" & vbLf)
        For lngRow = 0 To UBound(strRows)
            If blnIsHeader = True Then
                strSplitName = "</TH>"
            Else
                strSplitName = "</TD>"
                '行を追加
                rdResult.AddNew
            End If
            
            strItems = Split(strRows(lngRow), strSplitName & vbLf)
            
            Dim strtemp As String
            strtemp = ""
            For lngItem = 0 To UBound(strItems) - 1  '空白行が最後に含まれる
                strtemp = Mid(strItems(lngItem), 5)
                
                If blnIsHeader = True Then
                    rdResult.Fields.Append strtemp, adLongVarWChar, 255, adFldIsNullable
                Else
                    rdResult.Fields(lngItem) = strtemp
                End If
                
            Next
            
            If blnIsHeader = True Then
                blnIsHeader = False
                rdResult.Open
            Else
                rdResult.Update
            End If
        Next
        
    End With
    Set rdSet = rdResult
End Function

Private Sub ExecuteSqlite3(ByVal strSql As String)
    Dim strCommand As String
    Dim strSqlCommand As String
    
    Dim strTempFolderPath As String
    strTempFolderPath = ThisWorkbook.Path & "\temp"
    If Dir(strTempFolderPath, vbDirectory) = "" Then
        MkDir strTempFolderPath
    End If
    
    Dim strSqlite3ExePath As String
    strSqlite3ExePath = ThisWorkbook.Path & "\" & SQLITE_EXE
    
    Dim strResultFilePath As String
    strResultFilePath = "./" & RESULT_FILENAME
    
    Dim strBatchFilePath As String
    strBatchFilePath = strTempFolderPath & "\" & EXEC_BATCH
    
    Dim strExecSqlPath As String
    strExecSqlPath = strTempFolderPath & "\" & EXEC_SQL
    'sqlite3を実行するときのオプションコマンド
    strSqlCommand = ".headers on " & vbCrLf
    strSqlCommand = strSqlCommand & ".mode html " & vbCrLf
    strSqlCommand = strSqlCommand & ".output '" & Replace(strResultFilePath, "\", "/") & "'" & vbCrLf
    
    strSqlCommand = strSqlCommand & strSql & vbCrLf
    
    'sqlite3に渡すコマンドを出力する
    Call TextOutput(strSqlCommand, strExecSqlPath, CHARSET_UTF8, True)
    'バッチ用コマンド
    strCommand = ""
    strCommand = strCommand & strSqlite3ExePath & " " & DB_PATH & " < " & strExecSqlPath
    'sqlite3に渡すコマンドを出力する
    Call TextOutput(strCommand, strBatchFilePath, CHARSET_SJIS)
    Dim wsh As Object
    Dim result As Integer
    
    Set wsh = CreateObject("WScript.Shell")
    
    'バッチファイルを同期実行
    result = wsh.Run(Command:=strBatchFilePath, WaitOnReturn:=True)
    If (result = 0) Then
        Debug.Print ("バッチファイルは正常終了しました。")
    Else
        Debug.Print ("バッチファイルは異常終了しました。")
    End If
    
    '後片付け
    Set wsh = Nothing
    
End Sub
Public Sub TextOutput(ByVal strText As String, ByVal strFilePath As String, ByVal strCharSet As String, Optional ByVal blnNoBOM As Boolean = False)
    Dim i As Integer
     
    'ADODB.Streamオブジェクトを生成
    Dim ado As Object
    Set ado = CreateObject("ADODB.Stream")
     
    'ADODB.Streamで扱う文字コードを設定する
    ado.Charset = strCharSet
     
    'ADODB.Streamを開く
    ado.Open
     
    '開いたADODB.Streamに内容を保管する
    'adWriteLineは改行する時に入れる
     ado.WriteText strText
        ' ---------- ここから ----------
    If blnNoBOM = True And strCharSet = CHARSET_UTF8 Then
    
        With ado
            ' タイプをバイナリにして、先頭の3バイトをスキップ
            .Position = 0
            .Type = 1 ' ADODB.StreamTypeEnum.adTypeBinary ' タイプ変更するにはPosition = 0である必要がある
            .Position = 3
            ' 一時格納用
            Dim p_byteData() As Byte
            p_byteData = .Read
            .Close ' 一旦閉じて
            .Open ' 再度開いて
            .Write p_byteData ' ストリームに書き込む
        End With
    
    End If
     
    'ADODB.Streamに保管されている内容をファイルに保存する
    ado.SaveToFile strFilePath, 2
     
    'ADODB.Streamを閉じる
    ado.Close
   
End Sub

VBAからSqlite3.exeを利用する方法を検討（ODBC・dllを利用せずにVBAからSqlite3を利用する）

VBAでSqlite3を利用する方法としては、何個かネットに上がっているがODBCのインストールができず、dllの利用は汎用性が高いが難易度が高いと思われたので、sqlite3.exeを利用するケースを検討してみた。

下記の流れで何とかなるのではないかと思い、いろいろと検証しているが、現時点で処理ができた分をメモのために記載する。

　・実行するSqlを作成（UTF-8 BOM無しである必要がある）

　　　例）SQL文の内容（最初の３行はsqlite3.exeのオプション）

　　　　　.headers on 

　　　　　.mode html 

　　　　　.output ./result.xml 

 　　　　　SELECT * FROM T_Card;

　・Sqlを呼び出すためのバッチを作成（Shift-JISである必要がある）

　　　　　C:\Users\UserName\Desktop\PgUsrName\sqlite3.exe C:\Users\UserName\Desktop\PgUsrName\DataBase\開発PJ.prj < C:\Users\UserName\Desktop\PgUsrName\ExecSQL.sql

　・出力形式はhtml形式を指定し、出力された結果をVBAでデシリアライズする

　・処理完了後には一時ファイルを削除する（予定）

　・出力されたファイルをRecodesetに読み込む（予定）

---------------------------------　ソース ----------------------

 Private Const SQLITE_EXE As String = "C:\Users\UserName\Desktop\PgUsrName\sqlite3.exe"
Private Const RESULT_FILEPATH As String = "Result.xml"
Private Const EXEC_SQL As String = "ExecSQL.sql"
Private Const EXEC_BATCH As String = "ExecBatch.bat"
Private Const DB_PATH As String = "C:\Users\UserName\Desktop\PgUsrName\DataBase\開発PJ.sqlite3"
Private Const FOLDER_PATH As String = "C:\Users\UserName\Desktop\PgUsrName\"
Private Const CHARSET_UTF8 As String = "UTF-8"
Private Const CHARSET_SJIS As String = "Shift-JIS"

Private Sub Sqlite()
    Dim strCommand As String
    Dim strSqlCommand As String
    Dim strSql As String
    
    '実行するsql
    strSql = strSql & " SELECT * FROM T_Card;"
    'sqlite3を実行するときのオプションコマンド
    strSqlCommand = ".headers on " & vbCrLf
    strSqlCommand = strSqlCommand & ".mode html " & vbCrLf
    strSqlCommand = strSqlCommand & ".output ./result.xml " & vbCrLf
    
    strSqlCommand = strSqlCommand & strSql & vbCrLf
    
    'sqlite3に渡すコマンドを出力する
    Call TextOutput(strSqlCommand, FOLDER_PATH & EXEC_SQL, CHARSET_UTF8, True)
    'バッチ用コマンド
    strCommand = SQLITE_EXE & " " & DB_PATH & " < " & FOLDER_PATH & EXEC_SQL
    'sqlite3に渡すコマンドを出力する
    Call TextOutput(strCommand, FOLDER_PATH & EXEC_BATCH, CHARSET_SJIS)
    Dim wsh As Object
    Dim result As Integer
    Set wsh = CreateObject("WScript.Shell")
    
    'バッチファイルを同期実行
    result = wsh.Run(Command:=FOLDER_PATH & EXEC_BATCH, WaitOnReturn:=True)
    
    If (result = 0) Then
        MsgBox ("バッチファイルは正常終了しました。")
    Else
        MsgBox ("バッチファイルは異常終了しました。")
    End If
    
    '後片付け
    Set wsh = Nothing
    
End Sub
Public Sub TextOutput(ByVal strText As String, ByVal strFilePath As String, ByVal strCharSet As String, Optional ByVal blnNoBOM As Boolean = False)
    Dim i As Integer
     
    'ADODB.Streamオブジェクトを生成
    Dim ado As Object
    Set ado = CreateObject("ADODB.Stream")
     
    'ADODB.Streamで扱う文字コードを設定する
    ado.Charset = strCharSet
     
    'ADODB.Streamを開く
    ado.Open
     
    '開いたADODB.Streamに内容を保管する
    'adWriteLineは改行する時に入れる
     ado.WriteText strText
'    For i = 1 To 5
'        ado.WriteText Cells(i, 1).Value, adWriteLine
'    Next
     
        ' ---------- ここから ----------
    If blnNoBOM = True And strCharSet = CHARSET_UTF8 Then
    
        With ado
            ' タイプをバイナリにして、先頭の3バイトをスキップ
            .Position = 0
            .Type = 1 ' ADODB.StreamTypeEnum.adTypeBinary ' タイプ変更するにはPosition = 0である必要がある
            .Position = 3
            ' 一時格納用
            Dim p_byteData() As Byte
            p_byteData = .Read
            .Close ' 一旦閉じて
            .Open ' 再度開いて
            .Write p_byteData ' ストリームに書き込む
        End With
    
    End If
     
    'ADODB.Streamに保管されている内容をファイルに保存する
    ado.SaveToFile strFilePath, 2
     
    'ADODB.Streamを閉じる
    ado.Close
     
     
End Sub

UiPathでのDataTableの行削除方法

・ UiPathでのデータテーブル　行削除

二つのデータテーブルをループし、データのチェックを行い、条件を満たす行を削除するようなシナリオを考えたときにちょっと躓いたので、サンプルを残しておく。
「データテーブルの結合」アクティビティのほうが効率的なのかなとかいろいろと悩んでしまったが、結局昔から使い古しているほうがやりやすいことに気づいた・・・・。

削除したいデータテーブルの下の行から削除していくのがポイント

【イメージ】

　　主となるCSV（Main.csv）と削除対象リストのCSV（Del.csv）を二重ループ
　　　Mainデータテーブルのループ
　　　　Delデータテーブルのループ
　　　　　　条件判定を行い、行Indexを別データテーブル（Targetテーブル）に退避
　　　　Next　Mainデータテーブル
　　　Next　Mainデータテーブル
　　

　　Targetテーブルの値を降順にして、削除してく
　　※データテーブルの行をループしながら行インデックスで削除していくと、行の番号が都度変わってしまうので正しく削除できない

SQLクライアントツールについて（DMonkeyスクリプト）

SQL クライアントツールについて

　色々なSQLクライアントツールを使ったが、SQL ServerならSQL ManagementStudio、OracleならSQL Developerなどそれぞれの製品特有のクライアントツールが運用上使いやすいのは使うのは当然として、そのほかに総合的に見て使いやすいと思ったツールは「A5:SQL Mk-2」が一番使いやすいと思う。

　DBeaver もフリーのクライアントツールとしては使いやすいと思うが、スクリプトを標準装備しているという点で「A5:SQL Mk-2」が一番使いやすかった。

　「A5:SQL Mk-2」はポータブルモードにすればインストールせずに利用できるので管理者権限がない環境でも利用できるし、Sqlite3も作ることができるのでデータ分析をするときにすごく重宝する。

　複数のCSVファイルを取り込んで、SQLでは実装が難しいものもDMonkeyスクリプトが組めるので最悪はスクリプトで実装することができる。

　DMonkeyはWScriptも利用することができるのでファイルのコピーや移動もすることができる。クラスも作ることができるので汎用性がすごい。

サンプルスクリプト

class Sample {

var fstrTokCD;
var fstrTokName;
var fArrlogs = new Strings();

function GetData(){
var strSQL;
fArrlogs.add(" GetDataを実行")

strSQL = "";
strSQL = strSQL + "SELECT * FROM T_得意先マスタ ";
strSQL = strSQL + "WHERE 得意先CD = '" + fstrTokCD + "'" ;


var conn = application.dbTree.getSelectedDatabaseConnection();
var rs = conn.executeQuery(strSQL); // 結果セット
rs.first();
while (!rs.eof()) {
fstrTokName = rs.getFieldValue("得意先名")
rs.next();
}
rs.close();
fArrlogs.add(" GetDataが完了")
}
}

var samp = new Sample();
samp.GetData();

samp.fArrlogs.saveToFile("C:\\Users\\UserName\\Desktop\\folder\\dg.log")