Excel VBA質問箱 IV

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

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


7139 / 13644 ツリー ←次へ | 前へ→

【39378】線のトリムって出来ないでしょうか? カド 06/6/23(金) 8:24 質問[未読]
【39390】Re:線のトリムって出来ないでしょうか? ichinose 06/6/23(金) 10:05 発言[未読]
【39397】Re:線のトリムって出来ないでしょうか?... ichinose 06/6/23(金) 11:34 発言[未読]
【39400】Re:線のトリムって出来ないでしょうか?... ichinose 06/6/23(金) 12:38 発言[未読]
【40754】Re:線のトリムって出来ないでしょうか?... カド 06/7/22(土) 18:42 お礼[未読]
【40767】Re:線のトリムって出来ないでしょうか?... ichinose 06/7/23(日) 14:53 発言[未読]
【40821】Re:線のトリムって出来ないでしょうか?... カド 06/7/24(月) 19:21 お礼[未読]
【40832】Re:線のトリムって出来ないでしょうか?... ichinose 06/7/24(月) 22:44 発言[未読]
【40954】Re:線のトリムって出来ないでしょうか?... わいわい 06/7/26(水) 19:03 発言[未読]
【40968】Re:線のトリムって出来ないでしょうか?... わいわい 06/7/27(木) 9:12 発言[未読]

【39378】線のトリムって出来ないでしょうか?
質問  カド  - 06/6/23(金) 8:24 -

引用なし
パスワード
   2本の線が交わるように描画すると、”X”こんな形になりますが、
これをトリムすると”<”、”>”こんな感じになります。

これがマクロで出来たら描画が楽になって大変便利なのですが、
こんなことって出来ますでしょうか?


また、角部がRに出来ると更に最高なのですが、可能でしょうか?

【39390】Re:線のトリムって出来ないでしょうか?
発言  ichinose  - 06/6/23(金) 10:05 -

引用なし
パスワード
   ▼カド さん:
おはようございます。


>2本の線が交わるように描画すると、”X”こんな形になりますが、
>これをトリムすると”<”、”>”こんな感じになります。
こんな図形が作成可能なら他の方法でもと言うのなら、

線をつなげてグループ化すると同じような図形が作成できますよね?
新規ブックの標準モジュールに
'==============================================================
Sub test()
  Dim rad As Double
  rad = WorksheetFunction.pi() / 4
  Call mk_hutougou([b5].Left, [b5].Top, 20, rad, , False)
  Call mk_hutougou([b5].Left, [b5].Top, 20, rad, , True)
End Sub

'=====================================================================

Function mk_hutougou(ByVal stx As Double, ByVal sty As Double, rs As Double, rad As Double, Optional sht As Worksheet = Nothing, Optional opn As Boolean = False) As Shape
  '不等号を作成する
  ' input stx 不等号始点となるLeft
  '    sty 不等号始点となるtop
  '    rs 半径距離
  '    rad 角度 Radian
  '    sht 作成するシート
  '    opn false 右開き true 左開き
  Dim pi As Double
  Dim l1 As Line
  Dim l2 As Line
  Dim crad As Double
  Dim srad As Double
  pi = WorksheetFunction.pi()
  srad = rad / 2
  crad = rad / 2
  If opn = True Then crad = crad + pi
  If sht Is Nothing Then Set sht = ActiveSheet
  Set l1 = sht.Lines.Add(stx, sty, stx + rs * Cos(-crad), sty + rs * Sin(-srad))
  Set l2 = sht.Lines.Add(stx, sty, stx + rs * Cos(-crad), sty + rs * Sin(srad))
  Set mk_hutougou = sht.Shapes.Range(Array(l1.Name, l2.Name)).Group
End Function

でサンプルを作成してみてください。


セルB5の左上を始点に45度の角度で右・左開きで作成しています。

トリミングでも上記を応用すれば出来るかもしれませんが・・・。

試してみてください。

【39397】Re:線のトリムって出来ないでしょうか?...
発言  ichinose  - 06/6/23(金) 11:34 -

引用なし
パスワード
   関数内のコードはもっと簡単でした


>新規ブックの標準モジュールに
>'==============================================================
>Sub test()
>  Dim rad As Double
>  rad = WorksheetFunction.pi() / 4
>  Call mk_hutougou([b5].Left, [b5].Top, 20, rad, , False)
>  Call mk_hutougou([b5].Left, [b5].Top, 20, rad, , True)
>End Sub
>'=====================================================================

Function mk_hutougou(ByVal stx As Double, ByVal sty As Double, ByVal rs As Double, ByVal rad As Double, Optional ByVal sht As Worksheet = Nothing, Optional ByVal opn As Boolean = False) As Shape
  '不等号を作成する
  ' input stx 不等号始点となるLeft
  '    sty 不等号始点となるtop
  '    rs 半径距離
  '    rad 角度 Radian 0〜π
  '    sht 作成するシート
  '    opn false 右開き true 左開き
  Dim pi As Double
  Dim l1 As Line
  Dim l2 As Line
  pi = WorksheetFunction.pi()
  If opn = True Then rad = 2 * pi - rad
  If sht Is Nothing Then Set sht = ActiveSheet
  Set l1 = sht.Lines.Add(stx, sty, stx + rs * Cos(rad / 2), sty + rs * Sin(-rad / 2))
  Set l2 = sht.Lines.Add(stx, sty, stx + rs * Cos(rad / 2), sty + rs * Sin(rad / 2))
  Set mk_hutougou = sht.Shapes.Range(Array(l1.Name, l2.Name)).Group
(l1.Name, l2.Name)).Group
>End Function

【39400】Re:線のトリムって出来ないでしょうか?...
発言  ichinose  - 06/6/23(金) 12:38 -

引用なし
パスワード
   ▼ichinose さん:
余計なコードが入っていました。

>
>>新規ブックの標準モジュールに
>>'==============================================================
>>Sub test()
>>  Dim rad As Double
>>  rad = WorksheetFunction.pi() / 4
>>  Call mk_hutougou([b5].Left, [b5].Top, 20, rad, , False)
>>  Call mk_hutougou([b5].Left, [b5].Top, 20, rad, , True)
>>End Sub
>>'=====================================================================
>
>Function mk_hutougou(ByVal stx As Double, ByVal sty As Double, ByVal rs As Double, ByVal rad As Double, Optional ByVal sht As Worksheet = Nothing, Optional ByVal opn As Boolean = False) As Shape
>  '不等号を作成する
>  ' input stx 不等号始点となるLeft
>  '    sty 不等号始点となるtop
>  '    rs 半径距離
>  '    rad 角度 Radian 0〜π
>  '    sht 作成するシート
>  '    opn false 右開き true 左開き
>  Dim pi As Double
>  Dim l1 As Line
>  Dim l2 As Line
>  pi = WorksheetFunction.pi()
>  If opn = True Then rad = 2 * pi - rad
>  If sht Is Nothing Then Set sht = ActiveSheet
>  Set l1 = sht.Lines.Add(stx, sty, stx + rs * Cos(rad / 2), sty + rs * Sin(-rad / 2))
>  Set l2 = sht.Lines.Add(stx, sty, stx + rs * Cos(rad / 2), sty + rs * Sin(rad / 2))
>  Set mk_hutougou = sht.Shapes.Range(Array(l1.Name, l2.Name)).Group
' (l1.Name, l2.Name)).Group
>>End Function

【40754】Re:線のトリムって出来ないでしょうか?...
お礼  カド  - 06/7/22(土) 18:42 -

引用なし
パスワード
   ▼ichinose さん 回答ありがとうございます。
お礼がものすごくおそくなりました。

折角回答頂きましたが、任意の交わっている線をトリムできるマクロが
出来たらいいなと思いましたが、教えていただいたものはちょっと
違ってました。

また、貴殿のコードを改良する技量も持ち合わせておらず、
今回は断念します。

【40767】Re:線のトリムって出来ないでしょうか?...
発言  ichinose  - 06/7/23(日) 14:53 -

引用なし
パスワード
   ▼カド さん:
こんにちは。

>折角回答頂きましたが、任意の交わっている線をトリムできるマクロが
>出来たらいいなと思いましたが、教えていただいたものはちょっと
>違ってました。

>今回は断念します。
と仰っているのですが、トリミングでも出来ると思っていたので
投稿します。
トリミングするためには図として再作成しなければならないと思います。


新規ブックの標準モジュールに
'======================================================
Sub main()
  Dim ww As Double
  Dim wk As Double
  Dim ln1 As Shape
  Dim ln2 As Shape
  Dim trm As Double
  Dim shp As Shape
  With Range("f10:g16")
    ww = .Width
    Set ln1 = ActiveSheet.Shapes.AddLine(.Left, .Top, .Left + .Width, .Top + .height)
    Set ln2 = ActiveSheet.Shapes.AddLine(.Left, .Top + .height, .Left + .Width, .Top)
    DoEvents
    MsgBox "元になる二つの交差する直線"
   
    Set shp = cnv_pic(ln1, ln2)
    With shp
     wk = .Width - ww
     trm = (.Width - wk) / 2
     .PictureFormat.CropLeft = trm
     DoEvents
     MsgBox "<作成"
     .PictureFormat.CropLeft = 0
     .PictureFormat.CropRight = .Width - trm
     DoEvents
     MsgBox ">作成"
     End With
    End With
End Sub
'==================================================================
Function cnv_pic(shp1 As Shape, shp2 As Shape) As Shape
'指定されたShapeをグループ化し、図として再作成する
  Dim l As Double, t As Double
  Dim gshp As Shape
  Set gshp = shp1.Parent.Shapes.Range(Array(shp1.Name, shp2.Name)).Group
  l = gshp.Left
  t = gshp.Top
  gshp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  Set cnv_pic = shp1.Parent.Pictures.Paste.ShapeRange(1)
  With cnv_pic
    .Left = l
    .Top = t
    End With
  gshp.Delete
End Function

これで、mainを実行して確認してみて下さい

「<」と「>」を順にトリミングで作成しています。

最終的に作成された「>」の図も
「右クリック」---「図の書式設定」とクリックし、
「図」タブの「トリミング範囲」で設定することで別のトリミングも可能です。

試してみて下さい。

>また、貴殿のコードを改良する技量も持ち合わせておらず、

上記のコードだって恐らく変更しなければ
使えないと思います。
その時間が持てないのであれば、それは仕方ないですね!!

【40821】Re:線のトリムって出来ないでしょうか?...
お礼  カド  - 06/7/24(月) 19:21 -

引用なし
パスワード
   ▼ichinose さん 何度もありがとうございます。
どうしても図形になると分からないことが多すぎるのですが。

例えば、最初から4本の直線が引かれているとします。
このうちの2本をクリックして選び、
この状態でマクロを走らせるとトリムされることを実現したいのです。

もし簡単に分かるようでしたらお教えください。
面倒でしたら、無視してください。

この返信はあくまでもお礼がしたかっただけで、
答えをリクエストしているわけではありません。

文章ではなかなか思いを的確に伝えることが出来ませんが、
あくまでもお礼のレスです。
いつもありがとうございます。m(__)m

【40832】Re:線のトリムって出来ないでしょうか?...
発言  ichinose  - 06/7/24(月) 22:44 -

引用なし
パスワード
   ▼カド さん:
こんばんは。
新規ブックの標準モジュールに

'======================================================
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'======================================
Sub mk_line()
  With Range("f10:g16")
    ActiveSheet.Shapes.AddLine .Left, .Top, .Left + .Width, .Top + .Height
    ActiveSheet.Shapes.AddLine .Left, .Top + .Height, .Left + .Width, .Top
    ActiveSheet.Shapes.AddLine .Left + .Width / 3, .Top, .Left + .Width / 3, .Top + .Height
    ActiveSheet.Shapes.AddLine .Left, .Top + .Height / 3, .Left + .Width, .Top + .Height / 3
    End With
End Sub
'===========================================================
Sub main()
  Dim ww As Double
  Dim ln1 As Shape
  Dim ln2 As Shape
  Dim trm As Double
  Dim shp As Shape
  Set ln1 = Selection.ShapeRange(1)
  Set ln2 = Selection.ShapeRange(2)
  Set shp = cnv_pic(ln1, ln2)
  With shp
    .Select
    trm = 0
    ww = .Width
    On Error Resume Next
    Do While trm <= 100
     Err.Clear
     .PictureFormat.CropLeft = trm / 100 * ww
     Sleep 50
     DoEvents
     If Selection.Name <> .Name Then Exit Do
     If Err.Number <> 0 Then Exit Do
     trm = trm + 1
     Loop
    On Error GoTo 0
    End With
End Sub
'==================================================================
Function cnv_pic(shp1 As Shape, shp2 As Shape) As Shape
'指定されたShapeをグループ化し、図として再作成する
  Dim l As Double, t As Double
  Dim gshp As Shape
  Set gshp = shp1.Parent.Shapes.Range(Array(shp1.Name, shp2.Name)).Group
  l = gshp.Left
  t = gshp.Top
  gshp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  Set cnv_pic = shp1.Parent.Pictures.Paste.ShapeRange(1)
  With cnv_pic
    .Left = l
    .Top = t
    End With
  gshp.Delete
End Function


まず、mk_lineを実行して、交差する4本の線を作図します。

この4本の中から、2本の線を選択した状態で(Shiftを押しながら二つ線を選択します)
mainを実行します。

少しずつトリミングしていきます。止めたい箇所で適当なセルを選択してください。
(トリミング中はセルを選択していません。監視していてセルが選択されると
トリミングを中止します)

試してみて下さい。

【40954】Re:線のトリムって出来ないでしょうか?...
発言  わいわい  - 06/7/26(水) 19:03 -

引用なし
パスワード
   自分の作業が煮詰まったので試しに作ってみました。いつものごとく不恰好なリストですので、恥ずかしいのですが見てやってください。

(1)先ずUserForm1を作りLabel1とCommboButton1適当に配置して下さい。
(2)UserForm1に以下のコード貼り付けてください。
========================================================
Private Sub CommandButton1_Click()
  With Selection
    Select Case T_step
      Case 0
        '切断する線の名前の取得
        Line_Name = .Name
        '切断する線の状態取得
        H_Flip = .ShapeRange.HorizontalFlip
        V_Flip = .ShapeRange.VerticalFlip
        If H_Flip = 0 Then
          x_01 = .Left
          x_02 = .Left + .Width
        Else
          x_01 = .Left + .Width
          x_02 = .Left
        End If
        If V_Flip = 0 Then
          y_01 = .Top
          y_02 = .Top + .Height
        Else
          y_01 = .Top + .Height
          y_02 = .Top
        End If
        'y=α1 x + β1 を取得
        If x_01 = x_02 Then
          α1 = 10 ^ 10: β1 = -x_01
        ElseIf y_01 = y_02 Then
          α1 = 0: β1 = y_01
        Else
          α1 = (y_02 y_01 /(x_02 - x_01): β1 = y_01 - α1 * x_01
        End If
        Cells(1, 1).Value = x_01: Cells(1, 2).Value = y_01
        Cells(1, 3).Value = x_02: Cells(1, 4).Value = y_02
        Cells(1, 5).Value = α1: Cells(1, 6).Value = β1
        UserForm1.Label1.Caption = "切断基準になる線を選択した後CommandButtonを押して下さい。"
      Case 1
        '切断基準になる線の状態取得
        H_Flip = .ShapeRange.HorizontalFlip
        V_Flip = .ShapeRange.VerticalFlip
        If H_Flip = 0 Then
          x_11 = .Left
          x_12 = .Left + .Width
        Else
          x_11 = .Left + .Width
          x_12 = .Left
        End If
        If V_Flip = 0 Then
          y_11 = .Top
          y_12 = .Top + .Height
        Else
          y_11 = .Top + .Height
          y_12 = .Top
        End If
        'y=α2 x + β2 を取得
        If x_11 = x_12 Then
          α2 = 10 ^ 10: β2 = -x_11
        ElseIf y_11 = y_12 Then
          α2 = 0: β2 = y_11
        Else
          α2 = (y_12-y_11) / (x_12-x_11): β2 = y_11- α2 * x_11
        End If
        '交点の取得
        If α1 = α2 Then MsgBox "2直線が平行で交わりません。終了します。": T_step = 0: Exit Sub
        x_03 = (β2 - β1) / (α1 - α2)
        y_03 = α1 * x_03 + β1
        
        Cells(2, 1).Value = x_11: Cells(2, 2).Value = y_11
        Cells(2, 3).Value = x_12: Cells(2, 4).Value = y_12
        Cells(2, 5).Value = α2: Cells(2, 6).Value = β2
        Cells(3, 1).Value = x_03: Cells(3, 2).Value = y_03

        dx = 0.5 '交差判定の制度dxが大きいほど甘い
        If x_01 < x_02 Then
         If x_01-dx < x_03 And x_03 < x_02 + dx Then Else GoTo 10
        Else
         If x_01+dx > x_03 And x_03 > x_02 - dx Then Else GoTo 10
        End If
        If x_11 < x_12 Then
         If x_11-dx < x_03 And x_03 < x_12 + dx Then Else GoTo 10
        Else
         If x_11+dx > x_03 And x_03 > x_12 - dx Then Else GoTo 10
        End If
        
        UserForm1.Label1.Caption = "切断する部位の近くでダブルクリックして下さい。"
      Case Else
        MsgBox "CommandButtonでは無く、切断する部位の近くでダブルクリックして下さい。": Exit Sub
    End Select
    T_step = T_step + 1
  End With
Exit Sub
10:
  MsgBox "2直線の交点が線上に存在しません。終了します。"
End Sub

(3)次に標準モジュールに以下を貼付、線図作成はichinoseさんのをお借りします
'======================================================
Public T_step As Integer
Public Line_Name As String
Public α1 As Double
Public β1 As Double
Public α2 As Double
Public β2 As Double
Public x_01 As Double
Public x_02 As Double
Public x_03 As Double
Public x_04 As Double
Public x_11 As Double
Public x_12 As Double
Public y_01 As Double
Public y_02 As Double
Public y_03 As Double
Public y_04 As Double
Public y_11 As Double
Public y_12 As Double
'

'======================================
Sub mk_line()
  With Range("f10:g16")
    ActiveSheet.Shapes.AddLine .Left, .Top, .Left + .Width, .Top + .Height
    ActiveSheet.Shapes.AddLine .Left, .Top + .Height, .Left + .Width, .Top
    ActiveSheet.Shapes.AddLine .Left + .Width / 3, .Top, .Left + .Width / 3, .Top + .Height
    ActiveSheet.Shapes.AddLine .Left, .Top + .Height / 3, .Left + .Width, .Top + .Height / 3
    End With
End Sub

(4)Sheet1に以下を貼り付ける。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  With Target
    x_04 = .Left
    y_04 = .Top
  End With
  ActiveSheet.Shapes(Line_Name).Select
  With Selection
    If T_step = 2 Then
      len_01 = (x_01 - x_04) ^ 2 + (y_01 - y_04) ^ 2
      len_02 = (x_02 - x_04) ^ 2 + (y_02 - y_04) ^ 2
      If len_01 > len_02 Then
        If x_01 < x_03 Then
          .Left = x_01
          .Width = x_03 - x_01
        Else
          .Left = x_03
          .Width = x_01 - x_03
        End If
        If y_01 < y_03 Then
          .Top = y_01
          .Height = y_03 - y_01
        Else
          .Top = y_03
          .Height = y_01 - y_03
        End If
      Else
        If x_02 < x_03 Then
          .Left = x_02
          .Width = x_03 - x_02
        Else
          .Left = x_03
          .Width = x_02 - x_03
        End If
        If y_02 < y_03 Then
          .Top = y_02
          .Height = y_03 - y_02
        Else
          .Top = y_03
          .Height = y_02 - y_03
        End If
      End If
      T_step = 0
      Unload UserForm1
    Else
      '作業無し
    End If
  End With
End Sub

後はMacro1を実行して、メッセージに従えばトリムできると思います。
削除後の線頭と線尾が変わってしまいます。その辺は調整してください。
長くなりましたが、機会があったら試してみて下さい。

【40968】Re:線のトリムって出来ないでしょうか?...
発言  わいわい  - 06/7/27(木) 9:12 -

引用なし
パスワード
   前回の投稿では、垂直の線についての計算分岐を忘れていました。気になるので修正しておきます。
分岐条件を見直す際に、垂直線状態取得時にβを負符号で取る必要が無いので以下のように修正しました。
          α1 = 10 ^ 10: β1 = x_01
          α2 = 10 ^ 10: β2 = x_11


>        '交点の取得
>        If α1 = α2 Then MsgBox "2直線が平行で交わりません。終了します。": T_step = 0: Exit Sub
>>        x_03 = (β2 - β1) / (α1 - α2)
>>        y_03 = α1 * x_03 + β1
        If α1 = 10 ^ 10 Then
          x_03 = β1
          y_03 = α2 * x_03 + β2
        ElseIf α2 = 10 ^ 10 Then
          x_03 = β2
          y_03 = α1 * x_03 + β1
        Else
          x_03 = (β2 - β1) / (α1 - α2)
          y_03 = α1 * x_03 + β1
        End If
>        
>        Cells(2, 1).Value = x_11: Cells(2, 2).Value = y_11
>        Cells(2, 3).Value = x_12: Cells(2, 4).Value = y_12
>        Cells(2, 5).Value = α2: Cells(2, 6).Value = β2
>        Cells(3, 1).Value = x_03: Cells(3, 2).Value = y_03
>

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