HOME > エクセルVBA > サンプル > LineTo

LineTo


【ファイル名】LineTo.xlsm
【バージョン】Ver 1.0.0.0
【作成日】2021年06月08日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】LineTo.zip
【説明】Windows APIのLineToを使用してユーザーフォームに線を描画するサンプルです。四角形の描画は「Rectangle.xlsm」を参照してください。

画面

【外部リンク】Windows > Apps > Win32 > API > Windows GDI > Wingdi.h >  CreatePen functionDeleteObject functionLineTo functionMoveToEx functionSelectObject function
【外部リンク】Windows > Apps > Win32 > API > Windows GDI >  Winuser.h >  GetDC functionReleaseDC function
【外部リンク】Windows > Apps > Win32 > API > Windows Accessibility Features > Oleacc.h > WindowFromAccessibleObject function
【外部リンク】Windows > Apps > Win32 > API > Display Devices Reference > Windef.h >  POINT structure

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="サンプル" insertBeforeMso="TabHome" keytip="S">
        <group id="Group1" label="プロセッサの情報">
          <button id="ShowFormButton" label="フォームを表示" keytip="S"
                  supertip="フォームを表示します。" onAction="onAction" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

UserForm1
Option Explicit

' Pen Styles (wingdi.h)
Private Const PS_SOLID = 0
Private Const PS_DASH = 1       ' --------------
Private Const PS_DOT = 2        ' ..............
Private Const PS_DASHDOT = 3    ' _._._.__._._._
Private Const PS_DASHDOTDOT = 4 ' _.._..__.._.._
'Private Const PS_NULL = 5
'Private Const PS_INSIDEFRAME = 6
'Private Const PS_USERSTYLE = 7
'Private Const PS_ALTERNATE = 8
'Private Const PS_STYLE_MASK = &HF

' https://docs.microsoft.com/ja-jp/windows/win32/api/windef/ns-windef-point
Private Type POINTAPI ' Windef.h (include Windows.h)
  x As Long
  Y As Long
End Type

#If Win64 Then
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-createpen
  Private Declare PtrSafe Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As LongPtr
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-deleteobject
  Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
  
  ' https://docs.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getdc
  Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-lineto
  Private Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal Y As Long) As Long
  
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-movetoex
  Private Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long

  ' https://docs.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-releasedc
  Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
   
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-selectobject
  Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
              
  ' https://docs.microsoft.com/ja-jp/windows/desktop/api/oleacc/nf-oleacc-windowfromaccessibleobject
  Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal pacc As Object, phwnd As LongPtr) As Long
#Else
  Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
  Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal Y As Long) As Long
  Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
  Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
  Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  Private Declare Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal pacc As Object, phwnd As Long) As Long
#End If

#If Win64 Then
  Private hwnd As LongPtr ' ウィンドウのハンドル
  Private hDC As LongPtr  ' デバイス コンテキスト
#Else
  Private hwnd As Long ' ウィンドウのハンドル
  Private hDC As Long  ' デバイス コンテキスト
#End If

Private Sub CommandButton1_Click() ' 線を描く
  Dim XS As Long, XE As Long, Y As Long
  Dim P As POINTAPI ' 位置(使いません)
#If Win64 Then
  Dim NewPen As LongPtr ' 新しいペン
  Dim OldPen As LongPtr ' 元のペン
#Else
  Dim NewPen As Long ' 新しいペン
  Dim OldPen As Long ' 元のペン
#End If
  
  Repaint ' 描画のクリアー
  XS = 10  ' Xの開始位置
  XE = 200 ' Xの終了位置
  Y = 50   ' Yの開始位置
  ' 直線を描く
  NewPen = CreatePen(PS_SOLID, 1, VBA.ColorConstants.vbRed) ' ペンの作成
  OldPen = SelectObject(hDC, NewPen) ' 新しいペンを選択
  MoveToEx hDC, XS, Y, P ' 位置を移動
  LineTo hDC, XE, Y ' 線を描く
  SelectObject hDC, OldPen ' 元のペンに戻す
  DeleteObject NewPen ' ペンを削除
  ' 直線を描く
  Y = Y + 10
  OldPen = SelectObject(hDC, CreatePen(PS_DASH, 1, vbBlue)) ' 新しいペンを作成して、ペンを選択
  MoveToEx hDC, XS, Y, P ' 位置を移動
  LineTo hDC, XE, Y ' 線を描く
  DeleteObject SelectObject(hDC, OldPen) ' 元のペンに戻して、ペンを削除
  ' 点線を描く
  Y = Y + 10
  OldPen = SelectObject(hDC, CreatePen(PS_DOT, 1, vbYellow)) ' 新しいペンを作成して、ペンを選択
  MoveToEx hDC, XS, Y, P ' 位置を移動
  LineTo hDC, XE, Y ' 線を描く
  DeleteObject SelectObject(hDC, OldPen) ' 元のペンに戻して、ペンを削除
  ' ダッシュドット(破線)を描く
  Y = Y + 10
  OldPen = SelectObject(hDC, CreatePen(PS_DASHDOT, 1, vbMagenta)) ' 新しいペンを作成して、ペンを選択
  MoveToEx hDC, XS, Y, P ' 位置を移動
  LineTo hDC, XE, Y ' 線を描く
  DeleteObject SelectObject(hDC, OldPen) ' 元のペンに戻して、ペンを削除
  ' ダッシュドットドット(破線)を描く
  Y = Y + 10
  OldPen = SelectObject(hDC, CreatePen(PS_DASHDOTDOT, 1, Excel.XlRgbColor.rgbNavy)) ' 新しいペンを作成して、ペンを選択
  MoveToEx hDC, XS, Y, P ' 位置を移動
  LineTo hDC, XE, Y ' 線を描く
  DeleteObject SelectObject(hDC, OldPen) ' 元のペンに戻して、ペンを削除
  ' 太い直線を描く
  Y = Y + 10
  OldPen = SelectObject(hDC, CreatePen(PS_SOLID, 5, RGB(128, 0, 128))) ' 新しいペンを作成して、ペンを選択
  MoveToEx hDC, XS, Y, P ' 位置を移動
  LineTo hDC, XE, Y ' 線を描く
  DeleteObject SelectObject(hDC, OldPen) ' 元のペンに戻して、ペンを削除
End Sub

Private Sub UserForm_Initialize() ' 初期処理
  WindowFromAccessibleObject Me, hwnd ' フォームのハンドルを取得する
  hDC = GetDC(hwnd) ' デバイス コンテキストを取得する
End Sub

Private Sub UserForm_Terminate() ' 終了処理
  ReleaseDC hwnd, hDC ' デバイス コンテキストを解放する
End Sub
このページの上

Module1
Option Explicit

Private rbRibbonUI As IRibbonUI   ' リボン

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "ShowFormButton"
      UserForm1.Show vbModal
    Case Else
      Beep ' 警告音
      MsgBox Prompt:=control.ID & "の処理がありません!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      Exit Sub
  End Select
  
  Exit Sub
'
ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical + vbSystemModal, Title:="エラー"
End Sub
このページの上