Lightbox Info Board : SQLの窓

frame.htm


<HTML>
<HEAD>
<TITLE>Excel 印刷</TITLE>
<META http-equiv="Content-type" content="text/html; charset=Shift_JIS">
</HEAD>
<FRAMESET id="TopFrame" rows="80,120,*" FRAMEBORDER=0 FRAMESPACING=0>
	<FRAME name="HeadFrame" src="control.php?view=head">
	<FRAME name="Excel" src="excel.htm">
	<FRAME name="BodyFrame" src="control.php?view=body">
</FRAMESET>
</HTML>

control.php


<?
# **********************************************************
# 外部ファイル
# **********************************************************
require_once( "common.php" );
require_once( "db.php" );
require_once( "model.php" );

# **********************************************************
# 定数定義
# **********************************************************
define( 'PASS_MESSAGE', 1 );
define( 'PASS_HEAD', 2 );
define( 'PASS_BODY', 3 );

define( 'VIEW_MESSAGE', 'viewmessage.php' );
define( 'VIEW_HEAD', 'view.php' );
define( 'VIEW_BODY', 'view2.php' );

# **********************************************************
# グローバル変数
# **********************************************************
$Target		= '商品分類マスタ';
$KeyName	= '';
$KeyField	= '';
$ErrMessage	= '';
$Message	= '';
$InData		= '';
$OutData	= '';
$OptionList	= '';

# **********************************************************
# 初期処理
# **********************************************************
if ( $_POST['In1001'] != "" ) {
	setcookie( 'In1001', $_POST['In1001'] );
}

$SQL = new DB( "localhost", "lightbox", "root", "" );
$SQL->Debug = FALSE;

# **********************************************************
# 処理コントロール
# **********************************************************
switch( $_POST['GNO'] ) {
	# ヘッド部からの処理
	case PASS_HEAD:
		CheckDataHead( );
		if ( $ErrMessage == "" ) {
			GetData( $SQL );
		}
		else {
			$_POST['GNO'] = PASS_MESSAGE;
		}
		break;

}

# **********************************************************
# ビュー
# **********************************************************
CreateInData( );
switch( $_POST['GNO'] ) {
	# メッセージ表示
	case PASS_MESSAGE:
		require_once( VIEW_MESSAGE );
		break;

	# ヘッド部からの処理
	case PASS_HEAD:
		EditDataBody();
		require_once( VIEW_BODY );
		break;

	# ボディ部からの処理
	case PASS_BODY:
		EditDataBody();
		require_once( VIEW_BODY );
		break;

	# 初期画面
	default:
		if ( $_GET['view'] == 'head' ) {
			RestoreCookie( );
			EditDataHead( );
			require_once( VIEW_HEAD );
		}
		if ( $_GET['view'] == 'body' ) {
			EditDataBody();
			require_once( VIEW_MESSAGE );
		}
		break;

}

# **********************************************************
# 終了処理
# **********************************************************
$SQL->Close();

# **********************************************************
# デバッグ
# **********************************************************
#DispData();
?>

model.php


<?
# **********************************************************
# SQL文字列作成用
# **********************************************************
function SetCond( &$Value ) {

	if ( $Value == "" ) {
		$Value .= " where ";
	}
	else {
		$Value .= " and ";
	}

}

# **********************************************************
# データベースデータの読出し
# **********************************************************
function GetData( &$SQL ) {

	global $Target,$KeyField,$KeyName;

	$Query = 'select * from ' . $Target;
	$Cond = "";

	# 最初の条件
	if ( $_POST['In1001'] != "" ) {
		SetCond( $Cond );
		$Cond .= "名称 like '%{$_POST['In1001']}%'";
	}

	$Column = $SQL->QueryEx( $Query . $Cond );

	while ( $Column ) {
		EditQueryData( $Column );
		$Column = $SQL->QueryEx( );
	}

}

# **********************************************************
# データベースデータの編集
# **********************************************************
function EditQueryData( &$Column ) {

	global $OutData;

	$OutData .= "<TR>";

	$OutData .= "<TD style='background-color:white'>";
	$OutData .= $Column['商品分類'];
	$OutData .= "</TD>";

	$OutData .= "<TD style='background-color:white'>";
	$OutData .= $Column['名称'];
	$OutData .= "</TD>";

	$OutData .= "</TR>";

}

# **********************************************************
# ヘッド部の編集
# **********************************************************
function EditDataHead( ) {

	global $Target,$KeyField,$KeyName;

}

# **********************************************************
# ボディ部の編集
# **********************************************************
function EditDataBody( ) {

	global $Target,$KeyField,$KeyName;

}

# **********************************************************
# 更新処理
# **********************************************************
function UpdateData( &$SQL ) {

	global $ErrMessage,$Message;
	global $Target,$KeyField,$KeyName;

	return TRUE;
}

# **********************************************************
# 削除処理
# **********************************************************
function DeleteData( &$SQL ){

	global $ErrMessage,$Message;
	global $Target,$KeyField,$KeyName;

	return TRUE;
}

# **********************************************************
# ヘッド部のエラーチェック
# **********************************************************
function CheckDataHead( ) {

	global $ErrMessage;
	global $Target,$KeyField,$KeyName;

	return TRUE;
}

# **********************************************************
# ボディ部のエラーチェック
# **********************************************************
function CheckDataBody( ) {

	global $ErrMessage;
	global $Target,$KeyField,$KeyName;

	return TRUE;
}

?>

view.php


<SCRIPT language="VBScript">

' **********************************************************
' フォームのチェック
' **********************************************************

function frmMain_onSubmit( )

	frmMain_onSubmit = true

end function

' **********************************************************
' フィールドのクリア
' **********************************************************
function ClearField( )

	document.all("In1001").value = ""

end function

</SCRIPT>


<HTML>
<HEAD>
<META http-equiv="Content-type" content="text/html; charset=Shift_JIS">
<TITLE>PHP 雛形</TITLE>
<STYLE>
	.MyCell {
		background-color:silver
	}
</STYLE>
</HEAD>
<BODY>

<FORM
	name=frmMain
	method=GET
	action=control.php
	target=BodyFrame
>
<TABLE border=0 bgcolor=black cellspacing=1 cellpadding=5>
<TR>
<!-- *******************************************************
 入力
******************************************************** -->
	<TD class=MyCell>名　称</TD>
	<TD class=MyCell>
		<INPUT
			type=text
			name=In1001
			value="<?= $_POST['In1001'] ?>"
		>
	</TD>

<!-- *******************************************************
 送信ボタン
******************************************************** -->
	<TD class=MyCell>
		<INPUT type=submit name=send value="送信">
	</TD>

<!-- *******************************************************
 クリアボタン
******************************************************** -->
	<TD class=MyCell>
		<INPUT 
			type=button
			value="クリア"
			onClick='ClearField()'
		>
	</TD>

<!-- *******************************************************
 画面初期化ボタン
******************************************************** -->
	<TD class=MyCell>
		<INPUT 
			type=button
			value="Cancel"
			onClick='top.location="frame.htm"'
		>
	</TD>
</TR>
</TABLE>

<!-- *******************************************************
 画面ID
******************************************************** -->
<INPUT type=hidden name=GNO value="<?= PASS_HEAD ?>">
</FORM>

</BODY>
</HTML>

view2.php

ActiveX 使用前にこちらを参照して下さい


<SCRIPT language="VbScript" src="fs.vbs"></SCRIPT>
<SCRIPT language="VbScript" src="excel.vbs"></SCRIPT>
<SCRIPT language="VbScript" src="client.vbs"></SCRIPT>
<SCRIPT language="VBScript">

' **********************************************************
' フォームのチェック
' **********************************************************
function frmMain_onSubmit()

	frmMain_onSubmit = true

end function

</SCRIPT>

<HTML>
<HEAD>
<META http-equiv="Content-type" content="text/html; charset=Shift_JIS">
<TITLE>PHP 雛形</TITLE>
<STYLE>
	.MyCell {
		background-color:silver
	}
</STYLE>
</HEAD>

<!-- *******************************************************
 ドキュメントオブジェクト
******************************************************** -->
<BODY>
<SPAN style='color:blue'><?= $ErrMessage ?></SPAN>
<SPAN style='color:black;font-weight:bold'><?= $Message ?></SPAN>

<!-- *******************************************************
 フォーム
******************************************************** -->
<FORM
	name=frmMain
	method=GET
	action=control.php
>

<!-- *******************************************************
 画面定義
******************************************************** -->
<TABLE>
	<TR>
	<TD valign=top>3)</TD>
	<TD>
		<INPUT type=button value="実行" onClick='Call ExcelOut()'>
	</TD>
	</TR>
</TABLE>

<TABLE id=data border=0 bgcolor=black cellspacing=1 cellpadding=5>
<TH class=MyCell>商品分類</TH>
<TH class=MyCell>名称</TH>
<?= $OutData ?>
</TABLE>

<!-- *******************************************************
 画面番号
******************************************************** -->
<INPUT type=hidden name=GNO value="<?= PASS_BODY ?>">

<!-- *******************************************************
 HEAD 部の入力データ引継ぎ用の埋め込み
******************************************************** -->
<?= $InData ?>
</FORM>

</BODY>
</HTML>

viewmessage.php


<HTML>
<HEAD>
<META http-equiv="Content-type" content="text/html; charset=Shift_JIS">
<TITLE>メッセージ表示専用</TITLE>
<STYLE>
	.MyCell {
		background-color:silver
	}
</STYLE>
</HEAD>
<BODY>
<SPAN style='color:blue'><?= $ErrMessage ?></SPAN>
<SPAN style='color:black;font-weight:bold'><?= $Message ?></SPAN>
</BODY>
</HTML>

excel.htm


<SCRIPT language="VBScript">

' **********************************************************
' エクセルブックのダウンロード説明
' **********************************************************
function Axls()

	window.event.returnValue = false
	alert("右クリックで、「対象をファイルに保存」でダウンロードして下さい     ")

end function

</SCRIPT>

<HTML>
<HEAD>
	<META http-equiv="Content-type" content="text/html; charset=Shift_JIS">
	<TITLE>excel専用</TITLE>
<STYLE>
	.MyCell {
		background-color:silver
	}
</STYLE>
</HEAD>
<BODY>
<TABLE>
	<TR>
	<TD valign=top>1)</TD>
	<TD>
		<A
			href='Format/Format.xls'
			onClick='Axls()'
		>出力の元フォーマットとなるエクセルのダウンロード</a>
	</TD>
	</TR>
</TABLE>

<BR>

<TABLE>
	<TR>
	<TD valign=top>2)</TD>
	<TD>
		ダウンロードしたエクセルブックまたは、
		カスタムのエクセルブックを選択して下さい
	</TD>
	</TR>
</TABLE>
<INPUT type=file name=Excel style='width:500'>
</BODY>
</HTML>

fs.vbs


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>