Excel VBA質問箱 IV

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

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


9673 / 12552 ツリー ←次へ | 前へ→

【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 回答[未読]

【19764】背景の透明化(?)
質問  ケン坊  - 04/11/16(火) 16:26 -

引用なし
パスワード
   はじめまして。2つほど聞きたいことがあるのですが、

サイクロトロンというソフトを見たのですが、
あれはユーザーフォームの形を変えたり透過したりしているのですが
あれはどのようにしたら、できるのですか????

もう一つの質問は、PSET(x,y)というのを知ったのですが、
何故か実行できませんでした。
ちなみに線を引く、LINEというのも実行できませんでした・・・

アドバイスお願いします!!

【19768】Re:背景の透明化(?)
発言  角田 WEB  - 04/11/16(火) 16:39 -

引用なし
パスワード
   こんにちは。
>サイクロトロンというソフトを見たのですが、
作者の谷さんを呼んで来たので、その内に来てくれるでしょう。

【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検索すると、使用例などがたくさんでてきます。

【19864】Re:背景の透明化(?)
回答  ちん  - 04/11/18(木) 9:46 -

引用なし
パスワード
   ▼ケン坊 さん:
>はじめまして。2つほど聞きたいことがあるのですが、
>
>サイクロトロンというソフトを見たのですが、
>あれはユーザーフォームの形を変えたり透過したりしているのですが
>あれはどのようにしたら、できるのですか????
>
>もう一つの質問は、PSET(x,y)というのを知ったのですが、
>何故か実行できませんでした。
>ちなみに線を引く、LINEというのも実行できませんでした・・・
>
>アドバイスお願いします!!
おはようございます。ちんといいます。
透過についてですが、丸くフォームを切り抜く関数と、四角くフォームを切り抜く
関数を掲載します。

(1)標準モジュールへの定義
Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function CreateRoundRectRgn Lib "gdi32" ( _
    ByVal X1 As Long, ByVal Y1 As Long, _
    ByVal X2 As Long, ByVal Y2 As Long, _
    ByVal X3 As Long, ByVal Y3 As Long) As Long

Private hRgn  As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Public Function xGetActiveWindow() As Long
  xGetActiveWindow = GetActiveWindow
End Function

(2)ユーザーフォームの定義
 ユーザーフォームにボタンを2つ配置して下さい。
Private Sub CommandButton1_Click()
  Dim hwnd As Long
  hwnd = xGetActiveWindow
  hRgn = CreateRectRgn(0, 0, 300, 300)  '*** 四角形の大きさ
  
  SetWindowRgn hwnd, hRgn, True
End Sub

Private Sub CommandButton2_Click()
  Dim hwnd As Long
  hwnd = xGetActiveWindow

  hRgn = CreateRoundRectRgn(0, 0, _
          300, _
          300, _
          320, 320)       '*** 円形の大きさ
          
  
  SetWindowRgn hwnd, hRgn, True

End Sub

以上、参考までに・・・

【19969】Re:背景の透明化(?)
質問  ケン坊 E-MAIL  - 04/11/21(日) 0:57 -

引用なし
パスワード
   ありがとうございます!
自分はこれで思った通りのプログラムを書くことができると思います!!

でも参考までに聞きたいのですがサイクロトロンは
移動させるために四角が上に表示されていたはずですが、
あのように丸と四角や丸と丸など、二つ以上の形にすることはできますか?

【19993】Re:背景の透明化(?)
回答  ちん  - 04/11/22(月) 18:06 -

引用なし
パスワード
   ▼ケン坊 さん:
>ありがとうございます!
>自分はこれで思った通りのプログラムを書くことができると思います!!
>
>でも参考までに聞きたいのですがサイクロトロンは
>移動させるために四角が上に表示されていたはずですが、
>あのように丸と四角や丸と丸など、二つ以上の形にすることはできますか?
 こんばんは、ちんといいます。
API関数の本を持っていないので、IEから関数を検索した結果で、お答えします。
リージョンの結合(CombineRgn関数)という関数を使用し、形を変えるまたは、
別な場所を切り抜いたりするようです。
http://www5d.biglobe.ne.jp/~tomoya03/shtml/vbapi/Region2.htm

(1)標準モジュール
Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function CreateRoundRectRgn Lib "gdi32" ( _
    ByVal X1 As Long, ByVal Y1 As Long, _
    ByVal X2 As Long, ByVal Y2 As Long, _
    ByVal X3 As Long, ByVal Y3 As Long) As Long

Private hRgn  As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

*** 今回追加。
Declare Function CombineRgn Lib "gdi32" ( _
  ByVal hDestRgn As Long, _
  ByVal hSrcRgn1 As Long, _
  ByVal hSrcRgn2 As Long, _
  ByVal CombineMode As Long) As Long

Declare Function CreateEllipticRgn Lib "gdi32" ( _
  ByVal LeftRect As Long, _
  ByVal TopRect As Long, _
  ByVal RightRect As Long, _
  ByVal BottomRect As Long) As Long


  Public Const RGN_AND = 1& 'リージョン同士のAND結合
  Public Const RGN_OR = 2& 'リージョン同士のOR結合
  Public Const RGN_XOR = 3& 'リージョン同士のXOR結合
  Public Const RGN_DIFF = 4& 'hSrcRgn1から、hSrcRgn2を除いた領域
  Public Const RGN_COPY = 5& 'hSrcRgn1のコピーを作成
  Public Const RGN_MIN = RGN_AND
  Public Const RGN_MAX = RGN_COPY
  '------------------戻り値-------------------
  '関数が終了すると、リージョンの複雑度が返る
  '次の値のいずれかになる
  Public Const ERRORAPI = 0& 'リージョンは作成されていない
  Public Const NULLREGION = 1& 'リージョンは空
  Public Const SIMPLEREGION = 2& 'リージョンは単一の長方形
  Public Const COMPLEXREGION = 3& 'リージョンは単一の長方形よりも複雑な形


Public Function xGetActiveWindow() As Long
  xGetActiveWindow = GetActiveWindow
End Function

(2)Form
Private Sub CommandButton4_Click()
  Dim wRgn1 As Long '結合リージョンサンプル
  Dim wRgn2 As Long
  Dim wRgn As Long '結合後のリージョン
Dim hwnd As Long
hwnd = xGetActiveWindow

  '角の丸い長方形のリージョンを作る
  wRgn1 = CreateRoundRectRgn(0, 0, 300, _
                300, 320, 320)
  '楕円のリージョンを作る
  wRgn2 = CreateEllipticRgn(0, 0, _
               200, 200)
  '長方形のリージョンを作る
  wRgn = CreateRectRgn(0, 0, 400, _
             400)

  'リージョンを結合して新しいリージョンをwRgnに格納
  CombineRgn wRgn, wRgn1, wRgn2, RGN_XOR
  SetWindowRgn hwnd, wRgn, True
End Sub

Private Sub CommandButton5_Click()
  Dim wRgn1 As Long '結合リージョンサンプル
  Dim wRgn2 As Long
  Dim wRgn As Long '結合後のリージョン
Dim hwnd As Long
hwnd = xGetActiveWindow

  '角の丸い長方形のリージョンを作る
  wRgn1 = CreateRoundRectRgn(0, 0, 300, _
                300, 320, 320)
  '長方形のリージョンを作る
  wRgn = CreateRectRgn(0, 0, 400, _
             400)

  'リージョンを結合して新しいリージョンをwRgnに格納
  CombineRgn wRgn, wRgn1, wRgn, RGN_XOR
  SetWindowRgn hwnd, wRgn, True

End Sub

こんな感じでイメージわきますでしょうか?
以上、参考までに・・・

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