[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『もう少し綺麗なコードにしたい』（じむいんさん）
はじめまして、いつもこちらで勉強しております。
以下のマクロを、試行錯誤して作成いたしました。 これでも思ったとおりの動きはするのですが、なんだかかっこ悪い気がしまして、 皆様だったらどのように修正するか？と、興味を持った次第です。
・別途マニュアルに、マクロ実行前にABCDのブックを立ち上げる旨を記載しています ・ABCDはExcelとは別の専用アプリケーションからダウンロードしており、それぞれ1シートのみ入っていて、シート名がABCDになっています（ブック名はランダムなので、そのままでは使えません） ・「A」シートのあるブックに他ブックのすべてのシートを集め、保存するという作業を行いたいと思っています ・以下のコードは、上記ブックとは別の「実行」ボタンのみが配置されている「成形マクロ」というブックに保存しています ・私としては、for〜文が二回続くのが、かっこ悪いなあと思っています（おまじない、はいらないと思うのですが、長年の癖で…）
「これでいいんじゃない？」でも、「だっさ、こうしなよ」でもかまいません。 何か、ご意見をいただきたく思います。 以上、よろしくお願いいたします。
↓以下コード Sub SoatMacro() ' '表示されているシートをABCD順に並べ替え、「A」シートに着色し、 'すべてのシートにフィルタとウインドウの固定を設定するマクロ
Dim i As Long 'カウンタ
Dim SaveBook As Long '「A」のシートがあるブック名の番号を控える
Dim FileName(1 To 5) As String '元ファイル名（5ファイル）
Dim SheetName(1 To 4) As String 'シート名（4つ）
Dim DefaultDate As String '保存日付（デフォルト）
Dim DateName As String '保存日付（自動で入るが、手入力可）
Dim WSH As Variant 'Windows Scripting Host
Const FolderName As String = "\\hogehoge\hozon\" 'ファイル保存先（指定）
On Error GoTo ErrMsg
'シート名配列（シート名の並び順を指定）
SheetName(1) = "A"
SheetName(2) = "B"
SheetName(3) = "C"
SheetName(4) = "D"
Application.ScreenUpdating = False
'表示ブックがマクロ含め5つではない場合、処理終了
If Application.Workbooks.Count <> 5 Then
MsgBox "開かれていないファイルがあるか、余計なファイルが開かれています。処理を終了します。", vbOKOnly
Exit Sub
End If
'おまじない
Workbooks("成形マクロ.xlsm").Activate
'開いているすべてのブック名を取得し、保存するブック（Aのあるブック）を指定する
For i = 1 To 5
FileName(i) = Workbooks(i).Name
If Workbooks(FileName(i)).Worksheets(1).Name = SheetName(1) Then
SaveBook = i '保存するブックが何番目に開かれているかを控える
End If
Next i
'保存するブックにすべてのシートを移動する（マクロブック以外）
For i = 1 To 5
If Workbooks(FileName(i)).Name <> "成形マクロ.xlsm" Then
If i <> SaveBook Then
Workbooks(FileName(i)).Worksheets(1).Move after:=Workbooks(FileName(SaveBook)).Worksheets(1)
End If
End If
Next i
'シート並べ替え
With Workbooks(FileName(SaveBook))
.Worksheets(SheetName(1)).Move Before:=Worksheets(1) 'Aシートを先頭に
For i = 1 To 4
With .Worksheets(SheetName(i)) 'シート名配列順に作業する
.Activate
If i <> 1 Then
'Aシートの後ろに順に並べ替え
.Move after:=Worksheets(SheetName(i - 1))
Else
'Aのシートの場合、シートに赤い色をつける
.Tab.ThemeColor = xlThemeColorAccent2
.Tab.TintAndShade = 0.599993896298105
End If
'8行目にオートフィルタ
.Rows("8:8").AutoFilter
'9行目にウィンドウ枠の固定
.Rows("9:9").Select
ActiveWindow.FreezePanes = True
'A1セルを選択
.Range("A1").Select
End With
Next i
End With
'並べ替え終了後、Aシートを選択
Worksheets(SheetName(1)).Activate
'保存ファイルの日付を指定する
DefaultDate = Format(Mid(Worksheets(SheetName(1)).Range("A5").Value, 13, 10), "yyyymmdd") 'デフォルト日付（Aシート記載のA5セルの日付）
Do
'入力メッセージ表示
DateName = InputBox(Prompt:="日付をYYYYMMDD形式で入力してください。" & vbCrLf & _
DefaultDate & "より大きい日付は入力できません。", Default:=DefaultDate)
'入力が空白の場合は何らかの入力があるまでエラーメッセージを表示
If DateName = "" Then
MsgBox "この項目は省略できません", vbExclamation
'日付以外のものが入力された場合や、短い日付が入力された場合はエラーメッセージを表示
ElseIf Not IsDate(Format(DateName, "@@@@/@@/@@")) Then
MsgBox "日付をYYYYMMDD形式で入力してください。"
DateName = ""
'デフォルト日付より先の日付が入力された場合はエラーメッセージを表示
ElseIf Format(DateName, "@@@@/@@/@@") > Format(DefaultDate, "@@@@/@@/@@") Then
MsgBox DefaultDate & "より先の日付は入力できません。"
DateName = ""
End If
Loop While DateName = ""
'「保存」フォルダにファイルを保存する
With CreateObject("WScript.Shell")
.currentdirectory = FolderName 'フォルダ移動
End With
On Error Resume Next
Workbooks(FileName(SaveBook)).SaveAs FolderName & DateName & "保存.xls"
If Err.Number > 0 Then
MsgBox "保存されませんでした。"
Else
MsgBox "「保存先」フォルダに" & vbCrLf & _
DateName & "保存.xlsを保存しました。"
End If
On Error GoTo ErrMsg
ActiveWorkbook.Close savechanges:=False
Application.ScreenUpdating = True
'エクセルを閉じる
Application.Quit
Exit Sub
ErrMsg:
MsgBox "何らかのエラーが発生しました。処理を中断します。" & vbCrLf & _
"本日の作業は手作業で行ってください。" & vbCrLf & _
"エラー番号：" & Err.Number & vbCrLf & _
"エラーメッセージ：" & Err.Description
End Sub
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
また、静的一次元配列を宣言して、For〜Nextステートメント使うくらいなら、For Each〜Nextステートメントでループするとおもいます。
とりあえずスマホからなので気になったところだけ。
（もこな２） 2018/05/01(火) 19:33
Sub test()
Dim MyBOOK As Workbook
Dim MyCol As New Collection
Dim tmp As Variant
Dim i As Long
For Each tmp In Array("A", "B", "C", "D")
For Each MyBOOK In Workbooks
If MyBOOK.Worksheets(1).Name = tmp Then
MyCol.Add Item:=MyBOOK
End If
Next MyBOOK
Next tmp
With MyCol(1)
For i = 2 To 4
MyCol(i).Worksheets(1).Copy After:=.Worksheets(.Worksheets.Count)
Next i
End With
End Sub
（もこな２） 2018/05/02(水) 04:23
もこな２さま
ご返信ありがとうございます！ 後ほど時間をとって、じっくり拝見いたします。 取り急ぎお礼まで。 （じむいんさん） 2018/05/02(水) 10:11
私ならこんな風に書くかなあ。
ブックやシートを指定する際、できるだけオブジェクトでそのまま指定するようにしたほうが 分かりやすくなるのではないですか、というのが指摘の骨子。 貴兄のコードは基本オーケーだと思います。 あえて手を入れるなら、ということです。参考にしてください。
Option Explicit
Const FolderName As String = "\\hogehoge\hozon\" 'ファイル保存先（指定）■■ ' 以下、要変更のところは■■を付す。
Dim SaveBook As Workbook '「A」のシートがあるワークブック
Sub SortMacro()
'いくつかのブックを1つに集約し、
'シートをABCD順に並べ替える。
'「A」シートに着色し、
'すべてのシートにフィルタとウインドウの固定を設定するマクロ
Dim wb As Workbook
On Error GoTo ErrMsg
Application.ScreenUpdating = False
'表示ブックがマクロ含め5つではない場合、処理終了
If Workbooks.Count <> 5 Then
MsgBox "開かれていないファイルがあるか、余計なファイルが開かれています。" & vbCrLf & _
"処理を終了します。", vbOKOnly
Exit Sub
End If
'開いているすべてのブックから、"A"のあるブックを集約先ブックに指定
For Each wb In Workbooks
If wb.Sheets(1).Name = "A" Then '■■
Set SaveBook = wb
Exit For
End If
Next
Call ワークシートの移動
Call 集約先ブックの保存
Application.ScreenUpdating = True
Exit Sub
ErrMsg:
MsgBox "何らかのエラーが発生しました。処理を中断します。" & vbCrLf & _
"本日の作業は手作業で行ってください。" & vbCrLf & _
"エラー番号：" & Err.Number & vbCrLf & _
"エラーメッセージ：" & Err.Description
End Sub
Sub ワークシートの移動()
Dim wb As Workbook
Dim s As Variant
'保存するブックにすべてのシートを移動する（マクロブック以外）
For Each wb In Workbooks
If Not (wb Is ThisWorkbook Or wb Is SaveBook) Then
wb.Worksheets(1).Move after:=SaveBook.Worksheets(1)
End If
Next
'シート並べ替え
With SaveBook
For Each s In Split("D,C,B,A", ",") '■■
With .Worksheets(s) 'シート名配列順に作業する
.Move Before:=SaveBook.Worksheets(1)
.Rows("8:8").AutoFilter
'9行目にウィンドウ枠の固定
Application.Goto .Rows("9:9")
ActiveWindow.FreezePanes = True
Application.Goto .Range("A1")
End With
Next
With .Worksheets("A") '■■
'シートタブに赤い色をつける
.Tab.ThemeColor = xlThemeColorAccent2
.Tab.TintAndShade = 0.599993896298105
End With
End With
End Sub
Sub 集約先ブックの保存()
Dim DefaultDate As String '保存日付（デフォルト）
Dim DateName As String '保存日付（自動で入るが、手入力可）
'保存ファイルの日付を指定する
'デフォルト日付（Aシート記載のA5セルの日付）
DefaultDate = Format(Mid(SaveBook.Worksheets(1).Range("A5").Value, 13, 10), "yyyymmdd")
Do
'入力メッセージ表示
DateName = InputBox(prompt:="日付をYYYYMMDD形式で入力してください。" & vbCrLf & _
DefaultDate & "より大きい日付は入力できません。", Default:=DefaultDate)
'入力が空白の場合は何らかの入力があるまでエラーメッセージを表示
If DateName = "" Then
MsgBox "この項目は省略できません", vbExclamation
'日付以外のものが入力された場合や、短い日付が入力された場合はエラーメッセージを表示
ElseIf Not IsDate(Format(DateName, "@@@@/@@/@@")) Then
MsgBox "日付をYYYYMMDD形式で入力してください。"
DateName = ""
'デフォルト日付より先の日付が入力された場合はエラーメッセージを表示
ElseIf Format(DateName, "@@@@/@@/@@") > Format(DefaultDate, "@@@@/@@/@@") Then
MsgBox DefaultDate & "より先の日付は入力できません。"
DateName = ""
End If
Loop While DateName = ""
'「保存」フォルダにファイルを保存する
On Error Resume Next
'SaveBook.SaveAs FolderName & DateName & "保存.xls" ' ファイル形式はこれでよいのか？
SaveBook.SaveAs FolderName & DateName & "保存.xlsx", FileFormat:=xlOpenXMLWorkbook
If Err.Number > 0 Then
MsgBox "保存されませんでした。"
Else
MsgBox "「保存先」フォルダに" & vbCrLf & _
DateName & "保存.xlsxを保存しました。"
SaveBook.Close savechanges:=False
End If
On Error GoTo 0
End Sub
＝---------------------------------------------------------- メインプロシージャにある冒頭の2つの繰り返し文も、 サブプロシージャーに落とした方が一貫性があるのですが、 Exit Subだとメインに戻ってしまうだけだし、Endで終わるのもちょっとと思い、 あえてメインに残したままにしました。 関数の戻り値で判断させたり、エラーをRaiseする手もあるかもしれないが、小賢しい感じ？ (この程度の長さで、プロシージャを分割する意味があるかどうか少し疑問だが。 人により意見は分かれそう。）
余談：
その昔、とある掲示板の質問で、
Worksheets(ActiveSheet.Name).Select
というコードを拝見したことがある。
二重に間違っていますよねえ。
# 本人は、名前を指定しないといけないと思い込んでいたのだろうか。
# それとも緊張緩和の笑いをとろうとしたのだろうか。
（γ） 2018/05/02(水) 11:16
γ様
コードありがとうございます！ こちらも、午後時間ができそうなので、じっくり拝見させていただきます。
ちなみに保存ファイルの拡張子は「.xls」で問題ございません。 （というか、指定されています）
取り急ぎ。 （じむいんさん） 2018/05/02(水) 11:48
もこな２様
おまじない、はともかく（本当にいらないと思うのですが…）、後者の.Activateはなくても動きました。 ご指摘ありがとうございます。
いただいたコードを実際に当てはめてみました。 結果、前半の部分（For Each〜）は成功し、ブックがひとつにまとまっているのですが 後半の
MyCol(i).Worksheets(1).Copy After:=.Worksheets(.Worksheets.Count)
という部分でエラーになります。 私がFor Eachをいまいち理解していないからなのか…原因がつかめません。 もしお心当たりがあったら、お手すきの際に教えていただけませんでしょうか。
γ様
いただいたコードで、思ったとおりの動きができました。 先ほどももこな２様へのレスで書きましたが、For Each〜文に苦手意識があり、 避けて通っていたのですが、これを機に勉強して、使いこなせるようになりたいと思います。
もう少しいろいろいじってみます。 お二方ともありがとうございます。 （じむいんさん） 2018/05/02(水) 14:46
ということで、研究成果発表。
Sub test2()
Dim MyBOOK As Workbook
Dim MyCol As New Collection
Dim tmp As Variant
Dim i As Long
For Each tmp In Array("A", "B", "C", "D")
For Each MyBOOK In Workbooks
If MyBOOK.Name <> ThisWorkbook.Name Then
If MyBOOK.Worksheets(1).Name = tmp Then
MyCol.Add Item:=MyBOOK
Exit For
End If
End If
Next MyBOOK
Next tmp
With MyCol(1)
'B〜DシートをAシート（があるブック）の末尾に順次コピー
For i = 2 To 4
MyCol(i).Worksheets(1).Copy After:=.Worksheets(.Worksheets.Count)
Next i
'Aシートのシート見出しを操作
With .Worksheets("A").Tab
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.599993896298105
End With
'（Aシートがある）ブックの全シートを順番に処理
For Each tmp In .Worksheets
With tmp
'オートフィルタが既に設定されているかもしれないので強制解除
.AutoFilterMode = False
.Rows("8:8").AutoFilter
Application.Goto .Rows(9)
ActiveWindow.FreezePanes = True
Application.Goto .Range("A1")
End With
Next tmp
Debug.Print .Path
Application.Goto .Worksheets(1).Range("A1")
.SaveAs _
Filename:= _
.Path & "\保存（" & Format(Date, "yyyy_mmdd") & "_" & _
Format(Time, "hhmm_ss") & "）"
'A〜Dシートが含まれるブックを保存せずに閉じる（Aシートが含まれるブックは、上記で保存済み）
Application.DisplayAlerts = False
For Each MyBOOK In MyCol
MyBOOK.Close
Next MyBOOK
Application.DisplayAlerts = True
End With
End Sub
〜補足〜
(1)エラートラップは検証がめんどくさかったので外しました。（実際に運用するならあったほうがいいとおもいます）
(2)「〜"成形マクロ.xlsm"〜」は、たぶん「ThisWorkbook.Name」の方が、ファイル名変わっても対応できるのでそちらをオススメします。
(3)開いてるブック数をチェックしてる部分は、なんで必要なのかよくわかなかったのと、テストする上でじゃまだったので外してあります。
(4) SaveAsのファイル名部分はそもそものファイル名の命名ルールがよくわからなかったので適当なものにしています。
(5)シートを並び替える部分は、目的の順番どおりにシートを追加（コピー）すれば、そもそも並び替える必要がなくなるので外しました。
(6)コピー元となるシートで既にオートフィルタが設定されている場合、AutoFilter実行するだけだと解除の意味になってしまうように思ったので、直前でオートフィルタを強制解除するよう変更しました。
(7)「Application.Quit」は逐一、Excelを丸ごと終わらせちゃうとテストしづらいので、「（Aシートが含まれるブックを含む）コピー元のブック」だけを閉じるようにしました。
(8)カレントフォルダを変更しているところがありますが、コード上の必要性がわからなかったので外しました。
とりあえず、思いつきですが参考になれば・・・
（もこな２） 2018/05/02(水) 15:06
あ、それで入れていたんだった…＞Activate もこな２様のご指摘で思い出しました。削除したらだめですね。すみません直します。
頂いたコードも試してみます。ありがとうございます。 （じむいんさん） 2018/05/02(水) 15:15
もこな２様
テストバージョン、希望通りに動きました。ありがとうございます。 これを実コードにも反映させてみたいと思います。
以下、お返事を。 （２）、なるほどです。すぐやります。 （３）、（７）は、実際の運用者の方がうっかりミスをしないように入れているので テストでは問題ございませんでした。 （４）は特定のセルに日付（不規則）が入力されているため、その情報を取得しています。 でもなんだかわかりませんよね、ご指摘もっともだと思います。 （８）は保存先をサーバ上の特定フォルダに指定しなければならないため、記載していました。 （コードが記載されているExcelマクロブックとは別のフォルダなのです）
大変勉強になりました。 重ね重ねありがとうございます。 （じむいんさん） 2018/05/02(水) 16:00
γ様
今見返しましたところ、全シートで「8行目にオートフィルタ」「9行目でウインドウ枠の固定」 が、反映されていませんでした。 確認せずできたと思いこみ、いい加減なことを申しましてすみませんでした。
先ほどのもこな２様からの指摘で気がつき、
With .Worksheets(s) 'シート名配列順に作業する
.activate '←
.Move Before:=SaveBook.Worksheets(1)
.Rows("8:8").AutoFilter
'9行目にウィンドウ枠の固定
Application.Goto .Rows("9:9")
ActiveWindow.FreezePanes = True
Application.Goto .Range("A1")
End With
.activateを入れることで解決いたしました。 （じむいんさん） 2018/05/02(水) 16:46
（３）は、興味があればステップ実行していただくとより解るかと思いますが、
For Each tmp In Array("A", "B", "C", "D")
For Each MyBOOK In Workbooks
If MyBOOK.Name <> ThisWorkbook.Name Then
If MyBOOK.Worksheets(1).Name = tmp Then
MyCol.Add Item:=MyBOOK
Exit For
End If
End If
Next MyBOOK
Next tmp
この部分が2重ループになっていて、外側のループで探したいシート名を変数「tmp」にセットしたうえで、内側のループで開いてるブックの中から、1番目のシートが「tmp」にセットされている名前になっているブックを探して、見つかった場合は、そのブックをコレクションに追加しています。
これを、繰り返すと「tmp」にセットした（された）順番に、対応するブックがコレクションに追加されるということになります。
個人的には、この部分で重要なのは、目的のブックが開いているかどうかですから、この部分をもうちょっと改良して、対象となるブックが見つからなかったらエラーを返すようにしたほうがいいんじゃないかなと思います。
（７）は現状だと、マクロを実行したが最後、ユーザーには何も知らせずにいきなりExcelが終わるわけですから、あんまりユーザーフレンドリーでないような気がします。
運用する方を考えるのであれば、処理が終わったことを通知するような設計をしてあげたほうがベターかなとおもいます。
＞（８）は保存先をサーバ上の特定フォルダに指定しなければならないため、記載していました。
＞（コードが記載されているExcelマクロブックとは別のフォルダなのです）
う〜ん。カレントフォルダを変更する理由って、SaveAsメソッドのためですよね。たぶん。
SaveAsメソッドは、パスを”省略して”ファイル名だけ与えると、カレントフォルダに与えられたファイル名で保存するという仕組みですから、保存先（フォルダ）も含めてきちんとフルパスを与えれば、カレントフォルダを切り替えなくとも、望みの場所に望みの名前で保存することは可能だとおもいます。
（４）はいろいろあってそのようなファイル名の取得の仕方をされてるとおもうので、ご自身で運用に合わせていくしかないですね・・・
そんなこんなを踏まえて、こんな感じに修正してみました。
Sub test3()
Dim MyBOOK As Workbook
Dim MyCol As New Collection
Dim tmp As Variant
Dim i As Long
Dim flag As Boolean
Dim MyPath As String, MyFile As String
For Each tmp In Array("A", "B", "C", "D")
flag = False
For Each MyBOOK In Workbooks
If MyBOOK.Name <> ThisWorkbook.Name Then
If MyBOOK.Worksheets(1).Name = tmp Then
MyCol.Add Item:=MyBOOK
flag = True
Exit For
End If
End If
Next MyBOOK
'対象ブックを開いていなかった時の処理
If Not flag Then
MsgBox "開いてるブックの中に、１番目のシートが「" & tmp & _
"」になってるものがありませんでした。" & vbCrLf & _
"該当するブックを開いてから再度実行してください｡"
Exit Sub
End If
Next tmp
With MyCol(1)
'B〜DシートをAシート（があるブック）の末尾に順次コピー
For i = 2 To 4
MyCol(i).Worksheets(1).Copy After:=.Worksheets(.Worksheets.Count)
Next i
'Aシートのシート見出しを操作
With .Worksheets("A").Tab
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.599993896298105
End With
'（Aシートがある）ブックの全シートを順番に処理
For Each tmp In .Worksheets
With tmp
'オートフィルタが既に設定されているかもしれないので強制解除
.AutoFilterMode = False
.Rows(8).AutoFilter
Application.Goto .Rows(9)
ActiveWindow.FreezePanes = True
Application.Goto .Range("A1")
End With
Next tmp
Application.Goto .Worksheets(1).Range("A1")
'保存処理
MyPath = .Path
MyFile = "保存（" & Format(Date, "yyyy_mmdd") & "_" & Format(Time, "hhmm_ss") & "）"
.SaveAs filename:=MyPath & "\" & MyFile
MsgBox MyPath & " に" & vbCrLf & .Name & "というファイル名で保存しました。" & _
vbCrLf & vbCrLf & "コピー元のブックを閉じます｡"
End With
'A〜Dシートが含まれるブックを保存せずに閉じる（Aシートが含まれるブックは、上記で保存済み）
Application.DisplayAlerts = False
For Each MyBOOK In MyCol
MyBOOK.Close
Next MyBOOK
Application.DisplayAlerts = True
End Sub
（もこな２） 2018/05/02(水) 22:23
（γ） 2018/05/02(水) 22:30
ということなので、雑感を。。。。
1）
この程度のことなら手動ですればいいじゃんって思いました。
パソコンの操作に慣れてない人のためにという事でしょうが、
これくらいの操作は出来るようになってほしいし、
出来るようになるべきだと思います。
＞MsgBox "開かれていないファイルがあるか、余計なファイルが開かれています。処理を終了します。
どうせはじかれるなら、、、、
毎度の作業でしょ？
目視で確認しましょうよ＾＾；
2）
VBAのコードの話
On Error 〜を安易に使いすぎだと思います。
メンテナンスを困難にしていると思います。
3）
個人的な趣味ですが、やたらとご丁寧なメッセージが多すぎると思います。
使う方の意見として、
毎度のメッセージなんか読みませんから、
うるさくメッセージを出さないでほしい＞＜
クリック数は1回でも少なく。
4）各作業はサブルーチン化して、
メインの流れを明確にした方がメンテナンスが楽だと思います。
Sub testメイン()
Dim wbNew As Workbook
Dim ws As Worksheet
Dim sProm As String
Dim sFName As String
'ブックを一つにまとめる
If GetSheetsInOne(wbNew) = False Then
sProm = "開いているブックに不足があります。要確認。"
GoTo Wayout
End If
'各シートの設定
For Each ws In wbNew.Worksheets
With ws
'8行目にオートフィルタ
.Range("A8").AutoFilter
'9行目にウィンドウ枠の固定
Application.Goto .Range("A9")
ActiveWindow.FreezePanes = True
'A1セルを選択
Application.Goto .Range("A1")
End With
Next
'保存ファイル名生成
sFName = GetFileName()
'名前を付けて保存
With wbNew
.SaveAs sFName
.Close False
End With
sProm = "処理終了"
Wayout:
MsgBox sProm
End Sub
（まっつわん） 2018/05/07(月) 17:00
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.