'*************************************************
' Simulate keyboard.
' Ex：
' Call keybd_event(17, 0, 0, 0) 'Pushing ctrl is continued.
' Call Delay(100)
' Call keybd_event(67, 0, 0, 0) '//Pushing c
' Call Delay(100)
' Call keybd_event(67, 0, 2, 0) '//Release c
' Call Delay(100)
' Call keybd_event(17, 0, 2, 0) 'Release ctrl
'*************************************************
Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Public Declare Function GetTickCount Lib "kernel32" () As Long
'Define Excel API
Public Declare Function GetLocaleInfo Lib "kernel32" Alias _
"GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, _
ByVal lpLCData As String, ByVal cchData As Long) As Long
Private Const LOCALE_SYSTEM_DEFAULT = 2048
Private Const LOCALE_SENGCOUNTRY = &H1002
Public Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As String
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
End Type
'*************************************************
' Get SYSTEMTIME
'*************************************************
Public Function GetSYSTEMTIME() As SYSTEMTIME
Dim sys As SYSTEMTIME
Dim dt As Date
Dim myTime
myTime = time
dt = Date
sys.wYear = Year(dt)
sys.wMonth = Month(dt)
sys.wDayOfWeek = WeekdayName(Weekday(dt))
sys.wDay = Day(dt)
sys.wHour = Hour(myTime)
sys.wMinute = Minute(myTime)
sys.wSecond = Second(myTime)
GetSYSTEMTIME = sys
End Function
'*************************************************
'* Get Now with yyyyMMddHHmmss
'*************************************************
Public Function GetNow_yyyyMMddHHmmss() As String
GetNow_yyyyMMddHHmmss = Format(Now, "yyyyMMddHHmmss")
End Function
'*************************************************
' Delay ( time ms )
'*************************************************
Public Sub Delay(time As Long)
Dim oldtime As Long
oldtime = GetTickCount()
If GetTickCount - oldtime < time Then
DoEvents
End If
End Sub
'*******************************************************
'EX:
'MessageFormat
' Dim args(2) As String
' args(0) = "test1"
' args(1) = "test2"
' args(2) = "test3"
' MsgBox (MessageFormat("this sheet No. {0},{1},{2} is OK.", args))
'*******************************************************
Function MessageFormat(targetMsg As String, args() As String) As String
Dim index As Integer
For index = 0 To UBound(args)
targetMsg = Replace(targetMsg, "{" & index & "}", args(index))
Next index
MessageFormat = targetMsg
End Function
'*************************************************
' This String is Matched ?
'*************************************************
Function isMatchedWithRegExp(ByVal theStr As String _
, ByVal pat As String _
, Optional ByVal ignoreCaseFlag As Boolean = True) As Boolean
Set re = CreateObject("VBScript.RegExp")
With re
.Global = True ' Search the whole character string.
.IgnoreCase = ignoreCaseFlag ' Ture : Lowwer Letter a = Upper Letter A
.Pattern = pat
If .test(theStr) Then
isMatchedWithRegExp = True
Set re = Nothing
Exit Function
End If
End With
isMatchedWithRegExp = False
Set re = Nothing
End Function
'*************************************************
' Get Matched String
' Ex: .+(\w\w).+(\d\d).+
'*************************************************
Function GetMatchedInnerStrWithRegExp(ByVal theStr As String _
, ByVal pat As String _
, Optional ByVal ignoreCaseFlag As Boolean = True _
, Optional ByVal strSplitMark As String = vbCrLf) As String
Dim ret As String
ret = ""
Set re = CreateObject("VBScript.RegExp")
With re
.Global = True ' Search the whole character string.
.IgnoreCase = ignoreCaseFlag ' Ture : Lowwer Letter a = Upper Letter A
.Pattern = pat
End With
Set objMatches = re.Execute(theStr)
If objMatches.COUNT > 0 Then
Set m = objMatches(0)
For index = 0 To m.SubMatches.COUNT - 1
ret = ret & m.SubMatches(index)
If index <> m.SubMatches.COUNT - 1 Then
ret = ret & strSplitMark
End If
Next index
End If
GetMatchedInnerStrWithRegExp = ret
Set re = Nothing
End Function
'*************************************************
' Get Matched String
' Ex: ([\w\d]+|bb)
'*************************************************
Function GetMatchedWithRegExp(ByVal theStr As String _
, ByVal pat As String _
, Optional ByVal ignoreCaseFlag As Boolean = True _
, Optional ByVal strSplitMark As String = vbCrLf) As String
Dim ret As String
ret = ""
Set re = CreateObject("VBScript.RegExp")
With re
.Global = True ' Search the whole character string.
.IgnoreCase = ignoreCaseFlag ' Ture : Lowwer Letter a = Upper Letter A
.Pattern = pat
End With
Set objMatches = re.Execute(theStr)
If objMatches.COUNT > 0 Then
For index = 0 To objMatches.COUNT - 1
ret = ret & objMatches.Item(index).value
If index <> objMatches.COUNT - 1 Then
ret = ret & strSplitMark
End If
Next index
End If
GetMatchedWithRegExp = ret
Set re = Nothing
End Function
'*************************************************
' Get String With RegExp After Repalced
'*************************************************
Function GetStringWithRegExpAfterFormat(ByVal theStr As String _
, ByVal pat As String _
, Optional ByVal ignoreCaseFlag As Boolean = True _
, Optional ByVal strReplace As String = "###") As String
If strReplace = "###" Then
MsgBox "Replace String is NULL!", vbCritical
Exit Function
End If
Dim ret
ret = theStr
On Error GoTo EXECEPTION
With CreateObject("VBScript.RegExp")
.Global = True ' Search the whole character string.
.IgnoreCase = ignoreCaseFlag ' Ture : Lowwer Letter a = Upper Letter A
.Pattern = pat
If .test(theStr) Then
ret = .Replace(theStr, strReplace)
End If
End With
EXECEPTION:
If Err.Number <> 0 Then
MsgBox GetMsg(LANGUAGE_KBN, 4) & Err.Description, vbExclamation
ret = ""
End If
GetStringWithRegExpAfterFormat = ret
End Function
'*************************************************
' GetTextFromClipboard
'*************************************************
Function GetTextFromClipboard() As String
On Error GoTo EXECEPTION
Set MyData = New DataObject
MyData.GetFromClipboard
GetTextFromClipboard = MyData.GetText(1)
EXECEPTION:
If Err.Number <> 0 Then
MsgBox GetMsg(LANGUAGE_KBN, 4) & Err.Description & vbCrLf, vbExclamation
End If
End Function
'*************************************************
' SetTextToClipboard
'*************************************************
Function SetTextToClipboard(theText)
On Error GoTo EXECEPTION
Set MyData = New DataObject
MyData.GetFromClipboard
MyData.SetText (theText)
MyData.PutInClipboard
EXECEPTION:
If Err.Number <> 0 Then
MsgBox GetMsg(LANGUAGE_KBN, 4) & Err.Description & vbCrLf, vbExclamation
End If
End Function
'*************************************************
' FindRangeAddrBySheet
'*************************************************
Function FindRangeAddrBySheet(sheetName, findString, MatCase) As String
Dim fc As Range
Set fc = Worksheets(sheetName).Cells.Find(What:=findString, MatchCase:=MatCase)
If fc Is Nothing Then
FindRangeAddrBySheet = ""
Else
FindRangeAddrBySheet = fc.Address
End If
End Function
'*************************************************
' FindNextRangeAddrBySheet
'*************************************************
Function FindNextRangeAddrBySheet(rangeAddress) As String
Dim ret As Range
Set ret = Worksheets(sheetName).Cells.FindNext(After:=Range(rangeAddress))
FindNextRangeAddrBySheet = ret.Address
End Function
'*************************************************
' FindPrevRangeAddrBySheet
'*************************************************
Function FindPrevRangeAddrBySheet(rangeAddress) As String
Dim ret As Range
Set ret = Worksheets(sheetName).Cells.FindPrevious(After:=Range(rangeAddress))
FindPrevRangeAddrBySheet = ret.Address
End Function
'*************************************************
' Get Cell of the last of cell field used for sheet 2015/10/13 ADD
'*************************************************
Function GetActiveCellMaxRowAndColumn(theSheetName) As String
Dim thisSheetMaxRow, thisSheetMaxCol As Long
thisSheetMaxRow = Sheets(theSheetName).Cells.SpecialCells(xlCellTypeLastCell).Row
thisSheetMaxCol = Sheets(theSheetName).Cells.SpecialCells(xlCellTypeLastCell).Column
GetCellActiveMaxRowAndColumn = thisSheetMaxRow & ":" & thisSheetMaxCol
End Function
'*************************************************
' Write in specified file to carry out for arrangement after clarifying. 2015/12/10 ADD
' Ex：Call WriteArr2File(ThisWorkbook.Path, "test.txt", arrWriteLine, "UTF-8", vbCrLf)
'*************************************************
Sub WriteArr2File_BOM(filePath, fileName, arrWriteLine() As String, writeMojiCode, wrapTypeCRLF)
Dim Stream As Object
Dim strCreateFile As String
Dim objFileSys As Object
If Len(Trim(filePath)) = 0 Then
' default : ThisWorkbook.Path when filePath is null/blank
filePath = ThisWorkbook.path
End If
If UBound(arrWriteLine) = 0 Then
MsgBox "Len(arrWriteLine) = 0", vbExclamation
End If
If Trim(wrapTypeCRLF) = 0 Then
' default : vbCrLf when wrapTypeCRLF is null/blank
wrapTypeCRLF = vbCrLf
End If
If Len(Trim(writeMojiCode)) = 0 Then
' default : "UTF-8" when writeMojiCode is null/blank
writeMojiCode = "UTF-8"
End If
On Error GoTo EXECEPTION
Set objFileSys = CreateObject("Scripting.FileSystemObject")
strCreateFile = objFileSys.BuildPath(filePath, fileName)
Set Stream = CreateObject("ADODB.Stream")
Stream.Charset = writeMojiCode
Stream.Type = 2
Stream.Open
Dim aLine As Variant
For Each aLine In arrWriteLine
Stream.writeText aLine & wrapTypeCRLF
Next
Stream.SaveToFile (strCreateFile), 2
EXECEPTION:
If Err.Number <> 0 Then
MsgBox "WriteArr2File_BOM " & GetMsg(LANGUAGE_KBN, 4) & Err.Description, vbExclamation
End If
Stream.Close
Set Stream = Nothing
End Sub
'*************************************************
' Character string code of generation file was used at BOM none. 2016/01/07 ADD
' Ex ：Call WriteArr2File(ThisWorkbook.Path, "test.txt", arrWriteLine, "UTF-8", vbCrLf)
'*************************************************
Sub WriteArr2File_NO_BOM(filePath, fileName, arrWriteLine() As String, writeMojiCode, wrapTypeCRLF)
Dim Stream, StreamTmp As Object
Dim strCreateFile, strCreateTmpFile As String
Dim objFileSys As Object
If Len(Trim(filePath)) = 0 Then
' default : ThisWorkbook.Path when filePath is null/blank
filePath = ThisWorkbook.path
End If
If UBound(arrWriteLine) = 0 Then
MsgBox "Len(arrWriteLine) = 0", vbExclamation
End If
If Trim(wrapTypeCRLF) = 0 Then
' default : vbCrLf when wrapTypeCRLF is null/blank
wrapTypeCRLF = vbCrLf
End If
writeMojiCode = Trim(writeMojiCode)
If Len(writeMojiCode) = 0 Then
' default : "UTF-8" when writeMojiCode is null/blank
writeMojiCode = "UTF-8"
End If
On Error GoTo EXECEPTION
Dim tmpFile As String
tmpFile = fileName & "_temp"
Set objFileSys = CreateObject("Scripting.FileSystemObject")
strCreateFile = objFileSys.BuildPath(filePath, fileName)
strCreateTmpFile = objFileSys.BuildPath(filePath, tmpFile)
Set Stream = CreateObject("ADODB.Stream")
Stream.Charset = writeMojiCode
Stream.Type = 2
Stream.Open
Dim aLine As Variant
For Each aLine In arrWriteLine
Stream.writeText aLine & wrapTypeCRLF
Next
Stream.SaveToFile (strCreateTmpFile), 2
' remove BOM ... Start
Set StreamTmp = CreateObject("ADODB.Stream")
With StreamTmp
.Type = 1
.Open
.LoadFromFile (strCreateTmpFile) ' Read in the tmp file With Binnary
.Position = 3 ' BOM (Skip 3 bits)
' Output target File with contents from the 4th bit by binnary.
Dim ws: Set ws = CreateObject("ADODB.Stream")
ws.Type = 1
ws.Open
ws.Write (.Read(-1))
ws.SaveToFile strCreateFile, 2
End With
' remove BOM ... End
' Delete Tmp File
Call CreateObject("Scripting.FileSystemObject").DeleteFile(strCreateTmpFile)
EXECEPTION:
If Err.Number <> 0 Then
MsgBox "WriteArr2File_NO_BOM " & GetMsg(LANGUAGE_KBN, 4) & Err.Description, vbExclamation
End If
Stream.Close
Set Stream = Nothing
ws.Close
Set ws = Nothing
StreamTmp.Close
Set StreamTmp = Nothing
End Sub
'*************************************************
' Read target file . Became to String()
' Hint ：Copy Modify me.
'*************************************************
Function ReadFile2Arr(filePath, fileName, readMojiCode) As String()
ReDim ret(0) As String 'auto arr
On Error GoTo EXECEPTION
Dim index As Long
If Len(Trim(filePath)) = 0 Then
' default : ThisWorkbook.Path when filePath is null/blank
filePath = ThisWorkbook.path
End If
If Len(Trim(readMojiCode)) = 0 Then
' default : "UTF-8" when readMojiCode is null/blank
readMojiCode = "UTF-8"
End If
Set objFileSys = CreateObject("Scripting.FileSystemObject")
Dim StreamReader As Object
Set StreamReader = CreateObject("ADODB.Stream")
StreamReader.Charset = readMojiCode
StreamReader.Type = 2 '?
StreamReader.Open
StreamReader.LoadFromFile (objFileSys.BuildPath(filePath, fileName))
Dim retstring, retStr As String
Do While Not (StreamReader.EOS)
retstring = StreamReader.ReadText(-2) 'Read Text 1 row
retStr = retstring
'######################################################################
'### Modify for Local
'retStr = GetMatchedInnerStrWithRegExp
'retStr = isMatchedWithRegExp
'retStr = GetMatchedWithRegExp
'retStr = GetStringWithRegExpAfterFormat
'######################################################################
index = UBound(ret) 'now size
ReDim Preserve ret(index + 1) 'auto plus 1
ret(index) = retStr
Loop
ReDim Preserve ret(index) 'ReSet size
EXECEPTION:
If Err.Number <> 0 Then
MsgBox "ReadFile2Arr " & GetMsg(LANGUAGE_KBN, 4) & Err.Description, vbExclamation
End If
StreamReader.Close
Set StreamReader = Nothing
ReadFile2Arr = ret
End Function
'*************************************************
' add parameter to Environment
'*************************************************
Public Sub addParamToEnvironment(key As String, value As String)
Dim ws As Object
Set ws = CreateObject("Wscript.Shell")
Dim arr As Variant
arr = Split(value, SPLIT_DATEMARK_S)
Dim tmp As String
tmp = value
tmp = getValDec2Hex(arr(0)) & SPLIT_DATEMARK & getValDec2Hex(arr(1)) & SPLIT_DATEMARK & getValDec2Hex(arr(2))
ws.Run "cmd /c setx " & key & " " & tmp, vbHide
End Sub
'*************************************************
' Dec2Hex
'*************************************************
Function getValDec2Hex(Dec) As String
getValDec2Hex = String(4 - Len(Hex(Val(Dec))), "0") & Hex(Dec)
End Function
'*************************************************
' Hex2Dec
'*************************************************
Function getValHex2Dec(Hex) As String
getValHex2Dec = Application.WorksheetFunction.Hex2Dec(Hex)
End Function
'*************************************************
' Read target file on unit of row.
' hint：Copy Modify me.
'*************************************************
Function ReadFileA2WriteFileBLineByLine(filePathName, readMojiCode, wrapTypeCRLF_Reader, filePath_Write, fileName_Write, wrapTypeCRLF_Write, isRemoveBOM)
' Dim maxLine As Long
' maxLine = getMaxLine(filePathName)
On Error GoTo EXECEPTION
If Len(Trim(readMojiCode)) = 0 Then
readMojiCode = "UTF-8" ' default : "UTF-8" when readMojiCode is null/blank
End If
Dim objFileSys As Object
Set objFileSys = CreateObject("Scripting.FileSystemObject")
Dim StreamReader As Object
Set StreamReader = CreateObject("ADODB.Stream")
StreamReader.Charset = readMojiCode
StreamReader.Type = 2 '?
StreamReader.Open
StreamReader.LineSeparator = wrapTypeCRLF_Reader ' Enter CRLF（10）
StreamReader.LoadFromFile (filePathName)
Dim Stream_Write As Object
Dim strCreateFile_Write As String
strCreateFile_Write = objFileSys.BuildPath(filePath_Write, fileName_Write)
Set Stream_Write = CreateObject("ADODB.Stream")
Stream_Write.Charset = readMojiCode
Stream_Write.Type = 2
Stream_Write.Open
Dim retstring As String
Do While Not (StreamReader.EOS)
'DoEvents
retstring = StreamReader.ReadText(-2) 'Read in 1 row
Stream_Write.writeText retstring & wrapTypeCRLF_Write
continue:
Loop
Stream_Write.SaveToFile (strCreateFile_Write), 2
'Contains BOM
Dim StreamTmp_Write As Object
If isRemoveBOM Then ' Remove BOM
Dim tmpFile_Write As String
tmpFile_Write = fileName_Write & "_temp"
strCreateTmpFile_Write = objFileSys.BuildPath(filePath_Write, tmpFile_Write)
Set StreamTmp_Write = CreateObject("ADODB.Stream")
With StreamTmp_Write
.Type = 1
.Open
.LoadFromFile (strCreateTmpFile_Write) ' Read in the tmp file With Binnary
.Position = 3 ' (BOM) Skip 3 bits
' Output target File with contents from the 4th bit by binnary.
Dim ws: Set ws = CreateObject("ADODB.Stream")
ws.Type = 1
ws.Open
ws.Write (.Read(-1))
ws.SaveToFile strCreateFile_Write, 2
End With
' Delete tmp File
Call CreateObject("Scripting.FileSystemObject").DeleteFile(strCreateTmpFile_Write)
End If
EXECEPTION:
If Err.Number <> 0 Then
MsgBox "ReadFileA2WriteFileBLineByLine " & GetMsg(LANGUAGE_KBN, 4) & Err.Description, vbExclamation
End If
'Clear StreamReader
StreamReader.Close
Set StreamReader = Nothing
'Clear Stream_Write
If Stream_Write Is Nothing Then
Else
Stream_Write.Close
Set Stream_Write = Nothing
End If
'Clear StreamTmp_Write
If StreamTmp_Write Is Nothing Then
Else
StreamTmp_Write.Close
Set StreamTmp_Write = Nothing
End If
End Function
'*************************************************
' openFile
'*************************************************
Sub openFile(applicationFilePath, targetFilePath)
Dim rc As Long
rc = Shell(applicationFilePath & " " & targetFilePath, vbNormalFocus)
If rc = 0 Then MsgBox GetMsg(LANGUAGE_KBN, 5)
End Sub
'*************************************************
' getMaxLine
'*************************************************
Function getMaxLine(fileNm) As Long
Dim FSO As Object, TargetFile As String
TargetFile = fileNm
If TargetFile = "False" Then Exit Function
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO.OpenTextFile(TargetFile, 8)
getMaxLine = .Line
.Close
End With
Set FSO = Nothing
End Function
' ********************************************************************************************
' Progress character string creation Process
' Ex ：Application.StatusBar = "Processing ..." & GetProgressString(counter, Max) & "＠" & param
' ********************************************************************************************
Public Function GetProgressString(current, max) As String
If current > max Then
MsgBox "<GetProgressString> Error : " & "current > max value NG", vbCritical, "Error Message"
Exit Function
End If
Dim progress As String
Dim rate As Long
' Calc %
rate = (current / max * 100) \ 10
' ■■■■■□□□□□
progress = String(rate, GetMsg(LANGUAGE_KBN, 6)) & String(10 - rate, GetMsg(LANGUAGE_KBN, 7))
GetProgressString = " " & progress & "[" & current & "/" & max & "]"
End Function
' ********************************************************************************************
' GetSystemLanguage
' ********************************************************************************************
Public Function GetSystemLanguage() As String
Dim buf As String * 256
'API
GetLocaleInfo LOCALE_SYSTEM_DEFAULT, LOCALE_SENGCOUNTRY, buf, 256
GetSystemLanguage = buf
End Function
'*************************************************
' SetKeyWordStyle
' Ex: SetKeyWordStyle( "ab", Range, RGB(255, 0, 0),2 ) 'Red
'*************************************************
Public Sub SetKeyWordStyleCom(stringWord, Range, fontColor, kbn)
Dim word_start As Integer
Dim word_Length As Integer
Dim strCellAll As String
Range.Select
strCellAll = Range.value
word_start = InStr(1, strCellAll, stringWord, vbTextCompare)
word_Length = Len(stringWord)
If kbn = 1 Then
SetKeyWordStyleLoop_All strCellAll, stringWord, word_start, word_Length, fontColor
ElseIf kbn = 2 Then
SetKeyWordStyleLoop_2 strCellAll, stringWord, word_start, word_Length, fontColor
Else
MsgBox "parameter 'kbn' wrong.", vbExclamation
End If
End Sub
'*************************************************
' SetKeyWordStyleComFree
' Ex: SetKeyWordStyle( "ab", Range, RGB(255, 0, 0),2 ) 'Red
' kbn : 0: ALL , 1: Font?Color, 2: Under-bar, 3: Bold, 4: CancelLine
' 12: 1+2, 13: 1+3, 14: 1+4, 23: 2+3 ,24: 2+4, 34: 3+4, ...
'*************************************************
Public Sub SetKeyWordStyleComFree(stringWord, Range, fontColor, kbn)
Dim word_start As Integer
Dim word_Length As Integer
Dim strCellAll As String
Range.Select
strCellAll = Range.value
word_start = InStr(1, strCellAll, stringWord, vbTextCompare)
word_Length = Len(stringWord)
If Trim(kbn) <> "" Then
SetKeyWordStyleLoop_Free kbn, strCellAll, stringWord, word_start, word_Length, fontColor
Else
MsgBox "parameter 'kbn' wrong. " & kbn, vbExclamation
End If
End Sub
'*************************************************
' SetKeyWordStyleLoop_Free
' Under-bar + Bold + Font?Color
' kbn : 0: ALL , 1: Font?Color, 2: Under-bar, 3: Bold, 4: CancelLine
' 12: 1+2, 13: 1+3, 14: 1+4, 23: 2+3 ,24: 2+4, 34: 3+4, ...
'************************************************
Private Sub SetKeyWordStyleLoop_Free(kbn, strCellAll, stringWord, word_start, word_Length, fontColor)
On Error GoTo EXECEPTION
word_start = InStr(word_start, strCellAll, stringWord, vbTextCompare)
If word_start <= 0 Then
Exit Sub
Else
With ActiveCell.Characters(Start:=word_start, Length:=word_Length).Font
If kbn = 0 Or InStr(1, CStr(kbn), "1") > 0 Then .Color = fontColor
If kbn = 0 Or InStr(1, CStr(kbn), "2") > 0 Then .Underline = xlUnderlineStyleSingle
If kbn = 0 Or InStr(1, CStr(kbn), "3") > 0 Then .Bold = True
If kbn = 0 Or InStr(1, CStr(kbn), "4") > 0 Then .Strikethrough = True
End With
SetKeyWordStyleLoop_Free kbn, strCellAll, stringWord, (word_start + word_Length), word_Length, fontColor
End If
EXECEPTION:
If Err.Number <> 0 Then
MsgBox "SetKeyWordStyleLoop_Free" & GetMsg(LANGUAGE_KBN, 4) & Err.Description & vbCrLf & _
"kbn=" & kbn & vbCrLf & _
"strCellAll=" & strCellAll & vbCrLf & _
"stringWord=" & stringWord & vbCrLf & _
"word_start=" & word_start & vbCrLf & _
"word_Length=" & word_Length & vbCrLf & _
"fontColor=" & fontColor, vbExclamation
End If
Err.Clear
End Sub
'*************************************************
' SetKeyWordStyleLoop_All
' Under-bar + Bold + Font?Color
'************************************************
Private Sub SetKeyWordStyleLoop_All(strCellAll, stringWord, word_start, word_Length, fontColor)
On Error GoTo EXECEPTION
word_start = InStr(word_start, strCellAll, stringWord, vbTextCompare)
If word_start <= 0 Then
Exit Sub
Else
With ActiveCell.Characters(Start:=word_start, Length:=word_Length).Font
.Bold = True
.Underline = xlUnderlineStyleSingle
.Color = fontColor
End With
SetKeyWordStyleLoop_All strCellAll, stringWord, (word_start + word_Length), word_Length, fontColor
End If
EXECEPTION:
If Err.Number <> 0 Then
MsgBox "SetKeyWordStyleLoop_All" & GetMsg(LANGUAGE_KBN, 4) & Err.Description & vbCrLf & _
"strCellAll=" & strCellAll & vbCrLf & _
"stringWord=" & stringWord & vbCrLf & _
"word_start=" & word_start & vbCrLf & _
"word_Length=" & word_Length & vbCrLf & _
"fontColor=" & fontColor, vbExclamation
End If
Err.Clear
End Sub
'*************************************************
' SetKeyWordStyleLoop_2
' Font?Color Only
'*************************************************
Private Sub SetKeyWordStyleLoop_2(strCellAll, stringWord, word_start, word_Length, fontColor)
On Error GoTo EXECEPTION
word_start = InStr(word_start, strCellAll, stringWord, vbTextCompare)
If word_start <= 0 Then
Exit Sub
Else
With ActiveCell.Characters(Start:=word_start, Length:=word_Length).Font
.Color = fontColor
End With
Call SetKeyWordStyleLoop_2(strCellAll, stringWord, (word_start + word_Length), word_Length, fontColor)
End If
EXECEPTION:
If Err.Number <> 0 Then
MsgBox "SetKeyWordStyleLoop_2" & GetMsg(LANGUAGE_KBN, 4) & Err.Description & vbCrLf & _
"strCellAll=" & strCellAll & vbCrLf & _
"stringWord=" & stringWord & vbCrLf & _
"word_start=" & word_start & vbCrLf & _
"word_Length=" & word_Length & vbCrLf & _
"fontColor=" & fontColor, vbExclamation
End If
Err.Clear
End Sub
''*************************************
'' Ex:
'' Call ShowUserFormCommonProcessing(False)
'' For index = 1 To 10000
'' Call SetUserFormCommonProcessing("test", "executing for " & index)
'' Next index
'' Call HideUserFormCommonProcessing
' Call ShowUserFormCommonProcessing(False)
' Call SetUserFormCommonProcessing("Info.", "executing for " & index)
' Call HideUserFormCommonProcessing
'*************************************
'* Show UserFormCommonProcessing
'*************************************
Public Sub ShowUserFormCommonProcessing(showModal As Boolean)
UserFormCommonProcessing.Show showModal
End Sub
'*************************************
'* Set UserFormCommonProcessing
'*************************************
Public Sub SetUserFormCommonProcessing(title As String, msg As String)
If Trim(title) = "" Then
title = "Now: "
End If
UserFormCommonProcessing.Caption = title
UserFormCommonProcessing.Label1.Caption = msg
UserFormCommonProcessing.Repaint
End Sub
'*************************************
'* Hide UserFormCommonProcessing
'*************************************
Public Sub HideUserFormCommonProcessing()
UserFormCommonProcessing.Hide
End Sub
'*************************************
'* Save ThisWorkbook (tool)
'*************************************
Public Sub SaveThisWorkbook(ByVal showDialog As Boolean)
If showDialog Then
Call ShowUserFormCommonProcessing(False)
Application.ScreenUpdating = False
Call SetUserFormCommonProcessing("Updatting.", " Saving...")
ThisWorkbook.Save
Application.ScreenUpdating = True
Call HideUserFormCommonProcessing
Else
ThisWorkbook.Save
End If
End Sub
'*************************************
'* Set Addin to True
'*************************************
Public Sub SetAddin2True()
'If Comm_ConfirmPwd = True Then
If ThisWorkbook.IsAddin = False Then
ThisWorkbook.IsAddin = True
Call SaveThisWorkbook(True)
End If
'End If
End Sub
'*************************************
'* Set Addin to False
'*************************************
Public Sub SetAddin2False()
If Comm_ConfirmPwd = True Then
If ThisWorkbook.IsAddin = True Then
ThisWorkbook.IsAddin = False
End If
End If
End Sub
'*************************************
'* execute CMD
'* ex: Call ExecuteCMD ( "cmd /c C:\output.txt" )
'*************************************
Public Sub ExecuteCMD(cmd As String)
Set ws = CreateObject("Wscript.Shell")
ws.Run cmd, vbHide
End Sub
'*************************************
' Search History Info
' setSearConditions
'*************************************
Public Sub setSearConditionsCom(strFindCon As String, HISTORY_Column_S As String, HISTORY_Column_E As String)
Dim startNo As Integer
For startNo = SEARCH_HISTORY_MAX_ROWS - 1 To 1 Step -1
Sheet4.Range(HISTORY_Column_S & startNo + 1).value = Sheet4.Range(HISTORY_Column_S & startNo).value
Sheet4.Range(HISTORY_Column_E & startNo + 1).value = Sheet4.Range(HISTORY_Column_E & startNo).value
Next startNo
Sheet4.Range(HISTORY_Column_S & "1").value = strFindCon
Sheet4.Range(HISTORY_Column_E & "1").value = Date & " " & time()
End Sub
'*******************************************************
'* Format Date to YYYYMMDD
'* return YYYYMMDD As Variant
'*******************************************************
Function YYYYMMDD(dt As Date) As Variant
If dt >= #3/1/1900# Then
YYYYMMDD = Format(dt, "yyyymmdd")
Else
YYYYMMDD = CVErr(xlErrValue)
End If
End Function
'***********************************************************************
'*
'* Use ： SplitComm(text,Atc,wResult)
'* Capability ： Store character string in one-dimensional arrangement for every element divided in a certain character.
'* Arguments :
'* text I: target string
'* Atc I: split char(1 ch only)
'* wResult O: arr
'*
'* Return
'* no
'*
'************************************************************************
Public Sub SplitComm(ByVal Text As String, ByVal Atc As String, wResult() As String)
Dim i, j, COUNT As Integer
COUNT = 0
i = 1
Do While 1
i = InStr(i, Text, Atc)
If i = 0 Then Exit Do
i = i + 1
COUNT = COUNT + 1
Loop
ReDim wResult(COUNT)
For i = 1 To COUNT
k = InStr(Text, Atc)
wResult(i) = left(Text, k - 1)
Text = Right(Text, Len(Text) - k - Len(Atc) + 1)
Next i
End Sub
'*************************************************************************
'*
'* Use： SplitRev(Text,Atc,wkText)
'* Capability： Dividing character string stored in one-dimensional arrangement in a certain character,
'* arrange in order and make it one character string (reverse Process of Split).
'* Arguments
'* text O: Convert ret string
'* Atc I: split char(1 ch only)
'* WkText I: arr
'*
'* Return
'* no
'*
'*************************************************************************
Public Sub SplitRev(Text As String, ByVal Atc As String, WkText() As String)
Dim i As Integer
Text = ""
For i = 1 To UBound(WkText)
Text = Text + WkText(i) + Atc
Next i
End Sub
'*************************************************************************
'*
'* Use： PicturesBatchInsert(rootFolder,targetColumn)
'* Capability： Pictures Batch Insert Sheet
'* Arguments
'* rootFolder
'* targetColumnNo 1 / 2 / ...
'*
'* Return
'* no
'* Ex : Call Comm_PicturesBatchInsert("C:\A_TimerTask", 2)
'*************************************************************************
Public Sub Comm_PicturesBatchInsert(ByVal rootFolder As String _
, Optional ByVal targetColumnNo As Integer = 2)
On Error GoTo EXECEPTION
Call ShowUserFormCommonProcessing(False)
Dim fs, f, f1, fc, i, consor
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getFolder(rootFolder)
Set fc = f.Files
i = 1
consor = 13.5 'A Cell Height
For Each f1 In fc
DoEvents
Cells(i, targetColumnNo).Select
Call SetUserFormCommonProcessing("Info.", "executing for " & f1.path)
With ActiveSheet.Pictures.Insert(f1.path)
.Select
Application.Run "TurnItSmaller"
consor = CInt(.Height / 13.5)
i = i + consor + 1
End With
Next
EXECEPTION:
If Err.Number <> 0 Then
MsgBox "Comm_PicturesBatchInsert" & GetMsg(LANGUAGE_KBN, 4) & Err.Description & vbCrLf & _
"rootFolder=" & rootFolder & vbCrLf & _
"targetColumnNo=" & targetColumnNo, vbExclamation
End If
Call HideUserFormCommonProcessing
End Sub
'*************************************************************************
'*
'* Use： GetStdOutMsgCMD( cmd )
'* Capability： Show CMD MSG
'* Arguments
'* cmd
'*
'* Return
'* StdOut.ReadAll MSG
'*
'*************************************************************************
Public Function GetStdOutMsgCMD(sCmd) As String
Dim WSH, Result As String, wExec As Object
On Error GoTo EXECEPTION
If Trim(sCmd) <> "" Then
Set WSH = CreateObject("WScript.Shell")
Set wExec = WSH.Exec("%ComSpec% /c " & sCmd)
Do While wExec.Status = 0
DoEvents
Loop
Result = wExec.StdOut.ReadAll
'MsgBox Result
GetStdOutMsgCMD = Result
Else
MsgBox "NG : CMD String is Null!!", vbCritical
End If
EXECEPTION:
Set wExec = Nothing
Set WSH = Nothing
End Function
'*************************************************************************
'*
'* Use： GetYYYYMMDD_WeekNo(Optional formt)
'* Capability： GetYYYYMMDD_WeekNo
'* Arguments
'* format : Default value = "yyyy/mm/dd"
'*
'* Return
'* YYYYMMDD_WeekNo
'*
'*************************************************************************
Public Function GetYYYYMMDD_WeekNo(Optional ByVal formt As String = "yyyy/mm/dd") As String
Dim todayWeek, dispWeekNo As String
todayWeek = WeekdayName(Weekday(Date))
dispWeekNo = Mid(todayWeek, 1, 1)
If LANGUAGE_KBN = LANGUAGE_CHN Then
dispWeekNo = Mid(todayWeek, 3, 1)
End If
GetYYYYMMDD_WeekNo = Format(Date, formt) & " (" & dispWeekNo & ")"
End Function
'*************************************************************************
'*
'* Use： Comm_GetFontName1_2(frmComFont As UserForm02ComFontSetting ,title As String, def_fontNm1 As String, def_fontNm2 As String)
'* Capability： Get FontName1 & 2
'* Arguments
'* frmComFont : UserForm02ComFontSetting
'* title : title of Form
'* def_fontNm1 : Default Font 1
'* def_fontNm2 : Default Font 2
'*
'* Return
'* none
'*
'*************************************************************************
Sub Comm_GetFontName1_2(ByRef frmComFont As UserForm02ComFontSetting _
, Optional ByVal title As String = "Font Settings" _
, Optional ByVal def_fontNm1 As String = "Times New Roman" _
, Optional ByVal def_fontNm2 As String = "Times New Roman")
Dim ret(2) As String
On Error GoTo EXECEPTION
frmComFont.Caption = title
frmComFont.TextBoxFNM1 = def_fontNm1
frmComFont.TextBoxFNM2 = def_fontNm2
frmComFont.Show vbModal
EXECEPTION:
If Err.Number <> 0 Then
MsgBox "Comm_GetFontName1_2 " & GetMsg(LANGUAGE_KBN, 4) & Err.Description, vbExclamation
frmComFont.Hide
Unload frmComFont
End If
End Sub
'*************************************************
' Comm_ConfirmPwd
'*************************************************
Public Function Comm_ConfirmPwd() As Boolean
Const ERR_MSG = " Wrong! No Authority !!! "
Const FLGBi = 3
Dim pwd, planInfo As String
pwd = Application.InputBox( _
prompt:="The Key is ?", Default:="***", title:=":::Confirm Authority:::", Type:=2)
If pwd = False Then
Comm_ConfirmPwd = False
ElseIf Trim(pwd) = "" Then
Comm_ConfirmPwd = False
Else
On Error GoTo EXECEPTION
If Int(Day(Date)) Mod 2 = 0 Then
If Int(Mid(pwd, 1, 1)) + Int(Mid(pwd, 6, 1)) = 10 _
And Int(Mid(pwd, 1, 1)) - Int(Mid(pwd, 6, 1)) = Comm_Get10NumberByXbit(FLGBi, 22) _
And Int(Mid(pwd, 2, 1)) + Int(Mid(pwd, 7, 1)) = 7 _
And Int(Mid(pwd, 2, 1)) - Int(Mid(pwd, 7, 1)) = 1 _
And Int(Mid(pwd, 3, 1)) + Int(Mid(pwd, 8, 1)) = 11 _
And Int(Mid(pwd, 3, 1)) - Int(Mid(pwd, 8, 1)) = 1 _
And Int(Mid(pwd, 4, 1)) + Int(Mid(pwd, 9, 1)) = 15 _
And Int(Mid(pwd, 4, 1)) - Int(Mid(pwd, 9, 1)) = 1 _
And Int(Mid(pwd, 5, 1)) + Int(Mid(pwd, 10, 1)) = 2 _
And Int(Mid(pwd, 5, 1)) - Int(Mid(pwd, 10, 1)) = -2 _
And Int(Mid(pwd, 1, 1)) + Int(Mid(pwd, 10, 1)) = 11 _
And Int(Mid(pwd, 1, 1)) - Int(Mid(pwd, 10, 1)) = 7 _
Then
Comm_ConfirmPwd = True
Else
MsgBox ERR_MSG, vbCritical, "Warning"
Comm_ConfirmPwd = False
End If
ElseIf Int(Day(Date)) Mod 2 = 1 Then
If Int(Mid(pwd, 1, 1)) + Int(Mid(pwd, 6, 1)) = 2 _
And Int(Mid(pwd, 1, 1)) - Int(Mid(pwd, 6, 1)) = -2 _
And Int(Mid(pwd, 2, 1)) + Int(Mid(pwd, 7, 1)) = 7 _
And Int(Mid(pwd, 2, 1)) - Int(Mid(pwd, 7, 1)) = -1 _
And Int(Mid(pwd, 3, 1)) + Int(Mid(pwd, 8, 1)) = 11 _
And Int(Mid(pwd, 3, 1)) - Int(Mid(pwd, 8, 1)) = -1 _
And Int(Mid(pwd, 4, 1)) + Int(Mid(pwd, 9, 1)) = 15 _
And Int(Mid(pwd, 4, 1)) - Int(Mid(pwd, 9, 1)) = -1 _
And Int(Mid(pwd, 5, 1)) + Int(Mid(pwd, 10, 1)) = Comm_Get10NumberByXbit(FLGBi, 101) _
And Int(Mid(pwd, 5, 1)) - Int(Mid(pwd, 10, 1)) = Comm_Get10NumberByXbit(FLGBi, 22) _
And Int(Mid(pwd, 1, 1)) + Int(Mid(pwd, 10, 1)) = 1 _
And Int(Mid(pwd, 1, 1)) - Int(Mid(pwd, 10, 1)) = -1 _
Then
Comm_ConfirmPwd = True
Else
MsgBox ERR_MSG, vbCritical, "Warning"
Comm_ConfirmPwd = False
End If
End If
End If
EXECEPTION:
If Err.Number <> 0 Then
MsgBox ERR_MSG, vbCritical, "Warning"
Err.Clear
End If
End Function
'*************************************************
' Comm_Get10NumberByXbit(i, 123)
'*************************************************
Public Function Comm_Get10NumberByXbit(ByVal intXbit As Integer, ByVal longVal As Long) As Long
Dim tmp, i, tmp1, j As Long
Dim str, strLen As String
str = longVal
strLen = Len(str)
For i = 1 To strLen
If i = 1 Then
tmp = CLng(Right(str, 1)) * 1 ' str.substring(strLen - 1, strLen) * 1;
Else
tmp1 = 1
For j = 1 To i - 1
tmp1 = tmp1 * intXbit
Next j
tmp = tmp + CLng(Mid(str, strLen - i + 1, 1)) * tmp1
End If
Next i
Comm_Get10NumberByXbit = tmp
End Function
'*************************************************
' https://hogehoge.tk/nihongo/による日本語→変換後のローマ字を変数代入とする場合
' 2019/11/13 add
'*************************************************
Public Function Comm_GetNewJavaParameter(ByVal str As String) As String
Dim strArr, i, tmp, ret
strArr = Split(str, " ")
For i = 0 To UBound(strArr)
tmp = strArr(i)
If i > 0 Then
tmp = UCase(Mid(tmp, 1, 1)) & Mid(tmp, 2, Len(tmp) - 1)
End If
ret = ret & tmp
Next i
Comm_GetNewJavaParameter = ret
End Function
'*************************************************
' https://hogehoge.tk/nihongo/による日本語→変換後のローマ字を変数代入とする場合
' 2019/11/14 add
'*************************************************
Public Function Comm_GetNewJavaParameter4Set(ByVal str As String) As String
Dim strArr, i, tmp, ret
strArr = Split(str, " ")
For i = 0 To UBound(strArr)
tmp = strArr(i)
tmp = UCase(Mid(tmp, 1, 1)) & Mid(tmp, 2, Len(tmp) - 1)
ret = ret & tmp
Next i
Comm_GetNewJavaParameter4Set = ret
End Function
