Excel VBA質問箱 IV

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

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


61506 / 76732 ←次へ | 前へ→

【19842】Re:背景の透明化(?)
発言  ni  - 04/11/17(水) 19:03 -

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


フォームの形を変えるのはやったこと無いので、残りを。

PSETや、LINEは、APIを使います。

ユーザーフォームを1つ作って、ユーザーフォームのモジュールに下記コードを
コピペして下さい。

Option Explicit

Private Declare Function GetDC Lib "user32.dll" _
  (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" _
  (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetActiveWindow Lib "user32.dll" () As Long
Private Declare Function SetPixelV Lib "gdi32.dll" _
    (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" _
  (ByVal fnPenStyle As Long, ByVal nWidth As Long, _
   ByVal crColor As Long) As Long
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 Declare Function DeleteObject Lib "gdi32.dll" _
    (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" _
    (ByVal hdc As Long, ByVal hgdiobj As Long) As Long
Private Declare Function MoveToEx Lib "gdi32.dll" _
    (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, _
    ByVal lpPoint As Long) As Long
Private Declare Function LineTo Lib "gdi32.dll" _
    (ByVal hdc As Long, ByVal nXEnd As Long, ByVal nYEnd As Long) As Long

Private hwnd As Long


Private Sub UserForm_Activate()
  hwnd = GetActiveWindow 'ウインドウハンドル取得
  If hwnd = 0 Then
    MsgBox "エラーです"
    Unload Me
  End If

End Sub

Private Sub UserForm_Click()
Dim hdc As Long
Dim hpen As Long
Dim hpenSave As Long
Dim col As Long
  col = RGB(255, 0, 0) '色コード
  hdc = GetDC(hwnd) 'デバイスコンテキストを取得
  hpen = CreatePen(PS_solid, 5, col) 'ペンを作成 5は太さ
  hpenSave = SelectObject(hdc, hpen) 'デバイスコンテキストに作成したペンを選択と共に、元のペンを記憶しておく
  MoveToEx hdc, 0, 0, 0    '書き始めに移動
  LineTo hdc, Me.Width / 0.75, Me.Height / 0.75 '線を引く
  SelectObject hdc, hpenSave 'デバイスコンテキストのペンを元に戻す
  DeleteObject hpen      '作成したペンを削除
  ReleaseDC hwnd, hdc     'デバイスコンテキストを開放(削除してはダメ)
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim hdc As Long
Dim col As Long

  If Button = 2 Then
    hdc = GetDC(hwnd)    'デバイスコンテキストを取得
    col = RGB(0, 0, 255)  '色コード
    SetPixelV hdc, X / 0.75, Y / 0.75, col '指定位置に点を書く
    ReleaseDC hwnd, hdc   'デバイスコンテキストを開放
  End If
End Sub

ユーザーフォームを表示して、ユーザーフォームをクリックすると
赤い斜めの線が引かれます。(芸がない^^;)
MovoToExとLineToのサンプルです。

ユーザーフォームを右ボタン押してドラッグすると、なぞったところに
青い点が引かれます。(SetPixcelVのサンプル)

座標系はピクセルなので、フォームのポイント座標の0.75倍だそうです。

Windowsのオブジェクトを操作することになるので、
作成したオブジェクトをDeleteしなかったり、
オブジェクトをSelectObjectしたままで、元のオブジェクトに戻さなかったり、
Getしたデバイスコンテキストを開放すべきところを削除してしまったり、
してしまうと、Windowsが不安定になる恐れがありますので、
各関数の使い方をしっかり勉強して、
クラッシュしてもよい環境で実験して下さい。

API関数のリファレンスは、こちらが参考になります。
http://www.geocities.jp/winapi_database/

また、関数名でweb検索すると、使用例などがたくさんでてきます。

4 hits

【19764】背景の透明化(?) ケン坊 04/11/16(火) 16:26 質問
【19768】Re:背景の透明化(?) 角田 04/11/16(火) 16:39 発言
【19842】Re:背景の透明化(?) ni 04/11/17(水) 19:03 発言
【19864】Re:背景の透明化(?) ちん 04/11/18(木) 9:46 回答
【19969】Re:背景の透明化(?) ケン坊 04/11/21(日) 0:57 質問
【19993】Re:背景の透明化(?) ちん 04/11/22(月) 18:06 回答

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