'システム定義のカーソルをロードする
'システム定義のアイコンをロードする
'アイコンを描画する
'作成したアイコンを破棄する
'システム定義のカーソルの定数 Private Const IDC_APPSTARTING = 32650& '標準矢印カーソルと小型砂時計 Private Const IDC_ARROW = 32512& '標準矢印カーソル Private Const IDC_CROSS = 32515& '十字カーソル Private Const IDC_IBEAM = 32513& 'アイビーム Private Const IDC_NO = 32648& '禁止カーソル Private Const IDC_SIZEALL = 32646& '4方向矢印カーソル Private Const IDC_SIZENESW = 32643& '斜め左下がり両方向カーソル Private Const IDC_SIZENS = 32645& '上下両方向矢印カーソル Private Const IDC_SIZENWSE = 32642& '斜め右下がり両方向カーソル Private Const IDC_SIZEWE = 32644& '左右両方向矢印カーソル Private Const IDC_UPARROW = 32516& '垂直矢印のカーソル Private Const IDC_WAIT = 32514& '砂時計カーソル 'システム定義のアイコンの定数 Private Const IDI_APPLICATION = 32512& 'アプリケーション Private Const IDI_HAND = 32513& '警告 Private Const IDI_QUESTION = 32514& '問い合わせ Private Const IDI_EXCLAMATION = 32515& '注意 Private Const IDI_ASTERISK = 32516& '情報 Private Const DI_MASK = &H1 'ropImageのラスタ操作実行 Private Const DI_IMAGE = &H2 'ropMaskのラスタ操作実行 Private Const DI_NORMAL = &H3 'DI_MASKとDI_IMAGEの組み合わせ Private Type SYSTEM_DEF Value As Long Explanation As String End Type Public udtSd(16) As SYSTEM_DEF '----------------------------------------------------------------------- ' 関数名 : InitStruct ' 機能 : 構造体を初期化する ' 引数 : なし ' 戻り値 : なし '----------------------------------------------------------------------- Public Sub InitStruct() 'VBは構造体や配列の初期化が出来ないのが弱点… 不便や udtSd(0).Value = IDC_APPSTARTING udtSd(0).Explanation = "標準矢印カーソルと小型砂時計" udtSd(1).Value = IDC_ARROW udtSd(1).Explanation = "標準矢印カーソル" udtSd(2).Value = IDC_CROSS udtSd(2).Explanation = "十字カーソル" udtSd(3).Value = IDC_IBEAM udtSd(3).Explanation = "アイビーム" udtSd(4).Value = IDC_NO udtSd(4).Explanation = "禁止カーソル" udtSd(5).Value = IDC_SIZEALL udtSd(5).Explanation = "4方向矢印カーソル" udtSd(6).Value = IDC_SIZENESW udtSd(6).Explanation = "斜め左下がり両方向カーソル" udtSd(7).Value = IDC_SIZENS udtSd(7).Explanation = "上下両方向矢印カーソル" udtSd(8).Value = IDC_SIZENWSE udtSd(8).Explanation = "斜め右下がり両方向カーソル" udtSd(9).Value = IDC_SIZEWE udtSd(9).Explanation = "左右両方向矢印カーソル" udtSd(10).Value = IDC_UPARROW udtSd(10).Explanation = "垂直矢印のカーソル" udtSd(11).Value = IDC_WAIT udtSd(11).Explanation = "砂時計カーソル" udtSd(12).Value = IDI_APPLICATION udtSd(12).Explanation = "アプリケーションアイコン" udtSd(13).Value = IDI_HAND udtSd(13).Explanation = "警告のアイコン" udtSd(14).Value = IDI_QUESTION udtSd(14).Explanation = "問い合わせのアイコン" udtSd(15).Value = IDI_EXCLAMATION udtSd(15).Explanation = "注意のアイコン" udtSd(16).Value = IDI_ASTERISK udtSd(16).Explanation = "情報のアイコン" End Sub '----------------------------------------------------------------------- ' 関数名 : DrawCursorIcon ' 機能 : アイコンを描画する ' 引数 : (i)TargetObj … ピクチャーオブジェクト ' (i)IsCursor … カーソルかアイコンどうか ' (i)CurIcnVal … InitStruct() に定義されている定数のインデックス ' (i)xPos … X座標 ' (i)yPos … Y座標 ' (i)xWidth … 幅 ' (i)xHeight … 高さ ' 戻り値 : 正常終了…1 エラー…0 '----------------------------------------------------------------------- Public Sub DrawCursorIcon(ByVal TargetObj As Object, _ ByVal IsCursor As Boolean, _ ByVal CurIcnVal As Long, _ Optional ByVal xPos As Long = 0, _ Optional ByVal yPos As Long = 0, _ Optional ByVal xWidth As Long = 32, _ Optional ByVal xHeight As Long = 32) Dim hImgWnd As Long If IsCursor Then hImgWnd = LoadCursor(0, CurIcnVal) Else hImgWnd = LoadIcon(0, CurIcnVal) End If '描画 TargetObj.Cls Call DrawIconEx(TargetObj.hdc, xPos, yPos, hImgWnd, xWidth, xHeight, 0, 0, DI_NORMAL) TargetObj.Refresh 'はたして DestroyIcon する必要があるのだろうか Call DestroyIcon(hImgWnd) End Sub あとはフォームにリストボックスを配置して、以下を書く。 Private Sub Form_Load() Dim i As Long With Me .Caption = "システム定義のカーソル・アイコンを表示" .ScaleMode = vbPixels .AutoRedraw = True .Width = 300 * Screen.TwipsPerPixelX .Height = 160 * Screen.TwipsPerPixelY .List1.Clear .List1.Left = 0 .List1.Top = 4 .List1.Width = 210 .List1.Height = 130 End With '構造体初期化 Call InitStruct 'リストボックスに値を追加 For i = 0 To UBound(udtSd) - 1 With List1 .AddItem udtSd(i).Explanation .ItemData(i) = udtSd(i).Value End With Next End Sub Private Sub List1_Click() '描画 Call DrawCursorIcon(Me, CBool(List1.ListIndex < 12), _ List1.ItemData(List1.ListIndex), 220, 10, 64, 64) End Sub |