アルゴリズム共有　その７　～ 毛編 ～　改

作者コメント：

Thank you so much for all your support! They\'re very encouraging!!「腋毛を太くする頂点モーフ」に関しては、"アルゴリズム共有　その２　～ 毛編 ～" を参照してください。その動画の方法で出来ます。今回のマクロはすぐ出来るだろうなぁと思っていたら、意外と曲者な感じでした。。ｗ毛モデルが拡散的であれば、拡散的に伸び、収束的であればその形のまま伸びます。今回のマクロで気付いたことは、体の部位によって、拡散的な毛モデルにするのか、収束的な毛モデルにするのか、ちゃんと選んだほうがいいんだなぁと。陰毛の方に使用するのが無難な可能性もあります。腋は狭すぎるのかもしれません。※※※本マクロご使用上の際のご注意※※※エクセル上でのマクロの使用は、お使いのPC環境によっては、動作機能を著しく低下させる恐れがあります。本マクロご使用の際の前中後は、お使いのPCが安定した状態にあることを強く推奨いたします。※※※※※※※※※※※※※※※※※※※※！！！規則的毛モデルのルール追加！！！一本の毛の根元ほど、頂点インデックスNoは若く、毛先に近づいていくほど頂点インデックスNoは老番になっていくこと。！！！！！！！！！！！！！！！！！！！準備物・モデルビュー上選択頂点群の全情報を.CSV化/ Sub WAKIGE_S5_NAGAKU_x4_MORPH_UserInput()Dim y, x, y2, x2, r, s, ss, b, t, d, k, j, l As LongDim CX, CY, CZ, CX1, CY1, CZ1, CXt, CYt, CZt As DoubleDim Mname As StringDim sheet As Worksheety = 2x = 3y2 = 4x2 = 1r = 20s = 5ss = 5b = 16t = 0d = 0k = 0j = 1CX = 0CY = 0CZ = 0CX1 = 0CY1 = 0CZ1 = 0CXt = 0CYt = 0CZt = 0s = Application.InputBox(prompt:="毛モデル１本の底面の頂点数(角数)を数値のみで入力してください。", Type:=1, Default:=5) \', xpos:=1000, ypos:=2000If IsNumeric(s) = False Or s < 1 Then \'isnumeric(cells(yy,xx).value) = falseMsgBox "1 値以上を入力してください。マクロを中断します。"Exit SubEnd Ifss = sr = Application.InputBox(prompt:="毛モデル１本の曲がり箇所数を数値のみで入力してください。", Type:=1, Default:=20) \', xpos:=1000, ypos:=2000If IsNumeric(r) = False Or r < 1 Then \'isnumeric(cells(yy,xx).value) = falseMsgBox "1 値以上を入力してください。マクロを中断します。"Exit SubEnd Ifl = s * rl = 0b = Application.InputBox(prompt:="毛モデルを何倍長くするか、数値のみで入力してください。", Type:=1, Default:=4) \', xpos:=1000, ypos:=2000If IsNumeric(b) = False Or b < 1 Then \'isnumeric(cells(yy,xx).value) = falseMsgBox "1 値以上を入力してください。マクロを中断します。"Exit SubEnd Ifb = b - 1Mname = Application.InputBox(prompt:="モーフ名を入力してください。", Type:=3, Default:="腋毛長く(x" & b 1 & ")") \', xpos:=1000, ypos:=2000If Mname = "" ThenMsgBox "不適切な内容の入力です。マクロを中断します。"Exit SubEnd IfSet sheet = ActiveSheet \' 現在アクティブなシートを取得するWorksheets.Add After:=Worksheets(1)ActiveSheet.Name = MnameWorksheets(Mname).Cells(1, 1) = ";Morph"Worksheets(Mname).Cells(1, 2) = "モーフ名"Worksheets(Mname).Cells(1, 3) = "モーフ名(英)"Worksheets(Mname).Cells(1, 4) = "パネル(0:無効/1:眉(左下)/2:目(左上)/3:口(右上)/4:その他(右下))"Worksheets(Mname).Cells(1, 5) = "モーフ種類(0:グループモーフ/1:頂点モーフ/2:ボーンモーフ/3:UV(Tex)モーフ/4:追加UV1モーフ/5:追加UV2モーフ/6:追加UV3モーフ/7:追加UV4モーフ/8:材質モーフ/9:フリップモーフ/10:インパルスモーフ)"Worksheets(Mname).Cells(2, 1) = "Morph"Worksheets(Mname).Cells(2, 2) = MnameWorksheets(Mname).Cells(2, 3) = ""Worksheets(Mname).Cells(2, 4) = "4"Worksheets(Mname).Cells(2, 5) = "1"Worksheets(Mname).Cells(3, 1) = ";VertexMorph"Worksheets(Mname).Cells(3, 2) = "親モーフ名"Worksheets(Mname).Cells(3, 3) = "頂点Index"Worksheets(Mname).Cells(3, 4) = "位置オフセット_x"Worksheets(Mname).Cells(3, 5) = "位置オフセット_y"Worksheets(Mname).Cells(3, 6) = "位置オフセット_z"sheet.Activate \' シートをアクティブにするDo While Cells(y t, 2) <> ""Worksheets(Mname).Cells(y2 t, x2 2) = Cells(y t, 2)Worksheets(Mname).Cells(y2 t, x2) = "VertexMorph"Worksheets(Mname).Cells(y2 t, x2 1) = Mnamet = t 1LoopDo While Cells(y k, 2) <> ""For i = 0 To s - 1 Step 1CX = CX Cells(y i k, x 0)Next iCX = CX / sFor i = 0 To s - 1 Step 1CY = CY Cells(y i k, x 1)Next iCY = CY / sFor i = 0 To s - 1 Step 1CZ = CZ Cells(y i k, x 2)Next iCZ = CZ / s\'-------------------------------------------For i = 0 To s - 1 Step 1CX1 = CX1 Cells(y i k s, x 0)Next iCX1 = CX1 / sFor i = 0 To s - 1 Step 1CY1 = CY1 Cells(y i k s, x 1)Next iCY1 = CY1 / sFor i = 0 To s - 1 Step 1CZ1 = CZ1 Cells(y i k s, x 2)Next iCZ1 = CZ1 / s\'------------------------------------------------------------------------------------------For i = 0 To s - 1 Step 1Worksheets(Mname).Cells(y2 i k s, x2 3) = (CX1 - CX) * b CXtNext iCXt = CXt (CX1 - CX) * bCX = 0CX1 = 0For i = 0 To s - 1 Step 1Worksheets(Mname).Cells(y2 i k s, x2 4) = (CY1 - CY) * b CYtNext iCYt = CYt (CY1 - CY) * bCY = 0CY1 = 0For i = 0 To s - 1 Step 1Worksheets(Mname).Cells(y2 i k s, x2 5) = (CZ1 - CZ) * b CZtd = d 1Next iCZt = CZt (CZ1 - CZ) * bCZ = 0CZ1 = 0If d = s * (r 1) ThenCXt = 0CYt = 0CZt = 0d = 0End Ifk = k sLoop\'----------------------------------------------------------------------------------------Do While Worksheets(Mname).Cells(y2 l, x2 2) <> ""For i = 0 To s - 1 Step 1Worksheets(Mname).Cells(y2 i l, x2 3) = 0Next iFor i = 0 To s - 1 Step 1Worksheets(Mname).Cells(y2 i l, x2 4) = 0Next iFor i = 0 To s - 1 Step 1Worksheets(Mname).Cells(y2 i l, x2 5) = 0Next il = l s * (r 1)LoopFor i = 0 To s - 1 Step 1Worksheets(Mname).Rows(y2 t).DeleteNext i\'警告メッセージを表示しないApplication.DisplayAlerts = False\'アクティブシートを削除ActiveSheet.DeleteEnd Sub※ttps:/ ・`д・´)