2009/02/28

VBScriptで日付処理 そにょ3・・・


日付の処理だけ、某Format関数を模してみた。・・・あくまで暫定版。
限られた指定方法で、要素を並べ替えられる程度しか機能しないが、
新たに曜日を要素として取得可能になっている。

書式)
   iDTw({tDate}, {tNow}, {sFormat}, {dSplitter}, {tSplitter}, {dtSeparator}, Control)    

{tDate} 日付情報(時間を含まない) Date()ないし等価
{tNow} 時間情報 Now()ないし等価
{sFormat} OutPutFormat (Default - "Y/M/D H:N:S")
{dSplitter} DateSplitString (Normal - "/")
{tSplitter} TimeSplitString (Normal - ":")
{dtSeparater} Date/Time SepaleteString (Default - " ")
Control 0 文字列 / 1 配列化 (Default - 0)


{sFormat}に対し、半角英大文字の、"YMD" で 日付部分を
"W"で曜日を "HN" で 時分を "S" で秒を、それぞれ任意の位置に配置できます。

★オマケ
   "S HNS YMD [W] HN"    
のようなデタラメな呼び出しも可能^_^;


曜日取得処理 GetWeekDay
装飾も含めて好きなように曜日文字列を取得したいが為だけに作成したモノ。
単なる曜日取得と異なり、逆引き検索や対応データへの変換など、
パラメータの適用次第で応用の幅を広げられるようになっている。
また、iDTw を使う場合、変数 strWeekday をPublicで宣言し、
この関数(の結果)を事前に代入しておくコトが必須となる。
なんだか、海外のライブラリ使ってるみたいで使いデ悪くて、お蔵入りさせてたブツではあるがw

書式)
   GetWeekday(YMD, wFormat, WeekdaysString, nDepth)

   YMD - 日付を指定 (Date関数と等価値)
   wFormat - 戻り値に対する装飾を指定 例) " [ W ] "
   WeekdaysString - 曜日のリストを入力 ・・・リストの構成はサンプル参照のことw
   nDepth - リスト中の次元の深さを指定 (0~)


lArray や inArrays は、これらの為に用意したモノとも云える・・・

    '***** ↓↓↓ScriptTitle↓↓↓ *********************************************************     
'GetWeekDay & iDTw & lArray & inArrays
'- Created by LazwardFox -

' スクリプトライブラリの一部

' Release 20090228 1639

'***** ↓↓↓ Decralations ↓↓↓ ******************************************************
Const strWeekdays = "1:月:MON:Mon:Monday,2:火:TUE:Tue:Tuesday,3:水:WED:Wed:Wednesday,4:木:THU:Thu:Thursday,5:金:FRI:Fri:Friday,6:土:SAT:Sat:Saturday,7:日:SUN:Sun:Sunday"
Const vbWq = """"
Public strWeekday

Dim varNow, VarDate, sDa, sDb, sDc, sDd, sDe, testResult


'***** ↓↓↓Main(Test)Routine↓↓↓ ***************************************************
varNow = Now()
varDate = Date()

'Function GetWeekday(YMD,wFormat,WeekdaysString,nDepth)
strWeekday = GetWeekday(varDate,,strWeekdays,3)

sDa = iDTw(varDate,varNow,"YMD [W] HN","/",":",,0) '文字列テスト
sDb = iDTw(varDate,varNow,"YMD",,,,0) '文字列テスト
sDc = iDTw(,,"YMD*[W]*HNS",,,"*",1) '配列テスト
sDd = iDTw(,,"YMDWHNS","",""," ",0) 'スプリッタ無しテスト
sDe = iDTw(,,"YMD [ W ] HNS","",""," ",0) 'スプリッタ無しテスト

testResult = "iDTw(" & "varDate,varNow," & vbWq & "YMD [W] HN" & vbWq & "," & vbWq & "/" & vbWq & "," & vbWq & ":" & vbWq & ",,0) - <String YMD[W]HN> - >>> " & sDa & vbTab & vbCrLf _
& "iDTw(" & "varDate,varNow," & vbWq & "YMD" & vbWq & ",,,,0) - <String YMD Only> - >>> " & sDb & vbTab & vbCrLf _
& "iDTw(" & ",," & vbWq & "YMD*[W]*HNS" & vbWq & ",,," & vbWq & "*" & vbWq & ",1) - <Array iDTw(1)> - >>> " & sDc(1) & vbTab & vbCrLf _
& "iDTw(" & ",," & vbWq & "YMDWHNS" & vbWq & "," & vbWq & vbWq & "," & vbWq & vbWq & "," & vbWq & " " & vbWq & ",0) - <String NoSplitter> - >>> " & sDd & vbTab & vbCrLf _
& "iDTw(" & ",," & vbWq & "YMD [ W ] HNS" & vbWq & "," & vbWq & vbWq & "," & vbWq & vbWq & "," & vbWq & " " & vbWq & ",0) - <String Full> - >>>" & sDe & vbTab

msgbox testResult,,"Test"

'***** ↓↓↓Functions↓↓↓ ***********************************************************
'------------------------------------
'GetWeekDay - 曜日文字列配列化及び取得
'- Created by LazwardFox -

' Update 20090228 1403 inArraysの新版向けに変更
' Update 20090228 0855 配列化関数をinArraysに差し替え
' Update 20090223 1544
' Release 20090223
' Develop 20090223 1018

' GetWeekday(
' YMD - 日付を指定 (Date関数と等価値)
' ,wFormat - 戻り値に対する装飾を指定 例) " [ W ] "
' ,WeekdaysString - 曜日のリストを入力
' ,nDepth - リスト中の次元の深さを指定 (0~)
' )

Function GetWeekday(YMD,wFormat,WeekdaysString,nDepth)
Dim arsWeekdays,arWeekdays
If TypeName(WeekdaysString) = "Error" Then
ElseIf VarType(arWeekdays) = vbArray Then
Else
inArrays WeekdaysString,",:",arWeekdays
End If
If TypeName(wFormat) = "Error" Then
GetWeekday = arWeekdays(Weekday(YMD,2) - 1)(nDepth)
Else
GetWeekday = Replace(wFormat,"W",arWeekdays(Weekday(YMD,2) - 1)(nDepth))
End If
End Function

'------------------------------------
'iDTw - 日時(曜日)文字列 ないし 日/曜日/時 配列取得 for VBScript
'- Created by LazwardFox -

' Update 20090228 1403 inArraysの新版向けに変更
' Release 20090223 1413 iDTから改良

' Control以外のパラメータを省略可

' iDTw (
' {tDate}日付情報(時間を含まない)Date()ないし等価
' ,{tNow}時間情報Now()ないし等価
' ,{sFormat}OutPutFormat(Default - "YMD HNS")
' ,{dSplitter}DateSplitString (Normal - "/")
' ,{tSplitter}TimeSplitString (Normal - ":")
' ,{dtSeparater}Date/Time SepaleteString (Default - " ")
' ,Control0 文字列 / 1 配列化 (Default - 0)
' )

'記述例) iDTw(,,,,,0)- 現在の年月日/時分秒を配列で取得
'iDTw(,,"YMD*W*HNS",,"*",0)- 現在の年月日/曜日/時分秒を配列で取得

'曜日を取得する場合、事前に 変数strWeekdayをPublicで宣言し、
'GetWeekDay を実行、代入しておく必要があります。

Function iDTw(tDate,tNow,sFormat,dSplitter,tSplitter,dtSeparator,Control)
Dim nS, strHNS, arHNS, iHNS, valHNS'Update 20090223 0135

If TypeName(tDate) = "Error" Then
tDate = Date()
End If
If TypeName(tNow) = "Error" Then
tNow = Now()
End If
If TypeName(dSplitter) = "Error" Then
dSplitter = "/"
End If
If TypeName(tSplitter) = "Error" Then
tSplitter = ":"
End If
If TypeName(Control) = "Error" Then
Control = 0
End If
If TypeName(dtSeparator) = "Error" Then
If Control = 1 Then
dtSeparator = "*"
Else
dtSeparator = " "
End If
End If

strS = Split(CStr(FormatDateTime(tNow,3)),":")(2) 'Update 20090223 0951
strHN = FormatDateTime(tNow,4) 'Update 20090223 1428
strHNS = FormatDateTime(tNow,4) & tSplitter & strS 'Update 20090223 0951

If TypeName(sFormat) = "Error" Then
sFormat = "YMD" & dtSeparator & "HNS"
End If

If dSplitter = "/" Then
Else
tDate = Replace(tDate,"/",dSplitter)
End If
If tSplitter = ":" Then
Else
strHNS = Replace(strHNS,":",tSplitter)
End If

sFormat = Replace(sFormat,"YMD",tDate)
sFormat = Replace(sFormat,"HNS",strHNS)
sFormat = Replace(sFormat,"HN",strHN)
sFormat = Replace(sFormat,"S",strS)

If TypeName(sFormat) = "Error" Then
Else
wExist = Instr(1,sFormat,"W",1)
If wExist = 0 Then
Else
sFormat = Replace(sFormat,"W",strWeekday)
End If
End If
If Control = 0 Then
iDTw = sFormat
Else
iDTw = Split(sFormat,dtSeparator)
End If
End Function


'------------------------------------
'lArray - 文字列を1文字ずつバラし、配列として返す
'- Created by LazwardFox -

' Release 20090228 1246

' lArray(
' strLetters - 分解したい文字列
' ,rArray - 戻り値が代入されます。任意の変数名を指定
' )

Function lArray(strLetters, rArray)
Dim Pc, rLetters()
Set objADO = CreateObject("ADODB.Stream")
With objADO
.Type = 2
.Open
.WriteText strLetters
Pc = 0
.Position = 0
Do Until .EOS
ReDim Preserve rLetters(Pc)
rLetters(Pc) = .ReadText(1)
Pc = Pc + 1
Loop
End With
rArray = rLetters
objADO.Close
Set objADO = Nothing
End Function

'------------------------------------
'inArrays - 多次元配列構築
'- Created by LazwardFox -

'配列 及び 文字列から、区切り文字を指定して多重配列を作成し返す。

' inArrays(
' tSources - 区切り文字を含む文字列 ないし、それらで構成された配列
' ,strLimitters - 区切り文字を順番に並べた文字列を指定
' ,arReturn - 戻り値が代入されます。
' )

' Update 20090228 1248 strLimitters指定に、区切り文字 ~(チルダ)不要に。
' Update 20090228 0833 配列のほか、文字列もソースに適用可能に。
' Update 20090223 0917

Function inArrays(tSources, strLimitters, arReturn)
Dim arSources, arLimitters, iLimitter, arInArrays, iSource, Pc
arSources = tSources
lArray strLimitters, arLimitters '< Update 20090228 1248
For Each iLimitter In arLimitters
If VarType(arSources) = 8 Then
arInArrays = Split(arSources,iLimitter)
Else
Pc = 0
ReDim arInArrays(0)
For Each iSource in arSources
ReDim Preserve arInArrays(Pc)
arInArrays(Pc) = Split(iSource,iLimitter)
Pc = Pc + 1
Next
End If
arSources = arInArrays
arInArrays = Null
Next
arReturn = arSources
End Function


更に自由度の高い書式指定機能付スクリプトを作成するので、この分も要らなくなったりするww

似たようなものばかりでアレなんだケド、色んなデータへのアプローチの仕方があるというコトで、
なにかしら参考になっていればいいなぁ・・・(´ヘ`;)
<そのまま使える スクリプト 年月日 曜日 時分秒 文字列 配列変数 取得 Format Text FormatDateTime>

0 件のコメント:

コメントを投稿