'(Form)---------------------------------------------------------------------------------------------
Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

' Class field offsets for GetClassLong() and GetClassWord()
Private Const GCL_MENUNAME = (-8)
Private Const GCL_HBRBACKGROUND = (-10)
Private Const GCL_HCURSOR = (-12) 'クラスに関連付けられているマウスカーソルのハンドルを書き換えます。
Private Const GCL_HICON = (-14)
Private Const GCL_HMODULE = (-16)
Private Const GCL_CBWNDEXTRA = (-18)
Private Const GCL_CBCLSEXTRA = (-20)
Private Const GCL_WNDPROC = (-24)
Private Const GCL_STYLE = (-26)
Private Const GCW_ATOM = (-32)

'マウスカーソル（ マウスポインタ）の現在の位置に相当するスクリーン座標を取得します。
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

'マウスカーソル（ マウスポインタ）の位置を、指定されたスクリーン座標に移動します。
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long

'指定されたウィンドウが属するウィンドウクラスの拡張クラスメモリ内の指定されたオフセット位置にある long データ（32 ビット値）か、
'または WNDCLASSEX 構造体の中の指定された long データを指定された値に書き換えます。
Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

'システム全体に関するパラメータのいずれかを取得または設定します。
'成功=0 以外の値,失敗=0
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_SETDESKWALLPAPER = 20 'デスクトップに表示される壁紙を設定します。
' SystemParametersInfo flags
Private Const SPIF_UPDATEINIFILE = &H1 'システム全体のパラメータに関する新しい設定を、ユーザープロファイルに書き込みます。
Private Const SPIF_SENDWININICHANGE = &H2 'ユーザープロファイルを更新した後、WM_SETTINGCHANGE メッセージをブロードキャストします。


'画面のデザインに使われている、表示要素の色を取得します。表示要素とは、ウィンドウの一部、またはシステムが表示する画面の一部を意味します。
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
'デスクトップの色。
Private Const COLOR_BACKGROUND = 1

'画面のデザインに使われている、表示要素の色を設定します。表示要素とは、ウィンドウの一部、またはシステムが表示する画面の一部を意味します。
Private Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long

'ファイル内に記録されているデータに基づいて、マウスカーソル（ マウスポインタ）を作成します。
'ファイル名かシステムカーソルの識別子を使って、ファイルを指定します。この関数は、新しく作成されたマウスカーソルのハンドルを返します。
'マウスカーソルのデータを保持しているファイルは、カーソル（.CUR）形式またはアニメーションカーソル（.ANI）形式です。
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long

'メッセージ文字列を書式化します
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
'要求されたメッセージを、システムメッセージテーブルリソースから検索するよう指定します。
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000

' パスの最大長
Private Const MAX_PATH = 260

Private wOldCur As Long

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    'マウスポインタ位置を設定
    Dim wPointApi As POINTAPI
    Dim wCurX As Long
    Dim wCurY As Long
    Dim rc        As Long
    
    '現在のマウスポインタ位置を取得
    rc = GetCursorPos(wPointApi)
    'マウスポインタ位置を設定
    With wPointApi
        wCurX = .x
        wCurY = .y
    End With
    
    '矢印キーが押されたらマウスポインタ位置を変更
    Select Case KeyCode
    Case vbKeyUp
        wCurY = wCurY - 20
    Case vbKeyDown
        wCurY = wCurY + 20
    Case vbKeyLeft
        wCurX = wCurX - 20
    Case vbKeyRight
        wCurX = wCurX + 20
    End Select
    
    'マウスポインタ位置を設定
    rc = SetCursorPos(wCurX, wCurY)
End Sub

Private Sub Form_Open(Cancel As Integer)
    Dim wWinDir As String
    Dim wFile As String
    Dim w As String
    
    
    '壁紙用画像ファイル取得
    wWinDir = Environ("WINDIR") & "\"
    w = "(なし);(規定);"
    wFile = Dir$(wWinDir & "*.bmp")
    Do
        w = w & wWinDir & wFile & ";"
        wFile = Dir$()
    Loop Until wFile = ""
    If w > "" Then w = Left$(w, Len(w) - 1)
    Me!リスト1.RowSource = w

    'カーソル用画像ファイル取得
    wWinDir = wWinDir & "Cursors\"
    w = ""
    wFile = Dir$(wWinDir & "*.cur")
    Do
        w = w & wWinDir & wFile & ";"
        wFile = Dir$()
    Loop Until wFile = ""
    If w > "" Then w = Left$(w, Len(w) - 1)
    Me!リスト4.RowSource = w
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim rc As Long

    '初期のマウスカーソルに戻す
    If wOldCur > 0 Then
        rc = SetClassLong(Me.hwnd, GCL_HCURSOR, wOldCur)
    End If
End Sub

Private Sub コマンド1_Click()
    Dim wError As String
    Dim wFile As String
    
    'デスクトップの壁紙を設定
    'デスクトップに表示される壁紙を設定します。pvParam パラメータの値に基づいて、新しい壁紙が決まります。
    '壁紙のビットマップを指定するには、pvParam パラメータで、ビットマップファイルの名前を表す、NULL で終わる
    '文字列へのポインタを指定します。pvParam パラメータで空の文字列（""）を指定すると、壁紙は表示されなくなります。
    'pvParam パラメータで SETWALLPAPER_DEFAULT または NULL を指定すると、既定の壁紙へ戻ります。(規定)
    Dim rc As Long
    On Error Resume Next
    
    wFile = Me!リスト1
    If wFile > "" Then
        If wFile = "(なし)" Then
            wFile = ""
        ElseIf wFile = "(規定)" Then
            wFile = vbNullString
        Else
            wFile = wFile & vbNullChar
        End If
        rc = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, ByVal wFile, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
        If LsGetLastError(wError) <> 0 Then
            MsgBox wError
        End If
    End If
End Sub

Private Sub コマンド2_Click()
    'デスクトップの色を取得
    Dim color As Long

    ' デスクトップの色を取得
    color = GetSysColor(COLOR_BACKGROUND)
    ' デスクトップの色を表示
    Me!ラベル2.BackColor = color
End Sub

Private Sub コマンド3_Click()
    'デスクトップの色を変更
    Dim rc As Long
    Dim color As Long
    
    ' 色の選択ダイアログ
    If LsGetColorDialog(color, Me) = 1 Then
        rc = SetSysColors(1, COLOR_BACKGROUND, color)
    End If
End Sub

Private Sub コマンド4_Click()
    'マウスカーソルを変更
    Static flg As Boolean
    Dim wNewCur As Long
    Dim rc As Long
    
    'ファイルからカーソルをロード
    wNewCur = LoadCursorFromFile(Me!リスト4)
    'クラスに関連付けられているマウスカーソルのハンドルを書き換えます。
    wNewCur = SetClassLong(Me.hwnd, GCL_HCURSOR, wNewCur)
    If flg = False Then
        wOldCur = wNewCur
        flg = True
    End If
End Sub

Private Sub コマンド5_Click()
    '初期のマウスカーソルに戻す
    Dim wNewCur As Long
    Dim rc As Long
    'クラスに関連付けられているマウスカーソルのハンドルを書き換えます。
    wNewCur = SetClassLong(Me.hwnd, GCL_HCURSOR, wOldCur)
End Sub

Private Function LsGetLastError(wError As String) As Long
    Dim wErrNo As Long
    Dim rc As Long

    wErrNo = Err.LastDllError
    If wErrNo = 0 Then Exit Function
    LsGetLastError = wErrNo
    
    wError = String(256, vbNullChar)
    
    'エラーコードからエラーメッセージを取得する
    rc = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, wErrNo, 0, wError, Len(wError), 0)
    wError = Left$(wError, InStr(wError, vbNullChar) - 1)
End Function



'(Standerd Module)---------------------------------------------------------------------------------------------
Option Explicit

'「色指定」コモンダイアログを呼び出す
Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As YCHOOSECOLOR) As Long

Type YCHOOSECOLOR
    lStructSize As Long 'この構造体の長さ
    hwndOwner As Long 'ダイアログボックスを持つウインドウハンドル
    hInstance As Long 'モジュールのインスタンスハンドル
    rgbResult As Long '呼び出す前は初期色、終了時は、ユーザーが選択した色
    lpCustColors As Long 'カスタムカラーの配列のポインタ
    flags As Long '初期化フラグ
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

'Flagsの設定値
Public Const CC_ENABLEHOOK = &H10 'lpfnHoolで指定されたフック関数を有効にする
Public Const CC_ENABLETEMPLATE = &H20 'hInstanceとlpTemplateNameで指定されたダイアログテンプレートを使って作成する
Public Const CC_ENABLETEMPLATEHANDLE = &H40 'hInstanceがロード済みのテンプレートを含むメモリブロックを差す
Public Const CC_FULLOPEN = &H2 'ダイアログボックス作成時にダイアログ全体を表示する
Public Const CC_PREVENTFULLOPEN = &H4 '[色作成]ボタンを無効にする
Public Const CC_RGBINIT = &H1 'rgbResultで初期設定カラーとして指定されたカラーをダイアログに表示する
Public Const CC_SHOWHELP = &H8 '[ヘルプ]ボタンを表示する

' ヒープからメモリブロックを確保する
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long

Public Const GMEM_MOVEABLE = &H2 ' 移動可能メモリの割当て
Public Const GMEM_ZEROINIT = &H40 ' メモリ内容を0で初期化する
Public Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

'グローバルヒープに確保されたメモリブロックをロックする
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long

'メモリブロックを移動する。
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'グローバルヒープにロードされたメモリブロックを解放する
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

'グローバルヒープに確保されていたメモリブロックを解放する
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

Public Function LsGetColorDialog(ByRef color As Long, fm As Form) As Long

'***********************************************************
'機能 : 「色指定」ダイアログを表示する
'戻り値:　1:色が選択された　0:[キャンセル]ボタンを押された
'　　　　　引数colorに選択された色コードをセットします
'***********************************************************

    Dim col As YCHOOSECOLOR
    Dim longret As Long
    Dim longret2 As Long
    Dim custcol(15) As Long
    Dim rescol As Long
    Dim i As Integer
    Dim colorsize As Long
    Dim colorAddress As Long
    Dim memhandle As Long

    rescol = 0
    longret2 = 0
    For i = 0 To 15
        custcol(i) = &HFFFFFF
    Next
'カスタムカラーに必要なメモリのサイズを得る。
    colorsize = Len(custcol(0)) * 16
'カスタムカラーのメモリブロックを確保
    memhandle = GlobalAlloc(GHND, colorsize)
    If memhandle Then
'カスタムカラーののググローバルメモリブロックロックする
        colorAddress = GlobalLock(memhandle)

        If colorAddress Then
        'カスタムカラーのグローバルメモリブロックを配列にコピーする
            Call MoveMemory(ByVal colorAddress, custcol(0), colorsize)

            With col
                .lStructSize = Len(col)
                .hwndOwner = fm.hwnd
                .hInstance = 0&
                .rgbResult = rescol
                .lpCustColors = colorAddress
                .flags = CC_RGBINIT
                .lCustData = 0&
                .lpfnHook = 0&
                .lpTemplateName = 0&
            End With

            longret2 = ChooseColor(col)
        'メモリブロックロック解除
            longret = GlobalUnlock(memhandle)
        'メモリブロック解放
            longret = GlobalFree(memhandle)

        Else
        'メモリブロック解放
            longret = GlobalFree(memhandle)
        End If
    End If
    color = col.rgbResult
    LsGetColorDialog = longret2
End Function
'-----------------------------------------------------------------------------------------------------------------------