Dim FileSystem
' ******************************************************' 初期化' ******************************************************
Function FsInit()
If Not IsObject(FileSystem) Then
Set FileSystem = CreateObject("Scripting.FileSystemObject")
End If
End Function
' ******************************************************' ファイルの読み込みオープン' ******************************************************
Function FsReadOpen(strFileName)
Call FsInit
Set FsReadOpen = FileSystem.OpenTextFile(strFileName, 1)
End Function
' ******************************************************' ファイルの書き込みオープン' ******************************************************
Function FsWriteOpen(strFileName)
Call FsInit
Set FsWriteOpen = FileSystem.CreateTextFile(strFileName, 1)
End Function
' ******************************************************' クローズ' ******************************************************
Function FsClose(fp)
fp.Close
Set fp = Nothing
End Function
' ******************************************************' EOF' ******************************************************
Function FsEof(fp)
FsEof = fp.AtEndOfStream
End Function
' ******************************************************' ファイルの複写' ******************************************************
Function FsCopy(strFrom, strTo)
Call FsInit
FileSystem.CopyFile strFrom, strTo, True
End Function
' ******************************************************' テンポラリディレクトリの取得' ******************************************************
Function FsGetTmp()
Call FsInit
FsGetTmp = FileSystem.GetSpecialFolder(2)
End Function
' ******************************************************' 存在チェック' ******************************************************
Function FsExist(Spec, nType)
Call FsInit
Select Case nType
Case 0 ' ファイル
FsExist = FileSystem.FileExists(Spec)
Case 1 ' ディレクトリ
FsExist = FileSystem.FolderExists(Spec)
Case 2 ' ドライブ
FsExist = FileSystem.DriveExists(Spec)
End Select
End Function
' ******************************************************' ディレクトリ作成' ******************************************************
Function FsMkDir(Spec)
Call FsInit
Dim i
Dim strParent
strParent = Spec
On Error Resume Next
FileSystem.CreateFolder Spec
On Error GoTo 0
If FsExist(Spec, 1) Then
Exit Function
End If
strParent = FileSystem.GetParentFolderName(Spec)
If strParent = "" Then
Exit Function
End If
Do While Not FsExist(strParent, 1)
strParent = FileSystem.GetParentFolderName(strParent)
If strParent = "" Then
Exit Do
End If
On Error Resume Next
FileSystem.CreateFolder strParent
On Error GoTo 0
strParent = Spec
On Error Resume Next
FileSystem.CreateFolder strParent
On Error GoTo 0
Loop
End Function
' ******************************************************' ディレクトリ削除' ******************************************************
Function FsRmDir(Spec, Force)
Call FsInit
On Error Resume Next
FileSystem.DeleteFolder Spec, Force
On Error GoTo 0
End Function
' ******************************************************' カレントディレクトリ取得' ******************************************************
Function FsGetCurDir()
Call FsInit
FsGetCurDir = FileSystem.GetAbsolutePathName(".")
End Function
' ******************************************************' 使用されていないドライブを取得' ******************************************************
Function FsGetFreeDrive(nType)
Call FsInit
Dim i
Dim TargetDrive
If nType = 0 Then
For i = &H44 To &H5A
On Error Resume Next
Set TargetDrive = FileSystem.GetDrive(Chr(i) & ":")
If Err.Number <> 0 Then
FsGetFreeDrive = Chr(i) & ":"
Exit Function
End If
Next
Else
For i = &H5A To &H44 Step -1
On Error Resume Next
Set TargetDrive = FileSystem.GetDrive(Chr(i) & ":")
If Err.Number <> 0 Then
FsGetFreeDrive = Chr(i) & ":"
Exit Function
End If
Next
End If
End Function
' ******************************************************' ファイルの削除' ******************************************************
Function FsDeleteFile(TargetFile)
Call FsInit
Call FileSystem.DeleteFile(TargetFile, True)
End Function
excel.vbs
Dim ExcelApp
Const xlContinuous = 1
Const xlDash = -4115
Const xlDashDot = 4
Const xlDashDotDot = 5
Const xlDot = -4118
Const xlDouble = -4119
Const xlSlantDashDot = 13
Const xlLineStyleNone = -4142
Const xlHairline = 1
Const xlMedium = -4138
Const xlThick = 4
Const xlThin = 2
Const xlInsideHorizontal = 12
Const xlInsideVertical = 11
Const xlDiagonalDown = 5
Const xlDiagonalUp = 6
Const xlEdgeBottom = 9
Const xlEdgeLeft = 7
Const xlEdgeRight = 10
Const xlEdgeTop = 8
Const xlAutomatic = -4105
Const xlMaximized = -4137
Const xlMinimized = -4140
Const xlNormal = -4143
' ******************************************************' Excel 実行 ( NT5.0 以上 )' ******************************************************
Function ExcelLoad(strPath)
Dim WSH
Set WSH = CreateObject("WScript.Shell")
Call WSH.Run( "RunDLL32.EXE shell32.dll,ShellExec_RunDLL " & _
strPath )
' "RunDLL32.EXE url.dll,FileProtocolHandler "
End Function
' ******************************************************' オブジェクト作成' ******************************************************
Function ExcelInit()
If Not IsObject(ExcelApp) Then
Set ExcelApp = CreateObject("Excel.Application")
End If
End Function
' ******************************************************' ブックを開く(Workbookを返す)' ******************************************************
Function ExcelOpen(strPath)
ExcelInit
Set ExcelOpen = ExcelApp.Workbooks.Open(strPath)
' アクティブなウィンドウを最大化
ExcelApp.ActiveWindow.WindowState = 2
End Function
' ******************************************************' 表示状態の変更' ******************************************************
Function ExcelVisible(bFlg)
ExcelInit
ExcelApp.Visible = bFlg
End Function
' ******************************************************' 終了' ******************************************************
Function ExcelQuit(WorkBook)
If TypeName(WorkBook) = "Workbook" Then
' 保存した事にする
WorkBook.Saved = True
End If
If IsObject(ExcelApp) Then
ExcelApp.Quit
Set ExcelApp = Nothing
End If
ExcelApp = ""
End Function
' ******************************************************' シート名によるシート選択' ******************************************************
Function ExcelSelectSheet(MyBook, strSheetName)
MyBook.Sheets(strSheetName).Select
End Function
' ******************************************************' 番号よるシート選択' ******************************************************
Function ExcelSelectSheetByNo(MyBook, No)
MyBook.Sheets(No).Select
End Function
' ******************************************************' シート名によるシート複写' ******************************************************
Function ExcelCopySheet(MyBook, strSheetName, strNewSheetName)
MyBook.Sheets(strSheetName).Copy (MyBook.Sheets(strSheetName))
MyBook.ActiveSheet.Name = strNewSheetName
End Function
' ******************************************************' シート名によるシート名変更' ******************************************************
Function ExcelRenameSheet(MyBook, strSheetName, strNewSheetName)
MyBook.Sheets(strSheetName).Name = strNewSheetName
End Function
' ******************************************************' 上書き保存' ******************************************************
Function ExcelSave(MyBook)
MyBook.Save
End Function
' ******************************************************' 名前を付けて保存' ******************************************************
Function ExcelSaveAs(MyBook, strFileName)
MyBook.SaveAs strFileName
End Function
' ******************************************************' セルへのデータセット' ******************************************************
Function ExcelSetCell(MyBook, strSheetName, x, y, Data)
MyBook.Sheets(strSheetName).Cells(y, x) = Data
End Function
' ******************************************************' シートの数' ******************************************************
Function ExcelGetSheetCount(MyBook)
ExcelGetSheetCount = MyBook.Sheets.Count
End Function
' ******************************************************' 範囲選択' ******************************************************
Function ExcelRange(MyBook, strSheetName, nX1, nY1, nX2, nY2 )
Dim Sheet,strRange
Set Sheet = MyBook.Sheets(strSheetName)
Sheet.Select
strRange = Chr(Asc("A") + nX1 - 1) & nY1 & ":"
strRange = strRange & Chr(Asc("A") + nX2 - 1) & nY2
Sheet.Range(strRange).Select
End Function
' ******************************************************' 範囲の上に罫線' ******************************************************
Function ExcelLine( nLineType, nWeight )
With ExcelApp.Selection.Borders(xlEdgeTop)
.LineStyle = nLineType
.ColorIndex = xlAutomatic
.Weight = nWeight
End With
End Function
' ******************************************************' 範囲に罫線' ******************************************************
Function ExcelBox( nLineType, nWeight )
With ExcelApp.Selection.Borders(xlEdgeTop)
.LineStyle = nLineType
.ColorIndex = xlAutomatic
.Weight = nWeight
End With
With ExcelApp.Selection.Borders(xlEdgeLeft)
.LineStyle = nLineType
.ColorIndex = xlAutomatic
.Weight = nWeight
End With
With ExcelApp.Selection.Borders(xlEdgeRight)
.LineStyle = nLineType
.ColorIndex = xlAutomatic
.Weight = nWeight
End With
With ExcelApp.Selection.Borders(xlEdgeBottom)
.LineStyle = nLineType
.ColorIndex = xlAutomatic
.Weight = nWeight
End With
End Function
' ******************************************************' 範囲内の罫線を全てクリア' ******************************************************
Function ClearBox( )
With ExcelApp.Selection.Borders(xlEdgeTop)
.LineStyle = xlLineStyleNone
End With
With ExcelApp.Selection.Borders(xlEdgeLeft)
.LineStyle = xlLineStyleNone
End With
With ExcelApp.Selection.Borders(xlEdgeRight)
.LineStyle = xlLineStyleNone
End With
With ExcelApp.Selection.Borders(xlEdgeBottom)
.LineStyle = xlLineStyleNone
End With
With ExcelApp.Selection.Borders(xlInsideHorizontal)
.LineStyle = xlLineStyleNone
End With
With ExcelApp.Selection.Borders(xlInsideVertical)
.LineStyle = xlLineStyleNone
End With
End Function
' ******************************************************' 範囲内の内部罫線のみクリア' ******************************************************
Function ClearInner( )
With ExcelApp.Selection.Borders(xlInsideHorizontal)
.LineStyle = xlLineStyleNone
End With
With ExcelApp.Selection.Borders(xlInsideVertical)
.LineStyle = xlLineStyleNone
End With
End Function
' ******************************************************' 範囲内に罫線' ******************************************************
Function ExcelInnerH( nLineType, nWeight )
With ExcelApp.Selection.Borders(xlInsideHorizontal)
.LineStyle = nLineType
.ColorIndex = xlAutomatic
.Weight = nWeight
End With
End Function
' ******************************************************' 範囲内に罫線' ******************************************************
Function ExcelInnerV( nLineType, nWeight )
With ExcelApp.Selection.Borders(xlInsideVertical)
.LineStyle = nLineType
.ColorIndex = xlAutomatic
.Weight = nWeight
End With
End Function
' ******************************************************' Excelウィンドウ内で可能な限り大きく表示' ******************************************************
Function ExcelFitInExcel( )
With ExcelApp.ActiveWindow
.WindowState = xlNormal
.Top = 1
.Left = 1
.Height = ExcelApp.UsableHeight
.Width = ExcelApp.UsableWidth
End With
End Function
' ******************************************************' Excelウィンドウ内で最大化' ******************************************************
Function ExcelMaximizedInExcel( )
With ExcelApp.ActiveWindow
.WindowState = xlMaximized
End With
End Function
' ******************************************************' 指定行の高さを取得' ******************************************************
Function ExcelGetRowHeight(MyBook, strSheetName, row)
ExcelGetRowHeight = _
MyBook.Sheets(strSheetName).Rows(row).RowHeight
End Function
' ******************************************************' 指定行の高さを設定' ******************************************************
Function ExcelSetRowHeight(MyBook, strSheetName, row, Height)
MyBook.Sheets(strSheetName).Rows(row).RowHeight = _
Height
End Function
' ******************************************************' 指定列の幅を取得' ******************************************************
Function ExcelGetColumnWidth(MyBook, strSheetName, column)
Dim strColumn
strColumn = Chr(Asc("A") + column - 1)
ExcelGetColumnWidth = _
MyBook.Sheets(strSheetName).Columns(strColumn).ColumnWidth
End Function
' ******************************************************' 指定列の幅を設定' ******************************************************
Function ExcelSetColumnWidth(MyBook, strSheetName, column, Width)
Dim strColumn
strColumn = Chr(Asc("A") + column - 1)
MyBook.Sheets(strSheetName).Columns(strColumn).ColumnWidth = _
Width
End Function
' ******************************************************' シート一覧をコンボ(リスト)ボックスに設定' ******************************************************
Function ExcelSheetList(MyBook, strName)
document.all(strName).options.length = 0
For i = 1 to ExcelGetSheetCount(MyBook)
document.all(strName).options.length = i
document.all(strName).options(i-1).value = MyBook.sheets(i).name
document.all(strName).options(i-1).text = MyBook.sheets(i).name
Next
End Function
client.vbs
' **********************************************************' エクセルブックによるレポート' **********************************************************
function ExcelOut()
Dim SrcFileName
Dim Today, DestFileName
Dim MyBook, Table, MaxRow, PosX, PosY
Dim WSH,strCommand
' ソースファイル名
SrcFileName = parent.Excel.document.all.item("Excel").value
if Trim(SrcFileName) = "" then
alert("エクセルブックを選択して下さい ")
parent.Excel.document.all.item("Excel").focus
exit function
end if
'ターゲットファイル名 オリジナルファイル名_日付.xls
Today = Replace(Date(),"/","")
DestFileName = Replace(LCase(SrcFileName), ".xls", "" ) & "_" & Today & ".xls"
on error resume next
Call FsCopy( SrcFileName, DestFileName ) ' ファイルコピー
if err.Number <> 0 then
alert err.Description
exit function
end if
on error goto 0
Set MyBook = ExcelOpen( DestFileName ) ' オープン
Call ExcelVisible(false) ' Excelは非表示
Call ExcelSelectSheet( MyBook, "Sheet1" ) ' シート選択
Set Table = document.all.item( "data" )
MaxRow = Table.rows.length
' データ出力開始----------------------------------------
for PosY = 1 to MaxRow-1
' 商品分類
Call ExcelSetCell( _
MyBook, "Sheet1", _
1, PosY, _
Table.rows(PosY).cells(0).innerText )
' 名称
Call ExcelSetCell( _
MyBook, "Sheet1", _
2, PosY, _
Table.rows(PosY).cells(1).innerText )
next
' データ出力終了----------------------------------------
Call ExcelSave( MyBook ) '保存
Call ExcelQuit( MyBook ) 'クローズ
ExcelLoad(DestFileName)
end function
excelctl.htm
<SCRIPT language="VBScript" src="excel.vbs"></SCRIPT>
<SCRIPT language="VBScript">
Dim MyBook
' ************************************************' 開く' ************************************************
function XlsOpen()
Target = document.all("Excel").value
if Trim(Target) = "" then
alert("Excel ブックを選択して下さい ")
Exit Function
end if
Set MyBook = ExcelOpen( Target )
Call ExcelVisible( true )
if ExcelApp.WindowState <> xlNormal then
ExcelApp.WindowState = xlNormal
end if
ExcelApp.Left = 1
ExcelApp.Top = 1
ExcelApp.Width = ((screen.width / 2) * 72) / screen.deviceXDPI
ExcelApp.Height = ((screen.height - 32) * 72) / screen.deviceYDPI
Dim Group
For Each objElement In document.all
on error resume next
Group = objElement.group
if Err.Number = 0 then
if objElement.group = 1 then
objElement.disabled = True
end if
if objElement.group = 2 then
objElement.disabled = False
end if
end if
on error goto 0
Next
Call XlsSheetList()
Call XlsRange()
end function
' ************************************************' 終了' ************************************************
function XlsQuit()
Dim Group
For Each objElement In document.all
on error resume next
Group = objElement.group
if Err.Number = 0 then
if objElement.group = 1 then
objElement.disabled = False
end if
if objElement.group = 2 then
objElement.disabled = True
end if
end if
on error goto 0
Next
document.all("SheetList").options.length = 0
Call ExcelQuit(MyBook)
end function
' ************************************************' シート一覧' ************************************************
function XlsSheetList()
Call ExcelSheetList(MyBook,"SheetList")
end function
' ************************************************' シート選択' ************************************************
function XlsSelectSheet()
Target = document.all("SheetList").value
Call ExcelSelectSheet(MyBook, Target)
end function
' ************************************************' 範囲選択' ************************************************
function XlsRange()
Target = document.all("SheetList").value
if Target = "" then
alert("シートを選択して下さい ")
Exit Function
end if
Call ExcelSelectSheet(MyBook, Target)
X1 = Cint(document.all("RangeX1").value)
Y1 = Cint(document.all("RangeY1").value)
X2 = Cint(document.all("RangeX2").value)
Y2 = Cint(document.all("RangeY2").value)
Call ExcelRange(MyBook, Target, X1, Y1, X2, Y2 )
end function
' ************************************************' BOX罫線' ************************************************
function XlsBox()
Dim LineType,LineWidth
LineType = Cint(document.all("LineType").value)
LineWidth = Cint(document.all("LineWidth").value)
if LineType = xlLineStyleNone then
Call ClearBox( )
else
Call ExcelBox(LineType, LineWidth)
end if
end function
' ************************************************' 範囲内罫線' ************************************************
function XlsInner()
Dim LineType,LineWidth
LineType = Cint(document.all("LineType").value)
LineWidth = Cint(document.all("LineWidth").value)
if LineType = xlLineStyleNone then
Call ClearInner( )
else
Call ExcelInnerH(LineType, LineWidth)
Call ExcelInnerV(LineType, LineWidth)
end if
end function
' ************************************************' シート複写' ************************************************
function XlsCopySheet()
Target = document.all("SheetList").value
Call ExcelCopySheet(MyBook, Target, _
Target & Replace(Time(),":", "" ) )
end function
' ************************************************' 指定行の高さ' ************************************************
function XlsRowHeight()
Target = document.all("SheetList").value
Dim nRow,nHeight
nRow = Cint(document.all("RowNo").value)
nHeight = Cint(document.all("RowHeight").value)
Call ExcelSetRowHeight(MyBook, Target, nRow, nHeight)
end function
' ************************************************' 指定列の幅' ************************************************
function XlsColumnWidth()
Target = document.all("SheetList").value
Dim nColumn,nWidth
nColumn = Cint(document.all("ColumnNo").value)
nWidth = Cint(document.all("ColumnWidth").value)
Call ExcelSetColumnWidth(MyBook, Target, nColumn, nWidth)
end function
</SCRIPT>
<HTML>
<HEAD>
<META http-equiv="Content-type" content="text/html; charset=Shift_JIS">
<TITLE>excel専用</TITLE>
<STYLE>
.MyCell {
background-color:silver
}
.MyButton {
width:200
}
</STYLE>
</HEAD>
<BODY>
<INPUT type=file name=Excel style='width:400'>
<BR>
<INPUT
class=MyButton
name=OpenButton
type=button
value="開く"
onClick='Call XlsOpen()'
group=1
><BR>
<INPUT
class=MyButton
name=QuitButton
type=button
value="終了"
onClick='Call XlsQuit()'
disabled
group=2
><BR>
<BR>
<INPUT
class=MyButton
name=SheetListButton
type=button
value="シート一覧"
onClick='Call XlsSheetList()'
disabled
group=2
><BR>
<SELECT
class=MyButton
name=SheetList
disabled
onChange='Call XlsSelectSheet()'
group=2
></SELECT><BR>
<INPUT
class=MyButton
name=RangeButton
type=button
value="範囲選択"
onClick='Call XlsRange()'
disabled
group=2
><BR>
<SELECT
name=RangeX1
onChange='Call XlsRange()'
>
</SELECT>
<SELECT
name=RangeY1
onChange='Call XlsRange()'
>
</SELECT>
<SELECT
name=RangeX2
onChange='Call XlsRange()'
>
</SELECT>
<SELECT
name=RangeY2
onChange='Call XlsRange()'
>
</SELECT>
<BR>
<BR>
線種
<SELECT
name=LineType
>
<OPTION value="1">xlContinuous
<OPTION value="-4115">xlDash
<OPTION value="4">xlDashDot
<OPTION value="5">xlDashDotDot
<OPTION value="-4118">xlDot
<OPTION value="-4119">xlDouble
<OPTION value="13">xlSlantDashDot
<OPTION value="-4142">xlLineStyleNone
</SELECT>
<BR>
線幅
<SELECT
name=LineWidth
>
<OPTION value="1">xlHairline
<OPTION value="-4138">xlMedium
<OPTION value="4">xlThick
<OPTION value="2">xlThin
</SELECT>
<BR>
<INPUT
class=MyButton
name=BoxButton
type=button
value="BOX罫線"
onClick='Call XlsBox()'
disabled
group=2
><BR>
<INPUT
class=MyButton
name=InnerButton
type=button
value="範囲内X罫線"
onClick='Call XlsInner()'
disabled
group=2
><BR>
<BR>
<INPUT
class=MyButton
name=CopySheetButton
type=button
value="シートの複写"
onClick='Call XlsCopySheet()'
disabled
group=2
><BR>
<BR>
行
<INPUT
name=RowNo
size=3
type=text
value="3"
disabled
group=2
>
高さ
<INPUT
name=RowHeight
size=3
type=text
value="30"
disabled
group=2
><BR>
<INPUT
class=MyButton
name=RowHeightButton
type=button
value="指定行の高さ"
onClick='Call XlsRowHeight()'
disabled
group=2
><BR>
<BR>
カラム
<INPUT
name=ColumnNo
size=2
type=text
value="3"
disabled
group=2
>
幅
<INPUT
name=ColumnWidth
size=3
type=text
value="30"
disabled
group=2
><BR>
<INPUT
class=MyButton
name=ColumnWidthButton
type=button
value="指定列の幅"
onClick='Call XlsColumnWidth()'
disabled
group=2
><BR>
</BODY>
</HTML>
<SCRIPT for=window event=onload language="VBScript">
Dim i,len
document.all("RangeX1").options.length = 0
For i = 1 to 20
len = document.all("RangeX1").options.length
document.all("RangeX1").options.length = len + 1
document.all("RangeX1").options(i-1).value = i
document.all("RangeX1").options(i-1).text = i
len = document.all("RangeY1").options.length
document.all("RangeY1").options.length = len + 1
document.all("RangeY1").options(i-1).value = i
document.all("RangeY1").options(i-1).text = i
len = document.all("RangeX2").options.length
document.all("RangeX2").options.length = len + 1
document.all("RangeX2").options(i-1).value = i
document.all("RangeX2").options(i-1).text = i
len = document.all("RangeY2").options.length
document.all("RangeY2").options.length = len + 1
document.all("RangeY2").options(i-1).value = i
document.all("RangeY2").options(i-1).text = i
Next
document.all("RangeX2").value = 3
document.all("RangeY2").value = 10
window.focus()
top.resizeTo screen.width / 2, screen.height - 32
top.moveTo screen.width / 2, 0
</SCRIPT>
<SCRIPT for=window event=onunload language="VBScript">
Call ExcelQuit(MyBook)
</SCRIPT>
