CSVファイル入出力補助関数
CSVファイルを読み書きする補助関数として、一行分のCSV文字列をカンマで配列に分割するSplitCSV関数と、配列をCSV文字列に結合するJoinCSV関数を作りました。いちおう括り文字と前ゼロを考慮しています。
Option Explicit Const vbDoubleQuote$ = """" Const vbComma$ = "," Private Sub Command1_Click() Dim i As Long Dim arr() As String Dim f As Integer Dim line As String f = FreeFile Open "C:\Documents and Settings\love4beer\デスクトップ\test.csv" For Input As #f Do Until EOF(f) Line Input #f, line Debug.Print "line:" & line arr = SplitCSV(line) For i = LBound(arr) To UBound(arr) Debug.Print i & ":" & arr(i) Next Debug.Print "join:" & JoinCSV(arr) Loop Close #f End Sub Function SplitCSV(line As String) As String() Dim i As Long Dim quoted As Boolean 'ダブルクォートの内側のときTrue/それ以外のときFalse Dim arr() As String quoted = False '区切文字のカンマをバックスペース（CSVファイルに入力できない値）に置換する For i = 1 To Len(line) Select Case Mid$(line, i, 1) Case vbDoubleQuote quoted = Not quoted Case vbComma If Not quoted Then Mid$(line, i, 1) = vbBack End If End Select Next 'バックスペースでSplit arr = Split(line, vbBack) For i = LBound(arr) To UBound(arr) '括り文字を外す(一旦タブに置換して、後でまとめて削除する) If arr(i) Like vbDoubleQuote & "*" & vbDoubleQuote Then Mid$(arr(i), 1, 1) = vbTab Mid$(arr(i), Len(arr(i)), 1) = vbTab End If 'Trim、エスケープを元に戻す、タブを削除する arr(i) = Replace$(Replace$( _ Trim$(arr(i)), _ vbDoubleQuote & vbDoubleQuote, vbDoubleQuote), _ vbTab, vbNullString) Next Let SplitCSV = arr End Function Function JoinCSV(arr() As String) As String Dim i As Long For i = LBound(arr) To UBound(arr) 'ダブルクォートで括る（データ中のダブルクォートをエスケープする） '前ゼロコードにはタブを付加する arr(i) = vbDoubleQuote & _ IIf(IsNumeric(arr(i)) And arr(i) Like "0#*", vbTab, vbNullString) & _ Replace$(arr(i), vbDoubleQuote, vbDoubleQuote & vbDoubleQuote) & _ vbDoubleQuote Next Let JoinCSV = Join(arr, vbComma) End Function
■追記■
SplitCSV関数を、ExcelのCSV解析に準拠させてみました。最初のForループで、括りとエスケープのダブルクォートをvbTabに、区切りのカンマをvbBackに置換し、その後、Replaceでタブを除去して、Splitで配列に分割しています。
Enum FindState FindOpen FindClose FindComma End Enum Function SplitCSV(ByVal line As String) As String() Dim i As Long Dim fs As FindState fs = FindState.FindOpen For i = 1 To Len(line) Select Case fs Case FindState.FindOpen '項目の先頭で括りの開始を探す Select Case Mid$(line, i, 1) Case vbDoubleQuote Mid$(line, i, 1) = vbTab fs = FindState.FindClose Case vbComma '値なしの項目 Mid$(line, i, 1) = vbBack Case Else fs = FindState.FindComma End Select Case FindState.FindClose '括りの内側である場合に限り括りの終了を探す If Mid$(line, i, 1) = vbDoubleQuote Then Mid$(line, i, 1) = vbTab '次の文字をチェックする If Mid$(line, i + 1, 1) = vbDoubleQuote Then 'エスケープされたダブルクォートはスキップする i = i + 1 Else '単独のダブルクォートなので括りの終了 fs = FindState.FindComma End If End If Case FindState.FindComma '括りの内側でない場合に限りカンマを探す If Mid$(line, i, 1) = vbComma Then Mid$(line, i, 1) = vbBack fs = FindState.FindOpen End If End Select Next Let SplitCSV = Split(Replace$(line, vbTab, vbNullString), vbBack) End Function
ListBoxの項目を「上へ」「下へ」
UserFormにListBoxとSpinButtonをポトリペタして以下のコードを貼り付けます。
Option Explicit Private Sub UserForm_Initialize() ListBox1.MultiSelect = fmMultiSelectExtended Dim i As Long For i = 1 To 10 ListBox1.AddItem "hoge:" & i Next End Sub Private Sub SpinButton1_SpinUp() Call UpSelectedItems(ListBox1) End Sub Private Sub SpinButton1_SpinDown() Call DownSelectedItems(ListBox1) End Sub Private Sub UpSelectedItems(l As MSForms.ListBox) Dim i As Long For i = 0 To l.ListCount - 1 Call Swap(l, i, i - 1) Next End Sub Private Sub DownSelectedItems(l As MSForms.ListBox) Dim i As Long For i = l.ListCount - 1 To 0 Step -1 Call Swap(l, i, i + 1) Next End Sub Private Sub Swap(l As MSForms.ListBox, a As Long, b As Long) If a < 0 Or a > l.ListCount - 1 Then Exit Sub If b < 0 Or b > l.ListCount - 1 Then Exit Sub If a = b Then Exit Sub 'Index:a が選択されていて Index:b が選択されていないとき、aとbを入れ替える If l.Selected(a) And Not l.Selected(b) Then Dim v As Variant v = l.List(a) l.RemoveItem a l.AddItem v, b l.Selected(a) = False l.Selected(b) = True End If End Sub
VB6コンパイルスクリプト
まとめてコンパイルするときに使うスクリプト。他の言語でもコマンドラインをアレンジして使える。それとディレクトリサーチのテンプレ。
'----------------------------------------------------------------------- ' VB6コンパイルスクリプト '----------------------------------------------------------------------- ' カレント配下のvbp(VBプロジェクトファイル)を検索して、 ' binフォルダへexeを出力します ' ├vb6.vbs ' ├projectA ┐ ' ├projectB │入力 ' ･･･ │ ' ├projectZ ┘ ' └bin ┐ ' ├A.exe │出力 ' ├B.exe │ ' ･･･ │ ' └Z.exe ┘ '----------------------------------------------------------------------- Option Explicit const vb6exe = "C:\Program Files\Microsoft Visual Studio\VB98\vb6.exe" const vbHide = 0 dim vbp dim outdir dim wsh dim fso dim root dim msg init dive root fini msgbox msg & "コンパイルが完了しました。" WScript.Quit sub init() set wsh = CreateObject("Wscript.Shell") set fso = CreateObject("Scripting.FileSystemObject") set root = fso.GetFolder(fso.GetParentFolderName(Wscript.ScriptFullName)) outdir = fso.BuildPath(root.Path, "bin") if not fso.FolderExists(outdir) then fso.CreateFolder(outdir) end if end sub sub fini() set wsh = Nothing set fso = Nothing set root = Nothing end sub sub dive(p) dim f for each f in p.Files compile f next dim c for each c in p.SubFolders dive c next end sub sub compile(f) 'vbpファイル以外はスキップ if strcomp("vbp", fso.GetExtensionName(f.Name), vbTextCompare) <> 0 then exit sub end if msg = msg & f.Name & vbCrLf vbp = f.Path wsh.Run cmd("""%vb6exe%"" /make ""%vbp%"" -outdir ""%outdir%"""), vbHide, True end sub function cmd(s) 'パラメータを展開する cmd = s with CreateObject("VBScript.RegExp") .Pattern = "%([^%]+)%" .Global = True do while .Test(cmd) dim par for each par in .Execute(cmd) Execute "cmd = Replace(cmd, par, " + par.subMatches(0) + ")" next loop end with end function
fpSpreadでVirtualModeを簡単に使う拡張クラス
スプレッドに表示するデータをデータベースから取得しているとします。セルには複雑めの書式を設定していて、3000件くらい読み込むと、うーーーーーんぱ、くらい待たされます。というときに、うぱっと開くためのfpSpread拡張クラスです。
うぱっと開くにはVirtualModeを使います。VirtualModeは画面に表示しそうな範囲だけを処理対象にすることで高速化しています。デフォルトではQueryDataイベントがこれにあたりますが、1レコード複数行のレイアウトを使っていると、データソースとスプレッドの表示位置を対応付ける計算が微妙にめんどくさいので、カレント1レコードごとにQueryRowイベントを発火させるようにしてみました。
fpSpreadEx.cls
Option Explicit Private WithEvents This As fpSpread Private OraDynaset As OraDynaset Private OnFirst As Boolean Private SpreadFormat As SpreadFormat Public Event QueryRow() '1レコード分のデータ要求イベント Public Event OnFirstQuery() '初回要求時のイベント ' 初期処理 Public Sub Init(Spread As fpSpread, OraDynaset As OraDynaset) Set This = Spread Set OraDynaset = OraDynaset Set SpreadFormat = GetSpreadFormat(This) 'スプレッドから1レコード分のフォーマットを読み込む処理 OnFirst = True This.VirtualMaxRows = OraDynaset.RecordCount * RecordRows This.VirtualRows = 100 * RecordRows This.VirtualOverlap = 0 This.VirtualMode = True End Sub Public Property Get RecordRows() As Long RecordRows = This.ColHeaderRows End Property Public Property Get RecordCols() As Long RecordCols = This.MaxCols End Property Private Function RowToRowPosition(Row As Long) As Long RowToRowPosition = (Row - 1) \ RecordRows + 1 End Function Private Function CurrentTopRow() As Long CurrentTopRow = (OraDynaset.RowPosition - 1) * RecordRows + 1 End Function Private Function CurrentBottomRow() As Long CurrentBottomRow = OraDynaset.RowPosition * RecordRows End Function 'SpreadデフォルトのQueryDataイベント Private Sub This_QueryData(ByVal Row As Long, ByVal RowsNeeded As Long, RowsLoaded As Long, ByVal Direction As Integer, AtTop As Boolean, AtBottom As Boolean) 'Row 'スプレッド先頭Row 'Row + RowsNeeded - 1 'スプレッド末尾Row Dim lngTopRowPosition As Long 'Dynaset先頭RowPosition Dim lngEndRowPosition As Long 'Dynaset末尾RowPosition lngTopRowPosition = RowToRowPosition(Row) lngEndRowPosition = RowToRowPosition(Row + RowsNeeded - 1) With This Call OraDynaset.MoveTo(lngTopRowPosition) Do While Not OraDynaset.EOF If OraDynaset.RowPosition > lngEndRowPosition Then Exit Do End If 'スプレッド書式設定 If OraDynaset.RowPosition = lngTopRowPosition Or _ This.ActiveRow = CurrentTopRow - RecordRows Then Call SetFormat Else Call CopyFormat End If If This.ActiveRow = CurrentTopRow Then Call SetSelectedFormat End If 'RowPositionのデータ要求イベントを発火 RaiseEvent QueryRow OraDynaset.MoveNext Loop If OnFirst Then OnFirst = False '初回要求時のイベントを発火 RaiseEvent OnFirstQuery End If End With RowsLoaded = RowsNeeded AtTop = (Row = 1) AtBottom = OraDynaset.EOF End Sub Private Sub SetFormat() 'Initで読んでおいたSpreadFormat(スプレッドの1レコード分のセルフォーマット)を、 'スプレッドに適用する処理を記載する End Sub Private Sub SetSelectedFormat() '選択行の文字色、背景色の切り替えなどはここで End Sub Private Sub CopyFormat() '1レコード前のセルフォーマットをまるっとコピーする Call This.CopyRowRange(CurrentTopRow - RecordRows, _ CurrentBottomRow - RecordRows, _ CurrentTopRow) End Sub
使い方
拡張クラスのInitでスプレッドとデータセットを紐付けます。
Begin FPSpreadADO.fpSpread Spread Public OraDynaset As OraDynaset Private WithEvents SpreadEx As fpSpreadEx '読み込みボタン押下時の処理 Set OraDynaset = OraDataBase.CreateDynaset(SQL, GC_ORADYN_READONLY) Call SpreadEx.Init(Spread, OraDynaset)
要求1レコードごとにQueryRowイベントが発火するので、ここで、データセットのCurrentをスプレッドのCurrentTopRowへ貼り付けます。
Private Sub SpreadEx_QueryRow() Dim arr() As String ReDim arr(1 To SpreadEx.RecordRows, 0 To SpreadEx.RecordCols) With OraDynaset '行番号 arr(1, 0) = .RowPosition 'データ 1段目 arr(1, 1) = .Fields("COLUMN1").Value arr(1, 2) = .Fields("COLUMN2").Value arr(1, 3) = .Fields("COLUMN3").Value 'データ 2段目 arr(2, 1) = .Fields("COLUMN4").Value arr(2, 2) = .Fields("COLUMN5").Value arr(2, 3) = .Fields("COLUMN6").Value End With Call Spread.SetArray(0, SpreadEx.CurrentTopRow, arr) End Sub
ちなみに、ユーザーが操作した直後の一回だけの処理（例えばSetFocusとかEnabledを切り替えとか）はOnFirstQueryイベントに記述します。
Private Sub SpreadEx_OnFirstQuery() 'スプレッドでアクティブ行を切り替えたときの処理など End Sub
rpxテキストを読み込んで動的にレイアウト
ActiveReportsを使ったVB6プロジェクトで、ユーザーごとに、ちょこっとだけレイアウトを変えたいときにお手軽に対応する方法
ActiveReportは、rpxというXML形式のレイアウト定義を読み書きできるので、ちょこっと変えたレイアウト(dsrとdsx)からrpxをそれぞれ作り、実行時にはこれを読み込んでレイアウトを変更するというやり方です。rpxファイルを配布したくなかったので、データベースから読み込むことにしました。rpxファイルはUTF-8、データベースから読み込んだ文字列(VB6内)はUTF-16LEなので、UTF16ToUTF8関数も作りました。
ユーザーごとのレイアウト定義を用意します。
UserReport.dsr UserReport.dsx UserReport.rpx
前記事の rpxファイルをDBへインポートする で UserReport.rpx をDBにインポートしておきます。アプリ実行時には、これを読み込んでLoadLayoutします。
呼び出し
Dim obj As UserReport Set obj = New UserReport Call LoadLayout(obj, "UserReport.rpx")
共通関数
Declare Function WideCharToMultiByte Lib "kernel32" _ (ByVal CodePage As Long, _ ByVal dwFlags As Long, _ ByVal lpWideCharStr As Long, _ ByVal cchWideChar As Long, _ ByRef lpMultiByteStr As Any, _ ByVal cchMultiByte As Long, _ ByVal lpDefaultChar As String, _ ByVal lpUsedDefaultChar As Long) As Long Public Sub LoadLayout(ByRef obj As ActiveReport, ReportID As String) Dim SQL As String Dim OraDynaset As OraDynaset Dim arr() As String Dim rpx() As Byte Dim i As Long 'バインドパラメータ設定 With OraDataBase.Parameters For i = .Count - 1 To 0 Step - 1 .Remove i Next .Add "ReportID", "", ORAPARM_INPUT, ORATYPE_VARCHAR2 .Item("ReportID").Value = UCase(ReportID) End With SQL = "SELECT LINE FROM ActiveReports WHERE ReportID = :ReportID ORDER BY LINE_NO" Set OraDynaset = OraDataBase.CreateDynaset(SQL, ORADYN_READONLY) With OraDynaset If Not .EOF Then 'データベースからrpxテキストをarrに読み込み ReDim arr(1 To .RecordCount) Do While Not .EOF arr(.RowPosition) = .Fields("LINE").Value & vbCrLf '行末に改行を付加 .MoveNext Loop rpx = UTF16ToUTF8(Join(arr, "")) Call obj.LoadLayout(rpx) End If End With End Sub Public Function UTF16ToUTF8(UTF16 As String) As Byte() Const CP_UTF8 = 65001 UTF16ToUTF8 = UnicodeToMultiByte(UTF16, CP_UTF8) End Function Public Function UnicodeToMultiByte(UTF16 As String, CodePage As Long) As Byte() Dim pInput As Long Dim pOutput As Long Dim size As Long Dim buf() As Byte 'バッファサイズを取得するために、空変換してサイズだけ取得する pInput = StrPtr(UTF16) size = WideCharToMultiByte(CodePage, 0, pInput, -1, 0&, 0&, ByVal 0&, ByVal 0&) 'バッファを確保してCodePageに変換する ReDim buf(size - 1) pOutput = VarPtr(buf(0)) size = WideCharToMultiByte(CodePage, 0, pInput, -1, pOutput, size, ByVal 0&, ByVal 0&) '末尾のnullを除去する ReDim Preserve buf(size - 2) UnicodeToMultiByte = buf End Function
rpxファイルをDBへインポートする
ActiveReportsのrpxファイルを、データベースにインポートするVBScript
UTF-8のリソースファイルをDBにインポートするときのテンプレ
CREATE TABLE ACTIVEREPORTS ( REPORTID VARCHAR2(32) NOT NULL, LINE_NO NUMBER(5,0) NOT NULL, LINE VARCHAR2(2000) CONSTRAINT ACTIVEREPORTS_PK PRIMARY KEY (REPORTID, LINE_NO) USING INDEX )
Option Explicit '動作環境変数 dim oraconst dim database dim username dim password oraconst = "C:\Oracle\Ora92\oo4o\ORACONST.TXT" ' 設定しなければ %ORACLE_HOME% を探しに行きます database = "database" username = "username" password = "password" 'Globalオブジェクト dim wsh dim fso dim ado dim OraSession dim OraDatabase 'ADODB定数 const adBinary = 1 const adText = 2 const adUTF8 = "UTF-8" const adReadAll = -1 const adReadLine = -2 dim arg dim msg call init() for each arg in WScript.Arguments msg = msg & fso.GetFilename(arg) & vbCrLf call main(arg) next call fini() WScript.Echo msg & vbCrLf & "を ActiveReports へインポートしました" WScript.Quit sub init() set wsh = CreateObject("WScript.Shell") set fso = CreateObject("Scripting.FileSystemObject") if WScript.Arguments.Count = 0 then call err.Raise(vbObjectError + 1,, "*.rpx(ActiveReportsレポート定義ファイル) をドロップして下さい") end if for each arg in WScript.Arguments if StrComp("rpx", fso.GetExtensionName(arg), vbTextCompare) <> 0 then call err.Raise(vbObjectError + 2,, fso.GetFilename(arg) & " は *.rpx(ActiveReportsレポート定義ファイル) ではありません") end if next 'ORACONST.TXT定義展開 if len(oraconst) = 0 then if StrComp("%ORACLE_HOME%", wsh.ExpandEnvironmentStrings("%ORACLE_HOME%"), vbTextCompare) = 0 then call err.Raise(vbObjectError + 3,, "環境変数 ORACLE_HOME を取得できません") end if oraconst = fso.BuildPath(wsh.ExpandEnvironmentStrings("%ORACLE_HOME%"), "oo4o\ORACONST.TXT") end if if fso.FileExists(oraconst) then ExecuteGlobal Replace(fso.OpenTextFile(oraconst).ReadAll, "Global ","") else call err.Raise(vbObjectError + 4,, oraconst & " ファイルが見つかりません") end if '入力ファイル設定 Set ado = CreateObject("ADODB.Stream") ado.Type = adText ado.Charset = adUTF8 'ORACLE接続 Set OraSession = CreateObject("OracleInProcServer.XOraSession") Set OraDatabase = OraSession.OpenDatabase(database, username & "/" & password, ORADB_DEFAULT) OraDatabase.Parameters.Add "REPORTID", 0, ORAPARM_INPUT OraDatabase.Parameters.Add "LINE_NO" , 0, ORAPARM_INPUT OraDatabase.Parameters.Add "LINE" , 0, ORAPARM_INPUT end sub sub main(filename) dim reportid dim line_no dim line reportid = ucase(fso.GetFilename(filename)) line_no = 0 ado.Open ado.LoadFromFile filename OraSession.BeginTrans OraDatabase.Parameters("REPORTID").AutoBindEnable OraDatabase.Parameters("LINE_NO").AutoBindDisable OraDatabase.Parameters("LINE").AutoBindDisable OraDatabase.Parameters("REPORTID").Value = reportid OraDatabase.ExecuteSQL "DELETE FROM ActiveReports WHERE REPORTID = :REPORTID" OraDatabase.Parameters("REPORTID").AutoBindEnable OraDatabase.Parameters("LINE_NO").AutoBindEnable OraDatabase.Parameters("LINE").AutoBindEnable do while not ado.EOS line_no = line_no + 1 line = ado.ReadText(adReadLine) OraDatabase.Parameters("REPORTID").Value = reportid OraDatabase.Parameters("LINE_NO").Value = line_no OraDatabase.Parameters("LINE").Value = line OraDatabase.ExecuteSQL "INSERT INTO ActiveReports VALUES (:REPORTID, :LINE_NO, :LINE)" loop OraSession.CommitTrans ado.Close end sub sub fini() set wsh = Nothing set fso = Nothing set ado = Nothing set OraDatabase = Nothing set OraSession = Nothing end sub
ReplaceTable
var tablename varchar2(32) var yyyymmdd varchar2(8) var scriptdir varchar2(512) execute :tablename := '&1'; execute :yyyymmdd := '&2'; execute :scriptdir := '&3'; select statement from( select 0 as no, '-- ■■■ テーブル名( ' || :TABLENAME || ' )' as statement from dual union all select 0.1 as no, 'SELECT TO_CHAR(SYSDATE,''YYYY/MM/DD HH24:MI:SS'') FROM DUAL' from dual union all select 0.9 as no, '/' from dual union all select 1 as no, 'CREATE TABLE ' || :TABLENAME||'_'||:YYYYMMDD || ' AS SELECT * FROM ' || :TABLENAME from dual union all select 1.9 as no, '/' from dual union all select 2 as no, 'DROP TABLE ' || :TABLENAME || ' CASCADE CONSTRAINTS' from dual union all select 2.9 as no, '/' from dual union all select 3 as no, '@"'||:SCRIPTDIR||'\'||:TABLENAME||'.SQL"' from dual union all select 3.9 as no, '/' from dual union all select 4 as no, 'INSERT INTO ' || :TABLENAME || '(' from dual union all select 4 + column_id / 1000 as no, decode(column_id,1,' ',',') || column_name from user_tab_columns where table_name = :TABLENAME union all select 4.2 as no, ')' from dual union all select 4.3 as no, 'SELECT * FROM ' || :TABLENAME||'_'||:YYYYMMDD from dual union all select 4.9 as no, '/' from dual union all select 5 as no, 'COMMIT' from dual union all select 5.9 as no, '/' from dual union all select 90 as no, 'SELECT ''件数チェック'',OLD.COUNT,NEW.COUNT' from dual union all select 90.1 as no, ',''■■■''||DECODE(OLD.COUNT, NEW.COUNT, ''OK'', ''※NG※'') FROM' from dual union all select 90.2 as no, ' (SELECT COUNT(*) COUNT FROM ' || :TABLENAME||'_'||:YYYYMMDD||') OLD' from dual union all select 90.3 as no, ',(SELECT COUNT(*) COUNT FROM ' || :TABLENAME || ' ) NEW' from dual union all select 90.9 as no, '/' from dual union all select 99 as no, '-- ワークテーブル削除' from dual union all select 99.1 as no, '-- DROP TABLE ' || :TABLENAME||'_'||:YYYYMMDD from dual union all select 99.9 as no, '' from dual union all select 99.9 as no, '' from dual order by no) /
