Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


12090 / 13645 ツリー ←次へ | 前へ→

【12403】ひし形 nyan 04/4/2(金) 15:24 質問
【12407】Re:ひし形 IROC 04/4/2(金) 15:56 回答
【12412】Re:ひし形 nyan 04/4/2(金) 16:57 質問
【12413】Re:ひし形 Asaki 04/4/2(金) 17:03 回答
【12414】Re:ひし形 nyan 04/4/2(金) 17:09 質問
【12417】Re:ひし形 IROC 04/4/2(金) 17:24 回答
【12418】Re:ひし形 Asaki 04/4/2(金) 17:28 回答
【12420】Re:ひし形 nyan 04/4/2(金) 17:33 質問
【12421】Re:ひし形 Asaki 04/4/2(金) 17:38 回答
【12422】Re:ひし形 nyan 04/4/2(金) 17:46 質問
【12423】Re:ひし形 IROC 04/4/2(金) 18:03 回答
【12424】Re:ひし形 Asaki 04/4/2(金) 18:19 回答
【12429】Re:ひし形 ichinose 04/4/3(土) 0:31 発言
【12430】Re:ひし形(訂正) ichinose 04/4/3(土) 0:46 発言
【12438】Re:ひし形 ichinose 04/4/4(日) 0:22 回答

【12403】ひし形
質問  nyan  - 04/4/2(金) 15:24 -

引用なし
パスワード
   値によって変更できるひし形って作れますでしょうか?

【12407】Re:ひし形
回答  IROC  - 04/4/2(金) 15:56 -

引用なし
パスワード
   >変更

なにをですか?

【12412】Re:ひし形
質問  nyan  - 04/4/2(金) 16:57 -

引用なし
パスワード
   ひし形の形です。

【12413】Re:ひし形
回答  Asaki  - 04/4/2(金) 17:03 -

引用なし
パスワード
   こんにちは。

>ひし形の形です。
それはわかりますが、何をどう変えるのですか?
大きさ?高さ?幅?角度?回転とか?

【12414】Re:ひし形
質問  nyan  - 04/4/2(金) 17:09 -

引用なし
パスワード
   右斜め45度の線と真横の線を上下に変えれたらと考えています。

【12417】Re:ひし形
回答  IROC  - 04/4/2(金) 17:24 -

引用なし
パスワード
   >右斜め45度の線と真横の線を上下に変えれたらと考えています。

上下に何を変えるの? 位置? 移動させたいということ?

【12418】Re:ひし形
回答  Asaki  - 04/4/2(金) 17:28 -

引用なし
パスワード
   >>右斜め45度の線と真横の線を上下に変えれたらと考えています。
>上下に何を変えるの? 位置? 移動させたいということ?
あと、「真横の線」っていう表現が何を指しているのかがわからないんですけど。

【12420】Re:ひし形
質問  nyan  - 04/4/2(金) 17:33 -

引用なし
パスワード
   ひし形の上下の線と斜めの線を上下に動かしたいです。

【12421】Re:ひし形
回答  Asaki  - 04/4/2(金) 17:38 -

引用なし
パスワード
   >ひし形の上下の線と斜めの線を上下に動かしたいです。
すみません。
ほんとにひし形ですか?
平行四辺形では?

【12422】Re:ひし形
質問  nyan  - 04/4/2(金) 17:46 -

引用なし
パスワード
   あっ ごんなさい
勘違いしていました。 平行四辺形です。

【12423】Re:ひし形
回答  IROC  - 04/4/2(金) 18:03 -

引用なし
パスワード
   もっと目的とするマクロの仕様を詳しく書いては如何でしょうか?

数値の指定方法とか、
ユーザーインターフェースとか、
図形はあらかじめ配置してあるのかとか
図形の指定方法とか・・・

このままでは、回答でなく質問の繰り返しになってしまいます。

【12424】Re:ひし形
回答  Asaki  - 04/4/2(金) 18:19 -

引用なし
パスワード
   とりあえず、図形をいじくる手作業を、マクロの記録でコード化してみて、参考にされては如何でしょうか?

【12429】Re:ひし形
発言  ichinose  - 04/4/3(土) 0:31 -

引用なし
パスワード
   ▼nyan さん、皆さん、こんばんは。
サンプルを作ってみました。
'==============================================================
Const stx = 135
Const sty = 275
Const edx = 395
Const edy = 175
'==============================================================
Sub Mk_Parallelogram()
  Dim p_x(1 To 4) As Double '平行四辺形の4角のx
  Dim p_y(1 To 4) As Double '平行四辺形の4角のY
  Dim para As Shape '平行四辺形のShapeオブジェクト
  Dim cx As Double '対角線の交わるx
  Dim cy As Double '対角線が交わるY
  Dim rl As Double '指定した直線の長さの半分(対角線の長さ)/2
  Dim rs As Double 'もうひとつの対角線の長さ/2
  Dim pai As Double '円周率
  pai = WorksheetFunction.pi()
  p_x(2) = edx: p_y(2) = edy
  p_x(4) = stx: p_y(4) = sty
 
  rl = Sqr((edx - stx) ^ 2 + (edy - sty) ^ 2) / 2
  rs = rl * 2
  cx = Abs(edx + stx) / 2
  cy = Abs(edy + sty) / 2
  rs = rl / 2
  p_y(1) = cy
  p_y(3) = cy
  p_x(1) = cx - rs
  p_x(3) = cx + rs
  With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, p_x(1), p_y(1))
   For idx = 2 To 4
     .AddNodes msoSegmentLine, msoEditingAuto, p_x(idx), p_y(idx)
     Next idx
   .AddNodes msoSegmentLine, msoEditingAuto, p_x(1), p_y(1)
   Set para = .ConvertToShape
   End With
  MsgBox "平行四辺形が作れた?"
  '真横の対角線が縦になるまで移動
  With para
    For rr = 0 To pai / 2 Step 0.001
     .Nodes.SetPosition 3, cx + rs * Cos(rr), cy + rs * Sin(rr)
     .Nodes.SetPosition 1, cx + rs * Cos(rr + pai), cy + rs * Sin(rr + pai)
     Next
    End With
End Sub

対角線を意識して考えました。
Constの値を(stx<edx かつsty>edy)の条件を満たす範囲の
値に設定して実行してみて下さい。



と、ここまで書いてnyan さんの意図していることと違っている事に
気が付きました・・・。

でも、参考程度にはなりますか?
要は、平行四辺形を作成した後、円の奇跡で4角の内の2点を移動させると言う事です。
例では、対角を移動していますが・・・。

【12430】Re:ひし形(訂正)
発言  ichinose  - 04/4/3(土) 0:46 -

引用なし
パスワード
   仕様が違っているので訂正しても・・・
と思いましたが、一応・・・。

>サンプルを作ってみました。
>'==============================================================
>Const stx = 135
>Const sty = 275
>Const edx = 395
>Const edy = 175
>'==============================================================
>Sub Mk_Parallelogram()
>  Dim p_x(1 To 4) As Double '平行四辺形の4角のx
>  Dim p_y(1 To 4) As Double '平行四辺形の4角のY
>  Dim para As Shape '平行四辺形のShapeオブジェクト
>  Dim cx As Double '対角線の交わるx
>  Dim cy As Double '対角線が交わるY
>  Dim rl As Double '指定した直線の長さの半分(対角線の長さ)/2
>  Dim rs As Double 'もうひとつの対角線の長さ/2
>  Dim pai As Double '円周率
>  pai = WorksheetFunction.pi()
>  p_x(2) = edx: p_y(2) = edy
>  p_x(4) = stx: p_y(4) = sty
> 
>  rl = Sqr((edx - stx) ^ 2 + (edy - sty) ^ 2) / 2
>  rs = rl * 2
>  cx = Abs(edx + stx) / 2
>  cy = Abs(edy + sty) / 2
>  rs = rl / 2
>  p_y(1) = cy
>  p_y(3) = cy
>  p_x(1) = cx - rs
>  p_x(3) = cx + rs
>  With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, p_x(1), p_y(1))
>   For idx = 2 To 4
>     .AddNodes msoSegmentLine, msoEditingAuto, p_x(idx), p_y(idx)
>     Next idx
>   .AddNodes msoSegmentLine, msoEditingAuto, p_x(1), p_y(1)
>   Set para = .ConvertToShape
>   End With
  doevents '←これ入れといて
>  MsgBox "平行四辺形が作れた?"
>  '真横の対角線が縦になるまで移動
>  With para
>    For rr = 0 To pai / 2 Step 0.001
>     .Nodes.SetPosition 3, cx + rs * Cos(rr), cy + rs * Sin(rr)
>     .Nodes.SetPosition 1, cx + rs * Cos(rr + pai), cy + rs * Sin(rr + pai)
>     Next
>    End With
>End Sub
>
>対角線を意識して考えました。
>Constの値を(stx<edx かつsty>edy)の条件を満たす範囲の
>値に設定して実行してみて下さい。
>・
>・
>・
>と、ここまで書いてnyan さんの意図していることと違っている事に
>気が付きました・・・。
>
>でも、参考程度にはなりますか?
>要は、平行四辺形を作成した後、円の奇跡で4角の内の2点を移動させると言う事です。
>例では、対角を移動していますが・・・。

【12438】Re:ひし形
回答  ichinose  - 04/4/4(日) 0:22 -

引用なし
パスワード
   こんばんは。
再挑戦です。

>要は、平行四辺形を作成した後、円の奇跡で4角の内の2点を移動させると言う事です。
軌跡でした(実は、これ訂正するためにコード作ったりして・・)。

以下のコードで
>右斜め45度の線と真横の線
の平行四辺形が作成できると思います。

'=================================================================
Const stx = 150
Const sty = 100
Const edx = 300
Const edy = 220
'=================================================================
Sub Mk_Parallelogram2()
  Dim p_x(1 To 4) As Double '平行四辺形の4角のx
  Dim p_y(1 To 4) As Double '平行四辺形の4角のY
  Dim para As Shape '平行四辺形のShapeオブジェクト
  Dim rs As Double
  Dim pai As Double '円周率
  If stx < edx And sty < edy Then
   If stx - (edy - sty) >= 0 Then
   Else
     MsgBox "回転できませんから、処理中止"
     Exit Sub
     End If
   End If
  pai = WorksheetFunction.pi()
  p_x(1) = stx: p_y(1) = sty
  p_x(2) = edx: p_y(2) = sty
  p_x(3) = edx: p_y(3) = edy
  p_x(4) = stx: p_y(4) = edy
  rs = edy - sty
  With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, p_x(1), p_y(1))
   For idx = 2 To 4
     .AddNodes msoSegmentLine, msoEditingAuto, p_x(idx), p_y(idx)
     Next idx
   .AddNodes msoSegmentLine, msoEditingAuto, p_x(1), p_y(1)
   Set para = .ConvertToShape
   End With
  DoEvents
  MsgBox "この四角形の上二つの頂点を右45°に傾けます"
  With para
    rr = -pai / 4
    .Nodes.SetPosition 1, p_x(4) + rs * Cos(rr), p_y(4) + rs * Sin(rr)
    .Nodes.SetPosition 2, p_x(3) + rs * Cos(rr), p_y(3) + rs * Sin(rr)
    p_x(1) = p_x(4) + rs * Cos(rr): p_y(1) = p_y(4) + rs * Sin(rr)
    p_x(2) = p_x(3) + rs * Cos(rr): p_y(2) = p_y(3) + rs * Sin(rr)
    DoEvents
    MsgBox "平行四辺形が作れた? ここから、右回り1回転します"
    For rr = -pai / 4 To -pai / 4 + pai * 2 Step 0.001
     .Nodes.SetPosition 1, p_x(4) + rs * Cos(rr), p_y(4) + rs * Sin(rr)
     .Nodes.SetPosition 2, p_x(3) + rs * Cos(rr), p_y(3) + rs * Sin(rr)
     Next
    MsgBox "今度は、軸を変えて右回り1回転します"
    For rr = pai * 3 / 4 To pai * 3 / 4 + pai * 2 Step 0.001
     .Nodes.SetPosition 3, p_x(2) + rs * Cos(rr), p_y(2) + rs * Sin(rr)
     .Nodes.SetPosition 4, p_x(1) + rs * Cos(rr), p_y(1) + rs * Sin(rr)
     Next
    End With
End Sub

Constの値を「stx<edx 且つ sty<edy」の条件下で設定してみて下さい。
前回と同じ様に2角を回転させましたが、

>右斜め45度の線と真横の線を上下に変えれたらと考えています。

の意味が他の意味合いだったら又考えます(平行移動だったらIncrementTopや
IncrementLeftでもいいかも・・)。

確認してみて下さい。

12090 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free