Hatena::Groupvb6

VB6メモ

[VB] [個人メモ] [仕事メモ] [アイデア] [Rubyの魔神]
[VB6クラス]

2017-03-09

検査日変換マクロ

'============================================================
'[内容]検査データの日付を変更する
'[使い方] 変更したいファイルのあるフォルダで
'         「dir /S/B >fileList.txt」を実行しファイルのリストを作成
'          同じフォルダでこのスクリプトを実行する
'============================================================
Option Explicit

call main

function dateChange(str)
	dim dic
	dim ret
	
	ret = str

	set dic = CreateObject("Scripting.dictionary")
	'        変更前   変更後
	dic.add "20170207","20170306"
	dic.add "20170208","20170307"
	dic.add "20170209","20170307"
	dic.add "20170213","20170307"
	dic.add "20170214","20170308"
	dic.add "20170216","20170309"
	dic.add "20170217","20170310"
	dic.add "20170218","20170311"
	dic.add "20170220","20170313"
	dic.add "20170221","20170314"
	dic.add "20170222","20170315"
	dic.add "20170223","20170316"
	dic.add "20170224","20170317"
	dic.add "20170301","20170317"
	dic.add "20170306","20170317"

	dim rdline
	dim oldDate
	dim newDate

	rdline = split(str,",")
	oldDate = rdline(1)
	if len(oldDate)=8 then
		if dic.exists(oldDate) = True then
			newDate = dic(oldDate)
			ret = replace(str,oldDate,newDate)
			logPrint("[" & oldDate & ">" & newDate & "]" & ret)
		else
			logPrint("[SKIP2]" & str)
		end if
	else
		logPrint("[SKIP1]" & str)
	end if
	dateChange = ret
end function


sub main

	logPrint("[START]" & date & " " & time)

	dim fileList
	dim outFile

	set fileList = new clsText
	set outFile = new clsText

	fileList.FileName = "fileList.txt"
	fileList.ReadFile
	

	dim i
	dim fileName
	dim n
	
	n = fileList.Count

	for i = 0 to n -1
		outfile.FileName = fileList.Items(i)
		logPrint(outfile.FileName)
		outfile.Clear
		outfile.ReadFile
		dim j
		dim m
		m = outfile.Count
		for j = 0 to m -1
			outfile.Change j,dateChange(outfile.Items(j))
		next
		outfile.WriteFile
	next
	msgbox("END")
	logPrint("[END]" & date & " " & time)
end sub

class clsText

	dim LineData
	dim RDobjFile
	dim RDobjFso
	dim WRobjFso
	dim WRobjFile
	dim m_FileName

    Public Property Get FileName
        FileName = m_FileName
    End Property

    Public Property Let FileName(vData)
        m_FileName = vData
    End Property


    Private Sub Class_Initialize()
        set LineData = new ArrayList
		Set RDobjFso = CreateObject("Scripting.FileSystemObject")
		Set WRobjFso = CreateObject("Scripting.FileSystemObject")
    End Sub

    Private Sub Class_Terminate()
		Set RDobjFso = Nothing
		Set WRobjFso = Nothing
    End Sub

	Public Sub Clear
		LineData.Clear
	end sub

	public Function Count
		Count = LineData.Count
	end Function

	public Function Items(n)
		Items = LineData.Items(n)
	end Function

	public Sub Change(i,x)
		LineData.Change i,x
	end sub

	Public Sub ReadFile
		Set RDobjFile = RDobjFso.OpenTextFile(m_FileName, 1, False)
		If Err.Number > 0 Then
		    WScript.Echo "Open Error"
		Else
		    Do Until RDobjFile.AtEndOfStream
		        LineData.add RDobjFile.ReadLine
		    Loop
		End If
		RDobjFile.Close
		Set RDobjFile = Nothing
	end sub

	Public Sub WriteFile
		Set WRobjFile = WRobjFso.OpenTextFile(m_FileName, 2, True)
		If Err.Number > 0 Then
		    WScript.Echo "Open Error"
		Else
			dim item
			for each item in LineData.item
	    			WRobjFile.WriteLine item
			next
		End If
		WRobjFile.Close
		Set WRobjFile = Nothing
	end sub

	Public Sub AppendFile
		Set WRobjFile = WRobjFso.OpenTextFile(m_FileName, 8, True)
		If Err.Number > 0 Then
		    WScript.Echo "Open Error"
		Else
			for each item in LineData.item
	    		WRobjFile.WriteLine item
			next
		End If
		WRobjFile.Close
		Set WRobjFile = Nothing
	end sub

'Scripting.FileSystemObjectはファイル操作をするオブジェクトです。
'OpenTextFileでファイルを開きます。
'第1パラメータ→ 必ず指定します。
'第2パラメータ→ 1:読み取り専用、2:書き込み専用、8:ファイルの最後に書き込み
'第3パラメータ→ True(規定値):新しいファイルを作成する、False:新しいファイルを作成しない
'第4パラメータ→ 0(規定値):ASCII ファイルとして開く、-1:Unicode ファイルとして開く、-2:システムの既定値で開く
'ReadLineでテキストファイルを読み込みます。
'Closeでファイルをクローズします。

	sub OpenFileDialog(title)

	    Dim obj, filename
	    Set obj = CreateObject("Excel.Application")
	    filename = obj.GetOpenFilename("ALL File,*.*",1,title)
	    obj.Quit
	    Set obj = Nothing
	    If filename <> False Then
	          m_FileName = filename
	    End If

	end sub

end Class



'動的配列版ArrayList
class ArrayList

	private m_Item()
	private m_count

	public sub Add(x)
		ReDim Preserve m_item(m_count)
		If IsObject(x) Then
			set m_item(m_count) = x
		else
			m_item(m_count) = x
		end if
		m_count = m_count + 1
	end sub

	public sub Change(i,x)
		If IsObject(x) Then
			set m_item(i) = x
		else
			m_item(i) = x
		end if
	end sub

	public function Count
		Count = m_count
	end function

	public function Clear
		m_count=0
		Erase m_item
	end function

	public function Item
		Item = m_Item
	end function

	public function Items(n)
		If IsObject(m_Item(n)) Then
			set Items = m_Item(n)
		else
			Items = m_Item(n)
		end if
	end function

end class
function apppath
    dim fso
    set fso = createObject("Scripting.FileSystemObject")
    apppath = fso.getParentFolderName(WScript.ScriptFullName)
end function

sub logPrintln(s)
	logPrint(s & vbcrlf)
end sub

sub logPrint(s)
	dim objFsoWR
	dim objFileWR
	dim LogFile
	dim SerialFieldNo


	LogFile = apppath & "\log.log"

	Set objFsoWR = CreateObject("Scripting.FileSystemObject")
	Set objFileWR = objFsoWR.OpenTextFile(LogFile, 8, True)

	If Err.Number > 0 Then
	    WScript.Echo "Open Error"
	Else
		objFileWR.WriteLine s
	End If

	objFileWR.Close
	Set objFileWR = Nothing
	Set objFsoWR = Nothing

end sub

TXTファイル結合

'============================================================
'[内容]複数のテキストファイルを1つのファイルにまとめる
'[使い方] 結合したいファイルのあるフォルダで
'         「dir /S/B >fileList.txt」を実行しファイルのリストを作成
'          同じフォルダでこのスクリプトを実行すると「all.csv」へ
'          全てのファイルを結合し出力する
'============================================================
Option Explicit

call main


sub main

	logPrintln("[START]" & date & " " & time)

	dim fileList
	dim outFile

	set fileList = new clsText
	set outFile = new clsText

	fileList.FileName = "fileList.txt"
	fileList.ReadFile
	

	dim i
	dim fileName
	dim n
	
	n = fileList.Count

	for i = 0 to n -1
		outfile.FileName = fileList.Items(i)
		logPrintln(outfile.FileName)
		outfile.ReadFile
	next
	outfile.FileName = "all.csv"
	outfile.WriteFile
	msgbox("END")
	logPrintln("[END]" & date & " " & time)

end sub

class clsText

	dim LineData
	dim RDobjFile
	dim RDobjFso
	dim WRobjFso
	dim WRobjFile
	dim m_FileName

    Public Property Get FileName
        FileName = m_FileName
    End Property

    Public Property Let FileName(vData)
        m_FileName = vData
    End Property


    Private Sub Class_Initialize()
        set LineData = new ArrayList
		Set RDobjFso = CreateObject("Scripting.FileSystemObject")
		Set WRobjFso = CreateObject("Scripting.FileSystemObject")
    End Sub

    Private Sub Class_Terminate()
		Set RDobjFso = Nothing
		Set WRobjFso = Nothing
    End Sub

	Public Sub Clear
		LineData.Clear
	end sub

	public Function Count
		Count = LineData.Count
	end Function

	public Function Items(n)
		Items = LineData.Items(n)
	end Function

	public Sub Change(i,x)
		LineData.Change i,x
	end sub

	Public Sub ReadFile
		Set RDobjFile = RDobjFso.OpenTextFile(m_FileName, 1, False)
		If Err.Number > 0 Then
		    WScript.Echo "Open Error"
		Else
		    Do Until RDobjFile.AtEndOfStream
		        LineData.add RDobjFile.ReadLine
		    Loop
		End If
		RDobjFile.Close
		Set RDobjFile = Nothing
	end sub

	Public Sub WriteFile
		Set WRobjFile = WRobjFso.OpenTextFile(m_FileName, 2, True)
		If Err.Number > 0 Then
		    WScript.Echo "Open Error"
		Else
			dim item
			for each item in LineData.item
	    			WRobjFile.WriteLine item
			next
		End If
		WRobjFile.Close
		Set WRobjFile = Nothing
	end sub

	Public Sub AppendFile
		Set WRobjFile = WRobjFso.OpenTextFile(m_FileName, 8, True)
		If Err.Number > 0 Then
		    WScript.Echo "Open Error"
		Else
			for each item in LineData.item
	    		WRobjFile.WriteLine item
			next
		End If
		WRobjFile.Close
		Set WRobjFile = Nothing
	end sub

'Scripting.FileSystemObjectはファイル操作をするオブジェクトです。
'OpenTextFileでファイルを開きます。
'第1パラメータ→ 必ず指定します。
'第2パラメータ→ 1:読み取り専用、2:書き込み専用、8:ファイルの最後に書き込み
'第3パラメータ→ True(規定値):新しいファイルを作成する、False:新しいファイルを作成しない
'第4パラメータ→ 0(規定値):ASCII ファイルとして開く、-1:Unicode ファイルとして開く、-2:システムの既定値で開く
'ReadLineでテキストファイルを読み込みます。
'Closeでファイルをクローズします。

	sub OpenFileDialog(title)

	    Dim obj, filename
	    Set obj = CreateObject("Excel.Application")
	    filename = obj.GetOpenFilename("ALL File,*.*",1,title)
	    obj.Quit
	    Set obj = Nothing
	    If filename <> False Then
	          m_FileName = filename
	    End If

	end sub

end Class



'動的配列版ArrayList
class ArrayList

	private m_Item()
	private m_count

	public sub Add(x)
		ReDim Preserve m_item(m_count)
		If IsObject(x) Then
			set m_item(m_count) = x
		else
			m_item(m_count) = x
		end if
		m_count = m_count + 1
	end sub

	public sub Change(i,x)
		If IsObject(x) Then
			set m_item(i) = x
		else
			m_item(i) = x
		end if
	end sub

	public function Count
		Count = m_count
	end function

	public function Clear
		m_count=0
		Erase m_item
	end function

	public function Item
		Item = m_Item
	end function

	public function Items(n)
		If IsObject(m_Item(n)) Then
			set Items = m_Item(n)
		else
			Items = m_Item(n)
		end if
	end function

end class
function apppath
    dim fso
    set fso = createObject("Scripting.FileSystemObject")
    apppath = fso.getParentFolderName(WScript.ScriptFullName)
end function

sub logPrintln(s)
	logPrint(s & vbcrlf)
end sub

sub logPrint(s)
	dim objFsoWR
	dim objFileWR
	dim LogFile
	dim SerialFieldNo


	LogFile = apppath & "\log.log"

	Set objFsoWR = CreateObject("Scripting.FileSystemObject")
	Set objFileWR = objFsoWR.OpenTextFile(LogFile, 8, True)

	If Err.Number > 0 Then
	    WScript.Echo "Open Error"
	Else
		objFileWR.WriteLine s
	End If

	objFileWR.Close
	Set objFileWR = Nothing
	Set objFsoWR = Nothing

end sub


2016-06-10

VBS テキストファイル読書きクラス

Option Explicit

Main()


sub Main()

	dim tf
	dim s

	set tf = new ClsTxtFile

	tf.FileOpen "C:\Temp\test.txt","W"
	tf.Print "line1"
	tf.Print "line2"
	tf.FileClose

	tf.FileOpen "C:\Temp\test.txt","R"
	do while tf.Input(s) = True
		msgbox(s)
	loop
	tf.FileClose

	msgbox("ReadAll")

	tf.FileOpen "C:\Temp\test.txt","A"
	tf.Print "line3"
	tf.Print "line4"
	tf.FileClose

	tf.FileOpen "C:\Temp\test.txt","R"
	tf.ReadAll
	for each s in tf.Lines.Item
		msgbox(s)
	next
	tf.FileClose

end sub


class ClsTxtFile

	dim objFso
	dim objFile
	public Lines


	'Scripting.FileSystemObjectはファイル操作をするオブジェクトです。
	'OpenTextFileでファイルを開きます。
	'第1パラメータ→ 必ず指定します。
	'第2パラメータ→ 1:読み取り専用、2:書き込み専用、8:ファイルの最後に書き込み
	'第3パラメータ→ True(規定値):新しいファイルを作成する、False:新しいファイルを作成しない
	'第4パラメータ→ 0(規定値):ASCII ファイルとして開く、-1:Unicode ファイルとして開く、-2:システムの既定値で開く
	'ReadLineでテキストファイルを読み込みます。
	'Closeでファイルをクローズします。
	public function FileOpen(filename,mode)
		Set objFso = CreateObject("Scripting.FileSystemObject")
		Set Lines = new ArrayList

		select case ucase(mode)
			case "W"
				Set objFile = objFso.OpenTextFile(filename, 2, True)
			case "A"
				Set objFile = objFso.OpenTextFile(filename, 8, True)
			case "R"
				Set objFile = objFso.OpenTextFile(filename, 1, False)
		end select
	
	end function

	public sub Print(s)

		If Err.Number > 0 Then
		    WScript.Echo "Open Error"
		Else
		    objFile.WriteLine s
		End If

	end sub

	public function Input(s)

		If Err.Number > 0 Then
		    WScript.Echo "Open Error"
		Else
			if objFile.AtEndOfStream = True then
				Input = false
			else
				Input = True
		        s =  objFile.ReadLine
			end if
		End If

	end function

	public sub ReadAll

		If Err.Number > 0 Then
		    WScript.Echo "Open Error"
		Else
			Lines.Clear
		    Do Until objFile.AtEndOfStream
		        Lines.add objFile.ReadLine
		    Loop
		End If

	end sub

	public function FileClose
		objFile.Close
		Set objFile = Nothing
		Set objFso = Nothing
		Set Lines = Nothing
	end function

end class

'動的配列版ArrayList
class ArrayList

	private m_Item()
	private m_count

	public sub Add(x)
		ReDim Preserve m_item(m_count)
		If IsObject(x) Then
			set m_item(m_count) = x
		else
			m_item(m_count) = x
		end if
		m_count = m_count + 1
	end sub

	public function Count
		Count = m_count
	end function

	public function Clear
		m_count=0
		Erase m_item
	end function

	public function Item
		Item = m_Item
	end function

	public function Items(n)
		If IsObject(m_Item(n)) Then
			set Items = m_Item(n)
		else
			Items = m_Item(n)
		end if
	end function

end class


2016-06-06

VBS 文字コード変換

http://blog.goo.ne.jp/fukuriko/e/a40eb03d587d572f1389b24d17c60526


Function Encode(strUni,cset) 
    Set objStm = CreateObject("ADODB.Stream")
    objStm.Open
    objStm.Type = 2
    objStm.Charset = cset
    objStm.WriteText strUni 
    objStm.Position = 0
    objStm.Type = 1
    Select Case UCase(cset)
      Case "UNICODE", "UTF-16"
        objStm.Position = 2
      Case "UTF-8"
        objStm.Position = 3
    End Select
    Encode = objStm.Read()


    objStm.Close
    Set objStm = Nothing
End Function

【使用例】

' 変数str は Shift_JIS に変換された "あういうえお" が代入される

str = Encode("あいうえお","Shift_JIS")



UTF-8 読み書き

http://neos21.hatenablog.com/entry/2016/03/25/074343

' 読み込みファイルの指定 (相対パスなのでこのスクリプトと同じフォルダに置いておくこと)
Dim input
Set input = CreateObject("ADODB.Stream")
input.Type = 2    ' 1:バイナリ・2:テキスト
input.Charset = "UTF-8"    ' 文字コード指定
input.Open    ' Stream オブジェクトを開く
input.LoadFromFile "inputText.txt"    ' ファイルを読み込む

' 書き出しファイルの指定 (今回は新規作成する)
Dim output
Set output = CreateObject("ADODB.Stream")
output.Type = 2
output.Charset = "UTF-8"
output.Open

' 読み込みファイルから1行ずつ読み込み、書き出しファイルに書き出すのを最終行まで繰り返す
Dim records
Do Until input.EOS
  Dim lineStr
  lineStr = input.ReadText(-2)    ' -1:全行読み込み・-2:一行読み込み
  output.WriteText lineStr, 1    ' 0:文字列のみ書き込み・1:文字列 + 改行を書き込み
Loop

' 書き出しファイルの保存
output.SaveToFile "outputText.txt", 2    '1:指定ファイルがなければ新規作成・2:ファイルがある場合は上書き

' Stream を閉じる
input.Close
output.Close

2016-06-03

VBS 正規表現

http://d.hatena.ne.jp/cloned/20090205

正規表現を使ってパターンに一致するか調べる

Newを使ってRegExpオブジェクトを取得する。パターンはRegExpオブジェクトのPatternプロパティに代入する。

Dim re
Set re = New RegExp
re.Pattern = "^A.*$"
If re.Test("ABC") Then
    WScript.Echo "matched"
End If
大文字小文字を無視する場合はIgnoreCaseにTrueを代入する。

re.IgnoreCase = True
最初の一致のみではなく、文字列全体を検索対象にする場合にはGlobalにTrueを代入する。

re.Global = True
正規表現を使って一致する文字列を取得する

RegExpオブジェクトのExecuteを使う。

Dim re, matches
Set re = New RegExp
re.Pattern = "^A.*$"
Set matches = re.Execute("ABC")
If matches.Count > 0 Then
    WScript.Echo matches(0)
End If
出力結果は「ABC」となる。

正規表現を使ってキャプチャした文字列を取得する

Itemプロパティを利用してSubMatchesを取得する。

Dim re, matches
Set re = New RegExp
re.Pattern = "^([A-F]+)_([A-F]+).+"
Set matches = re.Execute("ABC_DEF_GHI")
If matches.Count > 0 Then
    WScript.Echo matches.Item(0).SubMatches.Item(0)
    WScript.Echo matches.Item(0).SubMatches.Item(1)
End If
出力結果は「ABC」「DEF」となる。

正規表現を使って文字列を置換する

RegExpオブジェクトのReplaceを使う。

Dim re, matches
Set re = New RegExp
re.Pattern = "^ABC_"
WScript.Echo re.Replace("ABC_DEF_GHI", "XXX_")
出力結果は「XXX_DEF_GHI」となる。

正規表現を使って文字列を置換する(後方参照)

RegExpオブジェクトのReplaceを使って置換文字列中に$数字の形式で参照する。

Dim re, matches
Set re = New RegExp
re.Pattern = "^([A-Z]{2})(.*)"
WScript.Echo re.Replace("ABCDE", "XX$2")
出力結果は「XXCDE」となる。

2016-06-02

VBS動的配列を使ったArrayList

Option Explicit

dim a



set a = new ArrayList

dim t1:set t1 = new test:t1.msg="1"
a.add(t1)
dim t2:set t2 = new test:t2.msg="2"
a.add(t2)
dim t3:set t3 = new test:t3.msg="3"
a.add(t3)
msgbox(a.Count)

dim item

for each item in a.item
	item.say
next

a.clear
msgbox("clear")
for each item in a.item
	item.say
next

a.add(t1)
a.add(t2)
a.add(t3)
msgbox(a.Count)


for each item in a.item
	item.say
next


a.Items(1).msg="say"
a.Items(1).say

class test
	public msg
	public sub say
		msgbox(msg)
	end sub
end class



'動的配列版
class ArrayList

	private m_Item()
	private m_count

	public sub Add(x)
		ReDim Preserve m_item(m_count)
		If IsObject(x) Then
			set m_item(m_count) = x
		else
			m_item(m_count) = x
		end if
		m_count = m_count + 1
	end sub

	public function Count
		Count = m_count
	end function

	public function Clear
		m_count=0
		Erase m_item
	end function

	public function Item
		Item = m_Item
	end function

	public function Items(n)
		If IsObject(m_Item(n)) Then
			set Items = m_Item(n)
		else
			Items = m_Item(n)
		end if
	end function

end class