ソース 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 の第１行を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 ="第１行目の##〜## や <<〜>> の指定が間違っています"
  Else
   If sharpsw <> 0 then
      If gtltsw <> 0 then
         ErrMsg ="第１行目に##〜## と <<〜>> が混在しています"
      End If
     Else
      If gtltsw = 0 then
         ErrMsg ="第１行目の##〜## や <<〜>> が間違っています"
      End If
   End If
End If


'------------------------------------------------------------------
'(sharpsw <> 0)の場合、Excel の第2行と第3行を読み込み

If ((errsw = 0) and (sharpsw <> 0) and (gtltsw = 0)) then

' まず２行目

  k = k + 1
         For i = 0 To j
             buff = Excel_Obj.Cells(k,i+1).Value
             members2(i) = buff
         Next

' 次に３行目
  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 ="第３行目の<<〜>> の指定が間違っています"
                    Exit Do
           End If
         i = i + 1
         j = j + 1
      Loop
     '第１行目に有効な##〜##、第３行目有効な<<〜>>があり
   Else
      n = 0
     '第１行目に##〜##なし

  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("終了します")