Hatena::Groupvb6

VB6メモ

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

2018-02-03

RS232Cクラス

'
' RS232C制御クラス
'
'使用には以下のコンポーネントが必要
'Microsoft Comm Control 6.0
'
'DATE       Name    Ver  Comment
'2018/02/02 Hantani 1.00 新規作成


Option Explicit

Private m_MSComm As Object
Private m_loglog As String

Public SendCmd As String
Public ExpectData As String
Public ReceiveData As String


Sub RS232open(comNo As Integer, Optional baudrate As String = "9600")
    m_MSComm.CommPort = comNo
    m_MSComm.Settings = baudrate & ",n,8,1"
    m_MSComm.InputLen = 0
    m_MSComm.Handshaking = comNone
    m_MSComm.InputMode = comInputModeText
    m_MSComm.Handshaking = comRTS
    m_MSComm.RThreshold = 1
    m_MSComm.SThreshold = 1
    m_MSComm.DTREnable = True
    m_MSComm.RTSEnable = True
    m_MSComm.PortOpen = True
End Sub

Sub RS232open_NoFlow(comNo As Integer, Optional baudrate As String = "9600")
    m_MSComm.CommPort = comNo
    m_MSComm.Settings = baudrate & ",n,8,1"
    m_MSComm.InputLen = 0
    m_MSComm.Handshaking = comNone
    m_MSComm.InputMode = comInputModeText
    m_MSComm.Handshaking = 0
    m_MSComm.RThreshold = 0
    m_MSComm.SThreshold = 0
    m_MSComm.DTREnable = False
    m_MSComm.RTSEnable = False
    m_MSComm.PortOpen = True
End Sub


Sub RS232close()
    If m_MSComm.PortOpen = True Then
        m_MSComm.PortOpen = False
    End If
End Sub

Sub RS232output(Dat As String)
    
    Dim i As Integer
    
    m_loglog = m_loglog & vbCrLf & "送信: " & Dat & vbCrLf
    
    RS232clear
    
    m_MSComm.Output = Dat
    
End Sub

Function RS232inputN(InLen As Integer) As String
    Dim t1 As Single
    
    t1 = Timer
    Do
        DoEvents
        If Timer - t1 > 15 Then          '15秒待っても指定文字数無かったらタイムアウト
            Exit Do
        End If
    Loop While m_MSComm.InBufferCount < InLen
    
    RS232inputN = Left$(RS232input, InLen)
    
End Function


Function RS232input() As String

    Dim buf As String
    
    If m_MSComm.InBufferCount > 0 Then
        
        buf = m_MSComm.Input
        
        RS232input = buf
        
        m_loglog = m_loglog & buf   'ログ用
        
        buf = Replace(buf, vbCr, "↓")
        buf = Replace(buf, vbLf, "")
    
    End If
End Function

Sub RS232clear()
    m_MSComm.InBufferCount = 0
End Sub

Function RS232instr(Dat As String, Optional Ret As String, Optional WaitTime As Integer = 5) As Boolean
    
    Dim jug As Boolean
    Dim Tm As Single
    Dim Cnt As Integer
    Dim buf As String
    
    Dim a As Single, b As String
        
    m_loglog = m_loglog & "受信: "      'ログ用
    
    jug = False
    Ret = ""
    Tm = Timer
    Cnt = 0
    
    Do
        Ret = Ret & RS232input
       
        If InStr(Ret, Dat) > 0 Then
            jug = True
            Exit Do
        End If
        DoEvents
    Loop While (Timer - Tm) <= WaitTime
    
    RS232instr = jug
    
End Function

'コマンド送信用
Function Send_Command(Cmd As String, OK_Ret As String, Optional Ret As String, Optional WaitTime As Integer = 0) As Boolean
    
    If WaitTime = 0 Then WaitTime = 3 's
    
    RS232output Cmd & vbCrLf
    Send_Command = RS232instr(OK_Ret, Ret, WaitTime)
    
End Function

Private Sub Class_Initialize()
    
    Set m_MSComm = CreateObject("MSCommLib.MSComm")
    'Set m_MSComm = CreateObject("MSCOMMLIB.MSCOMM")
    m_loglog = ""

End Sub

2017-12-25

VBSでAccessにTextをDBへインポートする方法

https://blogs.yahoo.co.jp/bardiel_of_may/54848527.html

Public Sub Import_TextFile()
Dim cn As ADODB.Connection
Dim sSQL As String
    Set cn = CurrentProject.Connection
    sSQL = "SELECT * INTO 受注明細 FROM [受注明細#TXT] IN " & _
        "'D:\My Documents\TEST' 'Text;HDR=NO'"
    cn.Execute sSQL
    cn.Close
    Set cn = Nothing
End Sub

2017-05-23

EXCELを開いている人を記録するVBAマクロ

Option Explicit
'*****************************************************************************
' EXCELファイルを誰が開いているか記録するマクロ
' 
' 【機能】EXCELファイルと同じフォルダにファイル名の拡張子を「.log」にしたファイル
'     にEXCELファイルを開いた時と閉じた時の日時、IPアドレス、PC名、読込専用かを
'        記録する
'
' 日付       Ver   氏名 コメント
' 2017/05/23 1.00  判谷 新規リリース
' 
'*****************************************************************************
Sub Auto_Open()

    Dim f As Integer
    
    f = FreeFile
    Open ActiveWorkbook.Path & "\" & getLogFilename For Append As #f
        Print #1, Date & "," & Time & ",[OPEN" & checkReadOnly & "]," & GetIPAddress & "," & Environ("COMPUTERNAME")
    Close #f

End Sub

Function checkReadOnly() As String

    Dim mode As String
    
    If ThisWorkbook.ReadOnly = True Then
        mode = "(読み取り専用)"
    Else
        mode = ""
    End If

    checkReadOnly = mode

End Function

Sub auto_Close()

    Dim f As Integer
    
    f = FreeFile

    Open ActiveWorkbook.Path & "\" & getLogFilename For Append As #f
        Print #1, Date & "," & Time & ",[CLOSE" & checkReadOnly & "]," & GetIPAddress & "," & Environ("COMPUTERNAME")
    Close #f

End Sub

Function getLogFilename() As String

    Dim FSO As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    getLogFilename = FSO.GetBaseName(ThisWorkbook.Name) & ".log"
    Set FSO = Nothing

End Function


'*****************************************************************************
' IP アドレス取得
'   WMI を用いて IP アドレスを取得する。
'*****************************************************************************
Function GetIPAddress() As String

    Dim NetAdapters, objNic, strIPAddress
    Set NetAdapters = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2") _
                           .ExecQuery("Select * from Win32_NetworkAdapterConfiguration " & _
                           "Where (IPEnabled = TRUE)")

    For Each objNic In NetAdapters 'ネットワークアダプターは、複数ある場合がある
        For Each strIPAddress In objNic.IPAddress 'IPは、複数割り当てられている場合がある
            GetIPAddress = strIPAddress
            Exit For        ' 1回のみ
        Next
        Exit For        ' 1回のみ
    Next

End Function


2017-05-19

Event

AlarmInteger クラス側

Public Event Over(ByVal value As Integer, cancel As Boolean)

Private mvarCurrentValue As Integer 'ローカル コピー
Private mvarMax As Integer 'ローカル コピー
Public Property Let Max(ByVal vData As Integer)
    mvarMax = vData
End Property


Public Property Get Max() As Integer
    Max = mvarMax
End Property



Public Property Let CurrentValue(ByVal vData As Integer)
    Dim cancel As Boolean
    
    If vData > Max Then
        RaiseEvent Over(ByVal vData, cancel)
        If cancel Then Exit Property
    End If
    
    mvarCurrentValue = vData

End Property


Public Property Get CurrentValue() As Integer
    CurrentValue = mvarCurrentValue
End Property

Dim WithEvents X As AlarmInteger

Private Sub Command1_Click()

    X = Text1.Text
    MsgBox (X)
    
    
End Sub

Private Sub Form_Load()
    Set X = New AlarmInteger
    X.Max = 100
End Sub

Private Sub X_Over(ByVal overValue As Integer, cancel As Boolean)
    Dim Answer As VbMsgBoxResult
    
    Answer = MsgBox(overValue & "を代入しようとしています.キャンセルしますか", vbYesNo)
    If Answer = vbYes Then cancel = True
    
    
End Sub

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