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

作者コメント：

サムネ詐欺のようなマネをしてすまぬすまぬ・・※※※本マクロご使用上の際のご注意※※※エクセル上でのマクロの使用は、お使いのPC環境によっては、動作機能を著しく低下させる恐れがあります。本マクロご使用の際の前中後は、お使いのPCが安定した状態にあることを強く推奨いたします。※※※※※※※※※※※※※※※※※※※※！！！規則的毛モデルのルール追加！！！一本の毛の根元ほど、頂点インデックスNoは若く、毛先に近づいていくほど頂点インデックスNoは老番になっていくこと。！！！！！！！！！！！！！！！！！！！準備物・モデルビュー上選択頂点群の全情報を.CSV化/ Sub WAKIGEnemoto_HENSYUUyou_UserInput()Dim y, s, RowsDltSftUpSTART, r, l, i As Longy = 2s = 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 IfRowsDltSftUpSTART = y 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 * ri = 0Do While Len(Cells(RowsDltSftUpSTART (i * s), 1)) <> 0Rows(RowsDltSftUpSTART (i * s) & ":" & RowsDltSftUpSTART (i * s) (l - 1)).SelectSelection.Delete Shift:=xlUpi = i 1LoopEnd Sub改変用っぽいものPublic Sub WAKIGEnemoto_HENSYUUyou()Dim RowsDltSftUpSTART, i As LongRowsDltSftUpSTART = 7i = 0Do While Len(Cells(RowsDltSftUpSTART (i * 5), 1)) <> 0Rows(RowsDltSftUpSTART (i * 5) & ":" & RowsDltSftUpSTART (i * 5) 99).SelectSelection.Delete Shift:=xlUpi = i 1LoopEnd Sub毛を太くするモーフ追加用Public Sub TITIGE_S5_HUTOKU_x16_MORPH_UserInput()Dim y, x, r, s, ss, b, k, j, l As LongDim CX, CY, CZ As Doubley = 2x = 3r = 20s = 5ss = 5b = 16k = 0j = 1CX = 0CY = 0CZ = 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 * rb = Application.InputBox(prompt:="毛モデルを何倍太くするか、自然数の半角数値のみで入力してください。※本マクロでは毛モデルの先端部分は太くはなりません", Type:=1, Default:=16) \', xpos:=1000, ypos:=2000If IsNumeric(b) = False Or b < 1 Then \'isnumeric(cells(yy,xx).value) = falseMsgBox "1 値以上を入力してください。マクロを中断します。"Exit SubEnd Ifb = b - 1Do While Cells(y k, 2) <> ""\'If k <> s * r * j ThenFor 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 / sFor i = 0 To s - 1 Step 1Cells(y i k, x 0) = (Cells(y i k, x 0) - CX) * bNext iCX = 0For i = 0 To s - 1 Step 1Cells(y i k, x 1) = (Cells(y i k, x 1) - CY) * bNext iCY = 0For i = 0 To s - 1 Step 1Cells(y i k, x 2) = (Cells(y i k, x 2) - CZ) * bNext iCZ = 0\'Else\'j = j 1\'End Ifk = k sLoop\'-------------------------------------------------------------Do While Cells(y l, 2) <> ""For i = 0 To s - 1 Step 1Cells(y i l, x 0) = 0Next iFor i = 0 To s - 1 Step 1Cells(y i l, x 1) = 0Next iFor i = 0 To s - 1 Step 1Cells(y i l, x 2) = 0Next il = l s * (r 1)LoopEnd Sub