VBAで画像の色を取得するツール作成しました!



The following two tabs change content below.
アバター

taka

あることがキッカケでVBAを独学で勉強しました、今ではブログを通してVBAでできることを解説しつつ、VBAや他の言語の勉強、ブログ運営の勉強をしています(^^♪

どうも、takaです(^-^)

今回はVBAのユーザーフォームを使って画像を表示させ、マウスポインターがある地点の色を取得します(^^♪

このツールに似ているのはカラーピッカー(Color Picker)というツールがあります

カラーピッカー(Color Picker)はこちら

カラーチェックツール

画像で説明している通りになっていますが、イメージコントロール上に表示させた画像にマウスポインターを配置させマウスポインターの位置の色を取得するツールです(^^♪

取得値は16進数とRGBをそれぞれ表示させます(^-^)

制作者からひと言

今回は申し訳ありませんが、ポインターから色を取得するコードはネットの情報を使用させていただきました(;^ω^)

恥ずかしながら私はまだAPIは苦手なので・・・

カラーチェックツールのコード

カラーチェックツールのコードを公開します!

ダウンロードファイルも用意しますので気になりましたら↓へ

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 GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long 'ポインターの座標を取得するAPI
  Private Type POINTAPI
    X As Long  '
    Y As Long '
 End Type
Private Declare Function GetPixel Lib "gdi32.dll" _
 (ByVal hdc As Long, ByVal nXPos As Long, ByVal nYPos As Long) As Long  'ポインターのあるピクセルの色を取得するAPI
 Private Sub CommandButton1_Click()
  On Error GoTo Error1
    Dim fType, prompt As String
    Dim fPath As Variant
    Dim ws As Worksheet
   
    '画像ファイルのみを表示も設定
   OpenFileName = Application.GetOpenFilename( _
                        "画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp")
    'ダイアログのタイトルを指定
    prompt = "画像ファイルを選択してください"

    If OpenFileName <> "False" Then
    Image1.Picture = LoadPicture(OpenFileName)
    Else
    MsgBox "キャンセルされました"
    Exit Sub
    End If
    
Exit Sub
Error1:
    MsgBox "エラー番号:" & Err.Number & vbLf & _
    "エラー内容:" & Err.Description
    
End Sub

Private Sub Image1_Click()
Set MyData = New DataObject
MyData.SetText TextBox1.Text
MyData.PutInClipboard

MsgBox "16進数をコピーしました"

End Sub
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    Dim hdc As Long, color As Long
    Dim pt As POINTAPI
    
    Call GetCursorPos(pt)
    hdc = GetDC(0)
    color = GetPixel(hdc, pt.X, pt.Y)
    
    Call ReleaseDC(0, hdc)
    Dim R As Byte, G As Byte, B As Byte
    R = color And &HFF
    G = color \ &H100 And &HFF
    B = color \ &H10000 And &HFF
'16進数での表示
TextBox1.Value = "#" & Format(Hex(R), "00") & Format(Hex(G), "00") & Format(Hex(B), "00")
'RGBでの表示
TextBox2.Value = "RGB(" & R & "," & G & "," & B & ")"

  Label1.BackColor = RGB(R, G, B)
End Sub

ダウンロード

当サイトの免責事項をお読みになってからお使いください。

フォロー・チャンネル登録お願いします

VBA以外についてのブログはこちら↓

https://yb-log.com/

■Twitterフォロー

■YouTubeチャンネル登録

ファイルやコードの利用、WEBサイトの利用について

サンプルコードなどは当サイトの免責事項をよくお読みになってからお使いください。

Sponsored Link

 

WordPressでブログを始めるなら

WordPress簡単インストール&安心の安定性

レンタルサーバー Xserver

コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です