Excel VBA質問箱 IV

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

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


40988 / 76732 ←次へ | 前へ→

【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を実行します。

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

試してみて下さい。
1 hits

【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 発言

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