Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Irregular Shape - Follow up
Hi
For those who may have followed this thread begun on 5th June, this demonstrates that defining regions by colour sampling can work. It also expands on Rick Rothstein's reply which uses hard coded nodes. Region functionality is documented at http://msdn.microsoft.com/en-us/libr...50(VS.85).aspx The colour sampling method referred to in the previous post defines single or multi regions and the basis is some VB6 code published by Steve McMahon in January 2003 a http://www.vbaccelerator.com/home/VB...ng/article.asp Here, for the specific purpose of drawing irregular form shapes this has been much adapted. Apologies to those more familiar with VB6 for any gaffs but the edited code works as expected and no glitches so far. Thanks Peter T for decompiling the public domain VB6 example and for further help. The method relies simply on producing an image with masking to delineate unwanted areas and inserting the image on a form using the picture property. By experiment the image must be saved as a gif - jpgs didn't work. The masking colour is easily assigned using an RGB value in the procedure where indicated and in this example is red. Using a mask means the resultant shape or shapes can be as complex as desired. The form needs to be sized appropriately. If this is not done correctly, parts of the mask colour may remain visible. For this example a picture 300 pixels square was perfect on a form 225 square. When the form is Shown it is 'clipped'. This means to move it, the form can only be grabbed from opaque areas. If it is made modeless, cells underlying transparent areas can be selected which may be of use if 'holes' have been designed in. These features apply equally to both methods. Using colour sampling to define regions on a form can be slower to Show compared to using hard coded nodal points largely because more points are calculated. And care has to be exercised regarding the choice of masking colour to avoid unwanted transparencies. But it is much simpler to produce complex shapes. Each opaque region can of course have controls added. Of novel interest perhaps - if irregular shaped 'island' regions have been created then an oversized control is installed on the island, the control will assume the shape of the island region too and the control area will be clipped. If doing this, care is needed with sizing because the control is still a defined shape and though its area may be clipped, its boundaries may become visible on adjacent islands with unwanted results. The second example extends Rick Rothstein's example in the previous post by creating holes. In this, nodal points are hard coded. This method is quick to Show though that is dependent on the number of nodes used. The calculation of nodal points to fit a picture can be fiddly, dependant on its complexity. But approximations may suit just as well depending how the form is deployed. Images used do not need to be in gif format. If all that is required however is a uniformly coloured shape then an image is not required at all, just apply colour to the form's background. Imo for more linear designs, hard coding is probably the best method as it is quick to Show and requires less code but for those wanting more random designs then masking offers simple flexibility. I hope this is of some use. Geoff Please watch out for long code line discontinuation. Method 1 Draw a picture, 300 pixels square with a black background. Paint 2 vertical and 2 horizontal stripes, several pixels wide, in red. Squiggly or straight, doesn't matter. Save as a gif. Insert on a modeless form 225 square using the picture property. Place a commandbutton on the form. ''******************** START OF METHOD 1 In UserForm1 Option Explicit ''form header removal Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function DrawMenuBar Lib "user32" _ (ByVal hwnd As Long) As Long Private Const WS_CAPTION = &HC00000 Private Const GWL_STYLE = (-16) '''form drag Private Const WM_NCLBUTTONDOWN = &HA1 Private Const HTCAPTION = 2 Private Declare Function ReleaseCapture Lib "user32" () As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, _ ByVal wParam As Long, lParam As Any) As Long Dim mFrmHwnd As Long Private m_cDibR As New cDIBSectionRegion Private Sub UserForm_Initialize() Dim lngFormStyle As Long If Application.Version < 9 Then mFrmHwnd = FindWindow("THUNDERXFRAME", Me.Caption) Else mFrmHwnd = FindWindow("THUNDERDFRAME", Me.Caption) End If '''remove form header lngFormStyle = GetWindowLong(mFrmHwnd, GWL_STYLE) lngFormStyle = lngFormStyle And Not WS_CAPTION SetWindowLong mFrmHwnd, GWL_STYLE, lngFormStyle DrawMenuBar mFrmHwnd MakeTransparent End Sub Private Sub MakeTransparent() Dim cDib As New cDIBSection Dim myMask As Long myMask = RGB(255, 0, 0) '''<<<< choose mask colour here cDib.CreateFromPicture Me.Picture m_cDibR.Create cDib, myMask m_cDibR.Applied(mFrmHwnd) = True End Sub Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button And 1 Then Call ReleaseCapture Call SendMessage(mFrmHwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&) End If End Sub Private Sub CommandButton1_Click() Unload UserForm1 Set UserForm1 = Nothing End Sub In a class module cDIBSection Option Explicit '''adapted from: ' ================================================== ================ ' FileName: cDIBSection.cls ' Author: Steve McMahon ' ' A Wrapper around the GDI DIBSection (DIB = Device Independent Bitmap) ' object. A DIB gives you full control over colour depth. The ' DIBSection object also means that the bitmap bits are allocated ' into Windows memory, and so can be directly modified by Windows ' programs. ' ' This class gives you the control you need in VB over a DIBSection. ' ' ------------------------------------------------------------------ ' Visit vbAccelerator - advanced, hardcore VB with full source code ' http://vbaccelerator.com/ ' ' ' ================================================== ================ Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _ lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long) Private Type SAFEARRAYBOUND cElements As Long lLbound As Long End Type Private Type SAFEARRAY2D cDims As Integer fFeatures As Integer cbElements As Long cLocks As Long pvData As Long Bounds(0 To 1) As SAFEARRAYBOUND End Type Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long Private Type RGBQUAD rgbBlue As Byte rgbGreen As Byte rgbRed As Byte rgbReserved As Byte End Type Private Type BITMAPINFOHEADER '40 bytes biSize As Long biWidth As Long biHeight As Long biPlanes As Integer biBitCount As Integer biCompression As Long biSizeImage As Long biXPelsPerMeter As Long biYPelsPerMeter As Long biClrUsed As Long biClrImportant As Long End Type Private Type BITMAPINFO bmiHeader As BITMAPINFOHEADER bmiColors As RGBQUAD End Type Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetDesktopWindow Lib "user32" () As Long ' Note - this is not the declare in the API viewer - modify lplpVoid to be ' Byref so we get the pointer back: Private Declare Function CreateDIBSection Lib "gdi32" _ (ByVal hdc As Long, _ pBitmapInfo As BITMAPINFO, _ ByVal un As Long, _ lplpVoid As Long, _ ByVal handle As Long, _ ByVal dw As Long) As Long Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Const BI_RGB = 0& Private Const DIB_RGB_COLORS = 0 ' color table in RGBs 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 GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long ' Handle to the current DIBSection: Private m_hDIb As Long ' Handle to the old bitmap in the DC, for clear up: Private m_hBmpOld As Long ' Handle to the Device context holding the DIBSection: Private m_hDC As Long ' Address of memory pointing to the DIBSection's bits: Private m_lPtr As Long ' Type containing the Bitmap information: Private m_tBI As BITMAPINFO Public Function CreateDIB( _ ByVal lhDC As Long, _ ByVal lWidth As Long, _ ByVal lHeight As Long, _ ByRef hDib As Long _ ) As Boolean With m_tBI.bmiHeader .biSize = Len(m_tBI.bmiHeader) .biWidth = lWidth .biHeight = lHeight .biPlanes = 1 .biBitCount = 24 .biCompression = BI_RGB .biSizeImage = BytesPerScanLine * .biHeight End With hDib = CreateDIBSection( _ lhDC, _ m_tBI, _ DIB_RGB_COLORS, _ m_lPtr, _ 0, 0) CreateDIB = (hDib < 0) End Function Public Function CreateFromPicture( _ ByRef picThis As StdPicture _ ) Dim lhDC As Long Dim lhDCDesktop As Long Dim lhBmpOld As Long Dim tBMP As BITMAP GetObjectAPI picThis.handle, Len(tBMP), tBMP If (Create(tBMP.bmWidth, tBMP.bmHeight)) Then lhDCDesktop = GetDC(GetDesktopWindow()) If (lhDCDesktop < 0) Then lhDC = CreateCompatibleDC(lhDCDesktop) DeleteDC lhDCDesktop If (lhDC < 0) Then lhBmpOld = SelectObject(lhDC, picThis.handle) LoadPictureBlt lhDC SelectObject lhDC, lhBmpOld DeleteObject lhDC End If End If End If End Function Public Function Create( _ ByVal lWidth As Long, _ ByVal lHeight As Long _ ) As Boolean ClearUp m_hDC = CreateCompatibleDC(0) If (m_hDC < 0) Then If (CreateDIB(m_hDC, lWidth, lHeight, m_hDIb)) Then m_hBmpOld = SelectObject(m_hDC, m_hDIb) Create = True Else DeleteObject m_hDC m_hDC = 0 End If End If End Function Public Property Get BytesPerScanLine() As Long ' Scans must align on dword boundaries: BytesPerScanLine = (m_tBI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC End Property Public Property Get Width() As Long Width = m_tBI.bmiHeader.biWidth End Property Public Property Get Height() As Long Height = m_tBI.bmiHeader.biHeight End Property Public Sub LoadPictureBlt( _ ByVal lhDC As Long, _ Optional ByVal lSrcLeft As Long = 0, _ Optional ByVal lSrcTop As Long = 0, _ Optional ByVal lSrcWidth As Long = -1, _ Optional ByVal lSrcHeight As Long = -1, _ Optional ByVal eRop As Long = 13369376 _ ) If lSrcWidth < 0 Then lSrcWidth = m_tBI.bmiHeader.biWidth If lSrcHeight < 0 Then lSrcHeight = m_tBI.bmiHeader.biHeight BitBlt m_hDC, 0, 0, lSrcWidth, lSrcHeight, lhDC, lSrcLeft, lSrcTop, eRop End Sub Public Property Get DIBSectionBitsPtr() As Long DIBSectionBitsPtr = m_lPtr End Property Public Sub ClearUp() If (m_hDC < 0) Then If (m_hDIb < 0) Then SelectObject m_hDC, m_hBmpOld DeleteObject m_hDIb End If DeleteObject m_hDC End If m_hDC = 0: m_hDIb = 0: m_hBmpOld = 0: m_lPtr = 0 End Sub Private Sub Class_Terminate() ClearUp End Sub In a class module cDIBSectionRegion Option Explicit '''adapted from: ' ================================================== ================ ' FileName: cDIBSectionRegion.cls ' Author: Steve McMahon ' ' Converts a cDIBSection object into a region which you can apply ' to a form, UserControl or PictureBox (in fact, anything with a ' hWnd property). ' ------------------------------------------------------------------ ' Visit vbAccelerator - advanced, hardcore VB with full source code ' http://vbaccelerator.com/ ' ' ' ================================================== ================ ' API for creating a region: Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long Private Const RGN_AND = 1 Private Const RGN_COPY = 5 Private Const RGN_DIFF = 4 Private Const RGN_OR = 2 Private Const RGN_XOR = 3 Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long ' API for reading cDIBSection bits: Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _ lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long) Private Type SAFEARRAYBOUND cElements As Long lLbound As Long End Type Private Type SAFEARRAY2D cDims As Integer fFeatures As Integer cbElements As Long cLocks As Long pvData As Long Bounds(0 To 1) As SAFEARRAYBOUND End Type Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long ' Implementation: Private m_hRgn As Long Private m_hWnd() As Long Private m_iCount As Long Public Property Let Applied(ByVal hwnd As Long, ByVal bState As Boolean) Dim i As Long Dim lIndex As Long lIndex = plIndex(hwnd) If bState Then If (lIndex = 0) Then ' Apply to window: m_iCount = m_iCount + 1 ReDim Preserve m_hWnd(1 To m_iCount) As Long m_hWnd(m_iCount) = hwnd SetWindowRgn m_hWnd(m_iCount), m_hRgn, True Else ' already applied, reset apply state jic SetWindowRgn m_hWnd(m_iCount), m_hRgn, True End If Else If (lIndex = 0) Then ' Not applied, reset state jic SetWindowRgn hwnd, 0, True Else ' Applied, reset: SetWindowRgn hwnd, 0, True If m_iCount 1 Then For i = lIndex To m_iCount - 1 m_hWnd(i) = m_hWnd(i + 1) Next i m_iCount = m_iCount - 1 ReDim Preserve m_hWnd(1 To m_iCount) As Long Else m_iCount = 0 Erase m_hWnd End If End If End If End Property Private Property Get plIndex(ByVal hwnd As Long) As Long Dim i As Long Dim lIndex As Long For i = 1 To m_iCount If hwnd = m_hWnd(i) Then plIndex = i Exit For End If Next i End Property Private Sub UnApply() Dim i As Long For i = 1 To m_iCount If Not m_hWnd(i) = 0 Then SetWindowRgn m_hWnd(i), 0, True m_hWnd(i) = 0 End If Next i m_iCount = 0 End Sub Public Sub Destroy() UnApply If Not m_hRgn = 0 Then DeleteObject m_hRgn End If m_hRgn = 0 End Sub Public Sub Create( _ ByRef cDib As cDIBSection, _ Optional ByRef lTransColor As Long = 0 _ ) Dim X As Long, Y As Long Dim lX As Long Dim yStart As Long Dim bStart As Boolean Dim hRgnTemp As Long Dim Br As Byte, bG As Byte, bB As Byte Dim lWidth As Long, lHeight As Long Dim bDib() As Byte Dim tSA As SAFEARRAY2D Destroy ' The transparent colour: Br = (lTransColor And &HFF&) bG = (lTransColor And &HFF00&) \ &H100& bB = (lTransColor And &HFF0000) \ &H10000 ' Create the base region m_hRgn = CreateRectRgn(0, 0, cDib.Width, cDib.Height) Debug.Assert (m_hRgn < 0) If m_hRgn < 0 Then ' Get the DIB into byte array: With tSA .cbElements = 1 .cDims = 2 .Bounds(0).lLbound = 0 .Bounds(0).cElements = cDib.Height .Bounds(1).lLbound = 0 .Bounds(1).cElements = cDib.BytesPerScanLine() .pvData = cDib.DIBSectionBitsPtr End With CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4 lWidth = cDib.BytesPerScanLine \ 3 lHeight = cDib.Height For X = 0 To (lWidth - 1) * 3 Step 3 ' DIB Sections are "upside down" :) For Y = lHeight - 1 To 0 Step -1 If bDib(X, Y) = bB And bDib(X + 1, Y) = bG And bDib(X + 2, Y) = Br Then If Not bStart Then yStart = lHeight - 1 - Y bStart = True End If Else If bStart Then hRgnTemp = CreateRectRgn(lX, yStart, lX + 1, lHeight - 1 - Y) CombineRgn m_hRgn, hRgnTemp, m_hRgn, RGN_XOR DeleteObject hRgnTemp bStart = False End If End If Next Y If bStart Then hRgnTemp = CreateRectRgn(lX, yStart, lX + 1, lHeight - 1 - Y) CombineRgn m_hRgn, hRgnTemp, m_hRgn, RGN_XOR DeleteObject hRgnTemp bStart = False End If lX = lX + 1 Next X CopyMemory ByVal VarPtrArray(bDib), 0&, 4 End If End Sub Private Sub Class_Terminate() Destroy End Sub ''******************** END OF METHOD 1 Method 2 On a modeless form 350 square apply a background colour. Place a commandbutton on the form. ''******************** START OF METHOD 2 In UserForm2 Option Explicit Private Type POINTAPI X As Long Y As Long End Type Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _ ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Private Declare Function CreateRectRgn Lib "gdi32" ( _ ByVal X1 As Long, ByVal Y1 As Long, _ ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function CombineRgn Lib "gdi32" ( _ ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, _ ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long Private Declare Function SetWindowRgn Lib "user32" ( _ ByVal hwnd As Long, _ ByVal hRgn As Long, ByVal bRedraw As Long) As Long Private Declare Function DeleteObject Lib "gdi32" ( _ ByVal hObject As Long) As Long Private Const RGN_DIFF = 4 Dim hwnd As Long Dim DefinedRegion As Long Dim HoleRegion As Long Private Declare Function ReleaseCapture Lib "user32" () As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _ ByVal hwnd As Long, ByVal wMsg As Long, _ ByVal wParam As Long, lParam As Any) As Long Private Const WM_NCLBUTTONDOWN = &HA1 Private Const HTCAPTION = 2 Private Sub UserForm_Initialize() Dim newRgn As Long If Application.Version < 9 Then hwnd = FindWindow("THUNDERXFRAME", Me.Caption) Else hwnd = FindWindow("THUNDERDFRAME", Me.Caption) End If DefinedRegion = CreateRectRgn(0, 30, 310, 350) HoleRegion = CreateRectRgn(90, 0, 110, 350) newRgn = CombineRgn(DefinedRegion, DefinedRegion, HoleRegion, RGN_DIFF) HoleRegion = CreateRectRgn(200, 0, 220, 350) newRgn = CombineRgn(DefinedRegion, DefinedRegion, HoleRegion, RGN_DIFF) HoleRegion = CreateRectRgn(0, 130, 350, 150) newRgn = CombineRgn(DefinedRegion, DefinedRegion, HoleRegion, RGN_DIFF) HoleRegion = CreateRectRgn(0, 240, 350, 260) newRgn = CombineRgn(DefinedRegion, DefinedRegion, HoleRegion, RGN_DIFF) SetWindowRgn hwnd, DefinedRegion, True DeleteObject DefinedRegion DeleteObject HoleRegion DeleteObject newRgn End Sub Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _ ByVal X As Single, ByVal Y As Single) If Button And 1 Then Call ReleaseCapture Call SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&) End If End Sub Private Sub CommandButton1_Click() Unload UserForm2 Set UserForm2 = Nothing End Sub ''******************** END OF METHOD 2 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Irregular Shape | Excel Programming | |||
Evaluating if a Shape is a line or a shape | Excel Programming | |||
my curser changed from arrow shape to a cross shape???? | New Users to Excel | |||
Deleting a shape and the cell contents the shape is in. | Excel Programming | |||
Deleting a shape and the cell contents the shape is in. | Excel Programming |