お勉強コミュの画像解析ソフト

Private Const DT_LEFT As Long = &H0
Private Const DT_BOTTOM As Long = &H8
Private Const DT_SINGLELINE As Long = &H20
Private Const TRANSPARENT As Long = 1
Private Const GUID_IDISPATCH_INTERFACE As String = "{00020400-0000-0000-C000-000000000046}"
Private Const CF_BITMAP As Long = 2
Private Const CF_PALETTE As Long = 9
Private Const PICTYPE_BITMAP As Long = 1
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_COPYRETURNORG As Long = &H4
Private Const LR_LOADFROMFILE As Long = &H10
Private Const LOGPIXELSX As Long = 88

Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function GetObject Lib "gdi32" _
Alias "GetObjectA" _
(ByVal hObject As Long, _
ByVal nCount As Long, _
ByRef lpObject As Any) As Long

Private Declare Function SelectObject Lib "gdi32" _
(ByVal hDC As Long, _
ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

'★
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long

Private Sub CommandButton1_Click()
Const FILE_ORIGINAL As String = "C:\Documents and Settings\Miyashita．Co，\デスクトップ\分析\画像を数値に変換\test\test.bmp"

Dim hDC As Long
Dim hBmp As Long
Dim hOrgBmp As Long
Dim hOrgFont As Long
Dim hPalette As Long
Dim hImg As Long
Dim tBitmap As BITMAP
Dim Pic As stdole.IPictureDisp
Dim Ratio As Single

Dim i, j, cnt
Dim BB, GG, RR
Dim BBh, GGh, RRh
Dim strBGR
Dim strBGRLen
'----------
On Error Resume Next
With Me.Image1

'Image1に元画像を表示
.Picture = LoadPicture(FILE_ORIGINAL)

.AutoSize = False
.AutoSize = True
' MsgBox "変換前"

'元画像ＢＭＰファイルからデバイスコンテキストを直接作成
hBmp = LoadImage(0, FILE_ORIGINAL, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
hDC = CreateCompatibleDC(0)
hOrgBmp = SelectObject(hDC, hBmp)
GetObject hBmp, Len(tBitmap), tBitmap

'----------
'★下位から 8 ビット単位で B、G、R、未使用の順に並んでいます
'MsgBox (Hex(GetPixel(hDC, 1, 1)))

'セルの幅を変更
Columns("A:IV").Select
Selection.ColumnWidth = 0.62

Rows("1:1000").Select
Selection.RowHeight = 6

For j = 1 To 200 Step 1 '縦方向
For i = 1 To 160 Step 1 '横方向
strBGR = (Hex(GetPixel(hDC, i, j))) 'ピクセル取得
strBGRLen = Len(strBGR) '文字列の長さを取得

'0の数が足りない場合、補う（6桁になるように左に0を追加）
If strBGRLen < 6 Then
For cnt = 1 To 6 - strBGRLen Step 1 '6 - strBGRLen回繰り返す
strBGR = "0" & strBGR '左に0を追加
Next cnt
End If

'16進数で取り出し
BBh = Left(strBGR, 2) '左から2つ取り出し
GGh = Mid(strBGR, 3, 2) '3つめから2つ取り出し
RRh = Right(strBGR, 2) '右から2つ取り出し

'10進数に変換
BB = Val("&H" & BBh)
GG = Val("&H" & GGh)
RR = Val("&H" & RRh)

'セルの色を書き換える
Cells(j, i).Interior.Color = RGB(RR, GG, BB)

Cells(j, i).Value = (RR & "," & GG & "," & BB & " / " & strBGR)

Next i
Next j

'描画オブジェクト／デバイスコンテキストの後始末
SelectObject hDC, hOrgFont

SelectObject hDC, hOrgBmp
DeleteDC hDC
DeleteObject hBmp


End With

Selection.ClearContents


End Sub

'ボタン2クリア

Private Sub CommandButton2_Click()
Selection.Interior.ColorIndex = xlNone

End Sub

追加

N = TextBox1.Text '横
T = TextBox2.Text '縦

For j = 1 To T Step 1 '縦方向
For i = 1 To N Step 1 '横方向

フォルダーを選択する

Private Sub CommandButton1_Click()
Dim rc As Long, myfolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
rc = .Show
If rc = -1 Then
myfolder = .SelectedItems.Item(1)
ChDrive Left(myfolder, 1)
ChDir myfolder
MsgBox CurDir
End If
End With

End Sub