FC2ブログ

スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

遊んでみますか の2 


ライン(直線)コントロールは、フォームデザインで配置して・・・・
配置し直すにしても、位置を変更するだけで・・・

ってな使い方をしていました。

自由に傾き( LineSlant )を変更しながら、位置/大きさを変更出来たら
いろいろと表示できる幅が増えるんではなかろうか・・・・
(グラフっていう手もあるかもしれないけど)

例えば、以下の様な表示を考えると(・・・って、どうやって・・・は考えてませんけど)
kEnt132_Image
それぞれ四角部分はラベルかなんかにして、未着手/未完/完了 とかで背景色を変更するとか・・・
(知恵袋での質問でしたが、すぐに消えちゃいました)

ライン(直線)コントロールを自由に扱えるようにしといた方が良いのかな・・・
1本2本変更できたところで・・・・ということで

多角形を作って、それぞれの座標をライン(直線)コントロールで結んでみましょう。
非表示のライン(直線)コントロールを630本作っておいて、
(630本あれば、36角形が表示できたと思うので・・・・)
位置/大きさ/傾きを設定できたものから、Visible = True として表示しましょう。
その時、1本ごとに色を変えてみますか。
1本表示する間隔を指定できれば良いのかな・・・・タイマー時イベントを使いましょうか・・・・

kEnt132_F3  kEnt132_21  kEnt132_16  kEnt132_17_2
ってな表示になります。

再認識できましたが、タイマー時の TimerInterval 値は、目安であると・・・・
 

まずは、色用のテーブル「T1」を作っておきます。
「Cno」が色番号で、登録されている色番号(昇順)で、1本1本色を変更しながら・・・
(「CrR」「CrG」「CrB」は、色を構成する RGB 値になってます)

メインのフォーム「F2」

kEnt132_F2
円を指定した角形で割り、Sin / Cos で求めた座標を基本とします。
詳細部分には、非表示のライン(直線)コントロールを630個配置しておきます。
630本、手で作るのもしんどいので、VBA で作成します。
(標準モジュール MakeForm の Make1stStageForm 関数を実行)
Private Const IPX As Integer = 567
Private Const sFname As String = "F2"

Public Sub Make1stStageForm()
  Dim sS As String
  Dim i As Long
  Const LineCount As Long = 630

  With CreateForm
    sS = .Name
    .RecordSelectors = False
    .NavigationButtons = False
    .ScrollBars = 0
    .PopUp = True
    .Modal = True
    .HasModule = True
    DoCmd.RunCommand acCmdFormHdrFtr
    For i = 1 To LineCount
      With CreateControl(.Name, acLine, acDetail)
        .Name = "line" & i
        .Visible = False
        .Top = IPX * 4.5
        .Left = IPX * 3
        .Width = IPX * 3
        .Height = 0
      End With
    Next
    .Section(acHeader).Height = 0
    .Section(acDetail).Height = IPX * 9
    .Section(acFooter).Height = IPX * 1
    .Width = 567 * 9

    With CreateControl(.Name, acTextBox, acFooter)
      .Name = "txt1"
      .Top = IPX * 0.25
      .Left = IPX * 3
      .Width = IPX * 1.5
      .Height = IPX * 0.48
      .Format = "General Number"
      .TextAlign = 2
      .ValidationRule = ">=1"
      .ValidationText = "1 以上の数値を入力して"
    End With
    With CreateControl(.Name, acLabel, acFooter, "txt1")
      .Top = IPX * 0.25
      .Left = IPX * 0.2
      .Width = IPX * 2.5
      .Height = IPX * 0.48
      .Caption = "描画間隔(ms)"
    End With
    With CreateControl(.Name, acToggleButton, acFooter)
      .Name = "tg1"
      .Top = IPX * 0.15
      .Left = IPX * 6
      .Width = IPX * 2
      .Height = IPX * 0.7
    End With
  End With

  On Error Resume Next
  DoCmd.Close acForm, sS, acSaveYes
  DoCmd.Close acForm, sFname, acSaveNo
  DoCmd.DeleteObject acForm, sFname
  DoCmd.Rename sFname, acForm, sS
  DoCmd.OpenForm sFname, acDesign
End Sub

 
当初、詳細部分にライン(直線)コントロールを作成するだけだったのですが、どうせなので、
フッタ部分に、描画間隔用のテキストボックス「txt1」、開始用のトグルボタン「tg1」を配置。
円を描画する中心を、「詳細の高さ」か「フォームの幅」の小さいほうの中央になる様に考えます。
(高さ、幅ともに9cmにしたので、縦横それぞれ 4.5cm のところが中央に)
詳細部分には、ライン(直線)コントロールのみとしておきます。

ここで作成したフォーム「F2」が主役になっていきます。

起動された( Open )時、OpenArgs で何角形を指定されなかった時には11角形に。
指定された時には、その角形で基本となる座標を作っておきます。
読み込み( Load )時には、上記座標をフォーム上の数値にした座標として求めておきます。
また、テーブル「T1」から使用できる色を求めておきます。

トグルボタン「tg1」がクリックされら、
TimerInterval に値を設定し、タイマー時イベントを発生させます。

タイマー時イベントでは、
線を引こうとしている2つの座標から、Top / Left / Width / Height を求め設定します。
傾き( LineSlant )は、Top / Left の座標が、線を引こうとしていた座標のどちらかであれば、
右下がりの傾き( False )であり、一致するものが無ければ右上がり( True )
BorderColor に色を設定し、Visible = True とすれば1回の処理は終了になります。

フォーム「F2」に記述したのは以下
Private Const KakuDef As Long = 11
Private Const TGMSG1 As String = "開始"
Private Const TGMSG2 As String = "停止"
Private Const TGMSG3 As String = "再開"

Private Type dPosData
  x As Double
  y As Double
End Type
Private Type iPosData
  x As Long
  y As Long
End Type

Dim dPosXY() As dPosData
Dim myPos() As iPosData
Dim iCr() As Long
Dim myLine As Long
Dim myS As Long
Dim myE As Long

Private Function fncMin(v1 As Long, v2 As Long) As Long
  fncMin = v1
  If (v1 > v2) Then fncMin = v2
End Function

Private Function fncDist(v1 As Long, v2 As Long) As Long
  fncDist = Abs(v1 - v2)
End Function

Private Sub Form_Timer()
  myE = myE + 1
  If (myE > UBound(myPos)) Then
    myS = myS + 1
    If (myS >= UBound(myPos)) Then
      Me.TimerInterval = 0
      Me.tg1 = False
      Me.tg1.Caption = TGMSG1
      Exit Sub
    End If
    myE = myS + 1
  End If
  myLine = myLine + 1
  If (myLine > Me.Section(acDetail).Controls.Count) Then
    Me.TimerInterval = 0
    Me.tg1 = False
    Me.tg1.Caption = TGMSG1
    MsgBox "線の数が足りてません", vbCritical
    Exit Sub
  End If
  With Me("line" & myLine)
    .Top = fncMin(myPos(myS).y, myPos(myE).y)
    .Left = fncMin(myPos(myS).x, myPos(myE).x)
    .Width = fncDist(myPos(myS).x, myPos(myE).x)
    .Height = fncDist(myPos(myS).y, myPos(myE).y)
    .LineSlant = Not (((.Top = myPos(myS).y) And (.Left = myPos(myS).x)) _
            Or ((.Top = myPos(myE).y) And (.Left = myPos(myE).x)))
    .BorderColor = iCr((myLine - 1) Mod (UBound(iCr) + 1))
    .Visible = True
  End With
End Sub

Private Sub Form_Open(Cancel As Integer)
  Dim i As Long
  Dim d As Double

  If (Len(Nz(Me.OpenArgs)) = 0) Then
    i = KakuDef - 1
  Else
    i = Val(Me.OpenArgs) - 1
  End If
  ReDim dPosXY(i)
  d = 360 / (UBound(dPosXY) + 1)
  For i = 0 To UBound(dPosXY)
    With dPosXY(i)
      .x = Cos((d * i) * (3.14159 / 180))
      .y = Sin((d * i) * (3.14159 / 180))
    End With
  Next
End Sub

Private Sub init()
  Dim i As Long

  For i = 1 To Me.Section(acDetail).Controls.Count
    Me("line" & i).Visible = False
  Next
  myLine = 0
  myS = -1
  myE = UBound(myPos)
End Sub

Private Sub Form_Load()
  Dim rs As New ADODB.Recordset
  Dim i As Long
  Dim iTmp As Long

  ReDim iCr(0)
  iCr(0) = RGB(255, 0, 0)
  i = -1
  rs.Source = "SELECT * FROM T1 ORDER BY Cno;"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  While (Not rs.EOF)
    i = i + 1
    ReDim Preserve iCr(i)
    iCr(i) = RGB(rs("CrR"), rs("CrG"), rs("CrB"))
    rs.MoveNext
  Wend
  rs.Close

  iTmp = Me.Section(acDetail).Height
  If (iTmp > Me.Width) Then iTmp = Me.Width
  iTmp = iTmp \ 20
  ReDim myPos(UBound(dPosXY))
  For i = 0 To UBound(dPosXY)
    myPos(i).x = (iTmp * 10) + (dPosXY(i).x * (iTmp * 9))
    myPos(i).y = (iTmp * 10) - (dPosXY(i).y * (iTmp * 9))
  Next
  Me.Caption = UBound(myPos) + 1 & " 角形の描画"
  Me.txt1 = 20
  Me.tg1 = False
  Me.tg1.Caption = TGMSG1
  Call init
End Sub

Private Sub tg1_Click()
  If (Me.tg1) Then
    If (Me.tg1.Caption = TGMSG1) Then Call init
    Me.tg1.Caption = TGMSG2
    Me.TimerInterval = Me.txt1
  Else
    Me.tg1.Caption = TGMSG3
    Me.TimerInterval = 0
  End If
End Sub

 
2種類の座標を持つ内容になってますが、一箇所にまとめても良いです。
これ、作成している時、実数の座標は親側が用意して・・・グローバル変数で渡して・・・
とか、指定されなかった時でも最低限何かを表示したいな・・・・あれこれやっていて・・・
Form_Open では実数の座標で
Form_Load では出来上がっていた実数の座標をフォームに合わせた整数の座標に・・・
グローバル変数も必要無くなったね・・・・・X角形のXだけ渡せば良いね・・・と変遷

フォーム「F2」単独の起動では、11角形を表示するように。

では、X角形のXを指定するフォーム「F1」を作りましょうか・・・・


フォーム「F2」を起動するフォーム「F1」

X角形のXを入力するテキストボックス「txt1」と、
フォームを起動するコマンドボタン「btn1」を詳細部分に配置します。
非連結の単票フォームになるので、それなりの見栄えのフォームにします。
(レコードセレクタ:いいえ / 移動ボタン:いいえ ・・・・など)

以下を記述
Private Sub Form_Load()
  Me.txt1 = 13
End Sub

Private Sub btn1_Click()
  Me.txt1.SetFocus
  DoCmd.OpenForm "F2", , , , , , Me.txt1.Text
End Sub

 
表示する為に、他のフォーム「F2」を起動して、違う角数の表示にしたい時には一度フォームを閉じて・・・
操作が面倒ですよね。
ってことで、1つのフォームでやれたら操作は楽になるんでは・・・・
主のフォーム「F2」をサブフォームとして組み込んでみたいと思います。


メイン/サブ構成に(フォーム「F3」「F32」)

フォーム「F1」を「F3」、フォーム「F2」を「F32」としてコピーします。
フォーム「F3」をデザインビューで開いて、
フォーム「F32」をドラッグ&ドロップしてサブフォームとして「F3」に組み込みます。
サブフォームコントロール名は「F32」となるので、「FSUB」に変更します。
(私は、サブフォームコントロール名は「FSUB」に統一しているという事だけです)
その後、「FSUB」の「ソースオブジェクト」部分を空欄にします。

空欄にするのなら、ドラッグ&ドロップしないで、そのままサブフォームコントロールを配置すれば・・・
でもね、ドラッグ&ドロップすれば、必要な大きさでコントロールを作ってくれる・・・
(動き的にはこうなんだけど・・・・保証されてるのかなぁ・・・・・???)

で、X角形のXを、メインフォーム「F3」の「Tag」経由で伝えるようにします。

メイン(親)フォーム「F3」に記述したのは以下
Private Sub Form_Load()
  Me.txt1 = 13
End Sub

Private Sub btn1_Click()
  Me.Tag = Me.txt1
  Me.FSUB.SourceObject = "F32"
End Sub

 
サブ(子)フォーム「F32」で「F2」から変更した部分は以下
Private Sub Form_Open(Cancel As Integer)
  Dim i As Long
  Dim d As Double

  On Error Resume Next
  If (Me.Parent.Tag = "") Then
    i = KakuDef - 1
  Else
    i = Val(Me.Parent.Tag) - 1
  End If

  ReDim dPosXY(i)
  d = 360 / (UBound(dPosXY) + 1)
  For i = 0 To UBound(dPosXY)
    With dPosXY(i)
      .x = Cos((d * i) * (3.14159 / 180))
      .y = Sin((d * i) * (3.14159 / 180))
    End With
  Next
End Sub

 
つまり、サブフォームとして組み込まれていなければ 11角形にするし、
Tag 経由で X角形を指定されたら、その角数で・・・
(なので、「F32」単独起動では、11角形の表示となります)
kEnt132_F3

メイン(親)フォームでは、ボタン「btn1」がクリックされたら「Tag」を設定して、
ソースオブジェクトを設定します。
これにより、以前のサブフォームはクローズされ、新しく Form_Open から動作するフォームが
組み込まれることになります。
この方法は、以前の記事でも紹介していたと思います。


表示の変形(サンプルなし)

ここで、図形の表示を見せたい・・・・のであれば、1本1本色を変更していたら・・・いまいち。
なので、単色表示に切り替えてみます。

今回のサンプルで、単色にする方法は以下の3つあります。
・テーブル「T1」内の「CrR」「CrG」「CrB」を全て同じにする(設定した色で表示)
・テーブル「T1」のレコード件数を0にする(赤の単色で表示)
・以下のテーブル「T1」のアクセス部分を実行しない
Private Sub Form_Load()
  Dim rs As New ADODB.Recordset
  Dim i As Long
  Dim iTmp As Long

  ReDim iCr(0)
  iCr(0) = RGB(255, 0, 0)
  i = -1
  rs.Source = "SELECT * FROM T1 ORDER BY Cno;"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  While (Not rs.EOF)
    i = i + 1
    ReDim Preserve iCr(i)
    iCr(i) = RGB(rs("CrR"), rs("CrG"), rs("CrB"))
    rs.MoveNext
  Wend
  rs.Close


  iTmp = Me.Section(acDetail).Height
  If (iTmp > Me.Width) Then iTmp = Me.Width
  iTmp = iTmp \ 20
  ReDim myPos(UBound(dPosXY))
  For i = 0 To UBound(dPosXY)
    myPos(i).x = (iTmp * 10) + (dPosXY(i).x * (iTmp * 9))
    myPos(i).y = (iTmp * 10) - (dPosXY(i).y * (iTmp * 9))
  Next
  Me.Caption = UBound(myPos) + 1 & " 角形の描画"
  Me.txt1 = 20
  Me.tg1 = False
  Me.tg1.Caption = TGMSG1
  Call init
End Sub

 
次の画像は上記をコメントにしただけ
kEnt132_21

また、
  iCr(0) = RGB(255, 0, 0)

  iCr(0) = RGB(128, 128, 128)
にしたのが以下の画面
kEnt132_17

また、座標を作る際に、歪みを付けるために
  For i = 0 To UBound(dPosXY)
    With dPosXY(i)
      .x = Cos((d * i) * (3.14159 / 180))
      .y = Sin((d * i) * (3.14159 / 180))
    End With
  Next

  For i = 0 To UBound(dPosXY)
    With dPosXY(i)
      .x = Cos((d * i) * (3.14159 / 180))
      .y = Sin((d * i) * (3.14159 / 180)) * 0.6
    End With
  Next
にしたのが以下の画面
kEnt132_17_2

正式な楕円ではないと思いますが、楕円モドキと言う事で・・・・


なお、色の設定を確認する為のフォームとして「FT」「FTS」
これは、メイン「FT」/サブ「FTS」構成のもので、テーブル「T1」の「Cno」0~11までを表示
実際に表示するものは、サブ側「FTS」
表示対象は、親「FT」で、サブフォームコントロールのソースオブジェクトにフォームを指定した後、
Filter で「Cno」を0~11を指定することに・・・


どんな感じでしょう・・・・



サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt132_2000.zipkEnt132_2003.zipkEnt132_2007.zip
 サイズ 82,16183,57286,683
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化

関連記事

2012/05/29

Category: やってみる

TB: --  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。