자료실

부자는 돈을 써서 시간을 아끼지만 가난한 사람은 시간을 써서 돈을 아낀다

vb6.0/vba

IT HUB를 찾아주셔서 감사합니다.

vba [vba] 엑셀 시트를 픽셀처럼 사용하여 폼의 이미지 박스의 이미지를 시트에 그리기

페이지 정보

profile_image
작성자 하나를하더라도최선을
댓글 0건 조회 8,828회 작성일 19-07-08 00:10

본문

af7e370ed561e082d99af4b4b17ed06d_1562512174_117.png



Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
'Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINT) As Long
'Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
 
 
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
 
Private Const POINTS_PER_INCH As Long = 72
Private Const LOGPIXELSX = 88 ' tell GetDeviceCaps to return horiz
 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As StringByVal lpWindowName As StringAs Long
 
'Private Type POINT
'    X As Long
'    Y As Long
'End Type
 
Private Sub CommandButton1_Click()
 
    img.Picture = LoadPicture(ThisWorkbook.Path & "\img.jpg")   '// 현재 파일과 같은 경로의 img.jpg 파일을 불러옴
    img.PictureSizeMode = fmPictureSizeModeClip
    img.AutoSize = True: DoEvents   '// 이미지 사이즈에 맞게 컨트롤을 변경하고 이벤트를 시스템에 넘김
    
    Application.ScreenUpdating = False  '// 앞으로 화면의 변화를 업데이트 하지 않음
    Columns.ColumnWidth = 0.38  '// 모든 셀의 넓이를
    Rows.RowHeight = 3.75   '// 모든셀의 높이를
    Cells.Interior.Pattern = xlNone '// 채우기 초기화
 
    Dim hDC As Long
    
    hDC = GetDC(FindWindow(vbNullString, Me.Caption))   '// 폼의 핸들값
 
    Dim Y As Integer, X As Integer
    For X = To GetGraphicswidth   '// 이미지의 넓이만큼
        For Y = To GetGraphicsHeight  '// 이미지의 높이 만큼
            Cells(Y, X).Interior.Color = GetPixel(hDC, X + (PixelsPerPoint * img.Left) - 1, Y + (PixelsPerPoint * img.Top) - 1'// 셀에 색상을 변경
        Next
    Next
    hDC = ReleaseDC(0, hDC)
    Application.ScreenUpdating = True
End Sub
 
Public Function PixelsPerPoint() As Double
    Dim deviceContextHandle As Long
    Dim DotsPerInch As Long
    deviceContextHandle = GetDC(0)
    DotsPerInch = GetDeviceCaps(deviceContextHandle, LOGPIXELSX)
    PixelsPerPoint = DotsPerInch / POINTS_PER_INCH
    ReleaseDC 0, deviceContextHandle
End Function
 
Public Function GetGraphicswidth()
    GetGraphicswidth = PixelsPerPoint * img.Width
End Function
 
Public Function GetGraphicsHeight()
    GetGraphicsHeight = PixelsPerPoint * img.Height
End Function




GetPixel 에서 이미지 컨트롤의 위치를  좀더 정확하게 찿을 수 있으면 좋겠다.


귀차나서 이부분은 간단히 마무리 하는걸로...


 

첨부파일

댓글목록

등록된 댓글이 없습니다.