ソース PROGXLS01.VBS
'--------- Create FileSystemObject & Initial Setting--------------
Set objFS = CreateObject("Scripting.FileSystemObject")
strtemp1 = WScript.ScriptFullName
strtemp1 = (objFS.GetParentFolderName(strtemp1))
strtemp1 = (objFS.GetParentFolderName(strtemp1))
Folder2 = strtemp1 & "\input\"
Folder3 = strtemp1 & "\omsg\"
Folder4 = strtemp1 & "\send\"
'MsgBox("Folder2 = " & Folder2)
'MsgBox("Folder3 = " & Folder3)
'MsgBox("Folder4 = " & Folder4)
TimeCtr = 0
'--------------- Create Excel Object -----------------------------
Dim Excel_Obj
Dim xls_path
xls_path = Folder2 & "indata.xls"
'-----------------------------------------------------------------
Set Excel_Obj = WScript.CreateObject("Excel.Application")
'警告が出ないように設定
Excel_Obj.Application.DisplayAlerts = False
'Excel_Obj.Visible = True
Excel_Obj.Visible = False
Dim In_Xls
Set In_Xls = Excel_Obj.WorkBooks.Open(xls_path)
' For sheet_no = 0 To 0
' -----------------------------------------------------------------
ErrMsg = "" 'ErrMsg はMessageが入っているか、nullかによりErrSwitchを兼ねる
sharpsw = 0 '##〜## 有無Switch
gtltsw = 0 '<<〜>> 有無Switch
errsw = 0 '##〜##や<<〜>>の指定ミスの有無Switch
TimeCtr = 0
'------------------------------------------------------------------
'Excel の第1行をNULLまで読み込み
Dim members(100)
Dim members2(100)
Dim buff
Dim j
Dim k
k = 1
buff = "init"
j = 0
Do While buff <> ""
buff = Excel_Obj.Cells(k,j+1).Value
members(j) = buff
If (buff <> "") then
If (Left(buff,2) = "##" and Right(buff,2) = "##") then
sharpsw = sharpsw + 1
ElseIf (Left(buff,2) = "<<" and Right(buff,2) = ">>") then
gtltsw = gtltsw + 1
else
errsw = errsw + 1
End If
j = j + 1
End If
Loop
n = j
'-------------------------------------------------------------------
'エラー表示
If errsw <> 0 then
ErrMsg ="第1行目の##〜## や <<〜>> の指定が間違っています"
Else
If sharpsw <> 0 then
If gtltsw <> 0 then
ErrMsg ="第1行目に##〜## と <<〜>> が混在しています"
End If
Else
If gtltsw = 0 then
ErrMsg ="第1行目の##〜## や <<〜>> が間違っています"
End If
End If
End If
'------------------------------------------------------------------
'(sharpsw <> 0)の場合、Excel の第2行と第3行を読み込み
If ((errsw = 0) and (sharpsw <> 0) and (gtltsw = 0)) then
' まず2行目
k = k + 1
For i = 0 To j
buff = Excel_Obj.Cells(k,i+1).Value
members2(i) = buff
Next
' 次に3行目
k = k + 1
i = 0
buff="init"
Do While buff <> ""
buff = Excel_Obj.Cells(k,i+1).Value
members(j) = buff
If (Left(buff,2) = "<<" and Right(buff,2) = ">>") then
gtltsw = gtltsw + 1
ElseIf (buff <> "")then
errsw = errsw + 1
ErrMsg ="第3行目の<<〜>> の指定が間違っています"
Exit Do
End If
i = i + 1
j = j + 1
Loop
'第1行目に有効な##〜##、第3行目有効な<<〜>>があり
Else
n = 0
'第1行目に##〜##なし
End If
'------------------------------------------------------------------
'##〜##、<<〜>> のエラーがあればMsgを出して終了します。
If ErrMsg = "" then
EndSwitch = 1
Do While EndSwitch <> 0
EndSwitch = 0 '---O:終り、0以外:終わりでない---
k = k + 1
For i = 1 To j
buff = Excel_Obj.Cells(k,i).Value
members2(i + n - 1) = buff
If buff <> "" Then
EndSwitch = EndSwitch + 1
End If
Next
'ここまで来れば、errsw = 0、sharpsw = 0、gtltsw <> 0
If EndSwitch <> 0 Then
TimeCtr = TimeCtr + 1
OutFileName = "EDI_PRO_MAIL_N" & Right(("000000" & TimeCtr),7) & ".txt"
Set objTextR = objFS.OpenTextFile(Folder3 & "Original_Msg.txt")
Set objTextW = objFS.CreateTextFile(Folder4 & OutFileName)
Do While objTextR.AtEndOfStream <> True
myStr = objTextR.Readline
For m = LBound(members) To UBound(members)
repStr = members2(m)
Set objRE = New RegExp
objRE.Pattern = members(m)
objRE.IgnoreCase = Faulse
objRE.Global = True
newStr = objRE.Replace(myStr,repStr)
myStr = newStr
Next
objTextW.WriteLine(myStr)
Loop
objTextR.Close
objTextW.Close
End If
Loop
Excel_Obj.Quit
'-------------------------------------------------------------------
'---以下を生かせばMailConnect送信タスクを自動起動して送信します-----
'MsgBox("以下を生かせばMailConnect送信タスクを自動起動して送信します")
'Dim WSHShell
'Set WSHShell = WScript.CreateObject("WScript.Shell")
'WSHShell.Run("""C:\Program Files\Internet_EDI_Pro\PROGRAM\EDI_Send_MailConnect.exe"" mcj0001/s,1,True")
Else
MsgBox(ErrMsg)
End If
Excel_Obj.Quit
MsgBox("終了します")
E-mail : webmaster@global.co.jp Copyright (C) Global Network Ltd.1995-2005, All Rights Reserved.
本ホームページに掲載の会社名および製品名は各社の登録商標または商標です。 |