'============Stretch(v1).vbs=================

' (c)k-hiray@mvb.biglobe.ne.jp

'自由曲面が伸びるアニメーションを作るスクリプトです。
'伸ばしたい自由曲面を選択して実行してください。

'1999/08/25作成
'1999/08/26	交差方向の線形状が閉じている場合でもそのまま実行できるよう修正。
'2000/05/24	(v1)

If XShade.PartType <> 1 Then
	msg = MsgBox("自由曲面を選択してください。")
Else
	XShade.Switch
	XShade.SelectChild 1
	If XShade.LineObjectClosed = True Then
		msg = MsgBox("交差方向の線形状が閉じているので、開いた線形状に変換します。")
		XShade.InhibitUpdate
		XShade.LineObjectClosed = False
		Do While XShade.SelectBrother(1) = True
			XShade.LineObjectClosed = False
		Loop
		XShade.Switch
		Do While XShade.SelectSister(1) = True
		Loop
		XShade.Copy
		Do While XShade.SelectBrother(1) = True
		Loop
		XShade.Paste
		XShade.Switch
		XShade.AllowUpdate
	End If
	XShade.SelectParent 1
	XShade.Switch
	S_P = XShade.Handle
	XShade.BeginDialog(8947117)
	XShade.AppendBoolDialogItem"ふたをつける"
	XShade.BoolPropertyValue(0) = 0
	If XShade.AskDialog = True then
		lid = XShade.BoolPropertyValue(0)
		If lid = True Then
			XShade.CreateMasterSurface "ふた"
			m_n = XShade.MasterSurface
			XShade.BrowserWindow = false
			XShade.SurfaceWindow = false
			XShade.BrowserWindow = true
			XShade.SurfaceWindow = True
			msg = MsgBox("ふたの表面材質を設定してください。")
		End If
		XShade.InhibitUpdate
		Call Stretch
		XShade.AllowUpdate
	End If
	XShade.EndDialog
End If

Function Stretch
	XShade.Select(S_P)
	XShade.SelectChild 1
	NAP = XShade.NumberOfAnchorPoints
	ReDim apx(NAP - 1), apy(NAP - 1), apz(NAP - 1)
	n_line = 1
	Do While XShade.SelectBrother(1) = True
		n_line = n_line + 1
	Loop
	XShade.SelectParent 1
	XShade.CreateMorphJoint
	XShade.SelectSister 1
	XShade.PlaceChild 1
	If lid = True Then
		XShade.CreatePart
		XShade.SelectSister 1
		XShade.PlaceChild 1
		XShade.SelectParent 1
	End if
	For i = 1 To n_line - 1
		XShade.CopyObjectTranslate 0, 0, 0
	Next
	For i = 1 To n_line - 1
		XShade.SelectSister 1
		If lid = True Then
			XShade.SelectChild 1
		End If
		XShade.SelectChild 1
		Do While XShade.SelectBrother(1) = True
		Loop
		For j = 1 To i
			XShade.Clear
		Next
		For k = 0 To NAP - 1
			apx(k) = XShade.AnchorPoint(k, 0)
			apy(k) = XShade.AnchorPoint(k, 1)
			apz(k) = XShade.AnchorPoint(k, 2)
			XShade.LateralOutHandle(k, 0) = apx(k)
			XShade.LateralOutHandle(k, 1) = apy(k)
			XShade.LateralOutHandle(k, 2) = apz(k)
		Next
		For j = 1 To i
			XShade.CopyObjectTranslate 0, 0, 0
			If j = 1 Then
				For k = 0 To NAP - 1
					XShade.LateralInHandle(k, 0) = apx(k)
					XShade.LateralInHandle(k, 1) = apy(k)
					XShade.LateralInHandle(k, 2) = apz(k)
				Next
			End If
		Next
		If lid = True Then
			XShade.Copy
			XShade.SelectParent 1
			XShade.Paste
			XShade.MasterSurface = m_n
'			If i = 1 Then
'				XShade.AllowUpdate
'				XShade.SurfaceWindow = false
'				XShade.SurfaceWindow = true
'				msg = MsgBox("ふたの表面材質を設定してください。")
'				XShade.SaveSurface "lid.sfc"
'				Set FS = CreateObject("Scripting.FileSystemObject")
'				Set F = FS.GetFile("lid.sfc")
'				sfc_p = F.Path
'				XShade.Message sfc_p
'				XShade.InhibitUpdate
'			Else
'				XShade.LoadSurface sfc_p
'			End If
		End If
		XShade.SelectParent 1
		XShade.Message i & "/" & n_line - 1 & "終了"
	Next
	If lid = True Then
		Do While XShade.SelectBrother(1) = True
		Loop
		XShade.SelectChild 1
		XShade.SelectChild 1
		Do While XShade.SelectBrother(1) = True
		Loop
		XShade.Copy
		XShade.SelectParent 1
		XShade.Paste
		XShade.MasterSurface = m_n
		XShade.SelectParent 1
	End If
	XShade.SelectParent 1
'	FS.DeleteFile sfc_p
End Function