Dim lblObj() As New Class1
Public lblName As String
Sub AutoOpen()
Dim n As Long
Dim oleObj As OLEObject
For Each oleObj In Sheets("SBS").OLEObjects
If InStr(oleObj.progID, "Forms.Label") Then
n = n + 1
oleObj.Object.BorderStyle = fmBorderStyleNone
ReDim Preserve lblObj(n)
Set lblObj(n).lbl = oleObj.Object
End If
Next
End SubPublic WithEvents lbl As MSForms.Label
Private Sub lbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
If UCase(lbl.Name) <> UCase(lblName) Then
lbl.BorderStyle = fmBorderStyleSingle
Sheets("SBS").OLEObjects(lblName).Object.BorderStyle = fmBorderStyleNone
lblName = lbl.Name
End If
End Sub
pen rồi rà chuột vào các Label xem sao!
Public WithEvents lbl As MSForms.Label
Private Sub lbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
If UCase(lbl.Name) <> UCase(lblName) Then
lbl.BorderStyle = fmBorderStyleSingle
Sheets("SBS").OLEObjects(lblName).Object.BorderStyle = fmBorderStyleNone
lblName = lbl.Name
Range("O2") = lblName
Call ShowLabel_be4
Sheets("dieukiennho").Range("SBS_celllabel") = lblName
Sheets("dieukiennho").Range("SBS_cellshape") = Replace(lblName, "label", "SBS_shape", , , vbTextCompare)
Call Hidelabel
End If
End SubPrivate Sub Workbook_Open()
Sheets("SBS").LabelSet
End SubPublic OldLabel As ObjectVề giải thuật thì cũng không có gì để bàn (hôm trước nhậu ta bàn rồi)
Code nhìn rất chuẩn,.
Nhưng hiệu ứng thì chưa giống. Minh đang xem thử có thể kết hợp code của bạn vào hiệu ứng Shadow được ko.
Thanks Hoang Trong Nghia !
Public lblObj() As New clsEffect, n As Long
Public szLabelName As String, szShapeName As String
Sub Auto_Open()
Dim oleObj As OLEObject
n = 0
Sheet1.lblBgrnd.Visible = False
For Each oleObj In Sheet1.OLEObjects
If InStr(oleObj.progID, "Forms.Label") Then
n = n + 1
oleObj.Object.BackStyle = 0
oleObj.Visible = True
ReDim Preserve lblObj(1 To n)
Set lblObj(n).lbl = oleObj.Object
End If
Next
End Sub
Sub ShadowSetup(ByVal Shape As Shape, ByVal ShadowType As Long, ByVal ShadowVisible As Boolean)
With Shape.Shadow
.Visible = ShadowVisible
.Parent.TextFrame.Characters.Font.Bold = ShadowVisible
If ShadowVisible Then
.OffsetX = 0
.OffsetY = 0
.Size = 105
.Type = ShadowType
End If
End With
End SubPublic WithEvents lbl As MSForms.Label
Private Sub lbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
Sheet1.lblBgrnd.Visible = (lbl.Name <> "lblBgrnd")
If UCase(lbl.Name) <> UCase(szLabelName) Then
ShadowSetup Sheet1.Shapes(szShapeName), 25, False
szLabelName = lbl.Name
szShapeName = Replace(szLabelName, "label", "", , , vbTextCompare)
ShadowSetup Sheet1.Shapes(szShapeName), 25, True
End If
End SubPrivate Sub Worksheet_SelectionChange(ByVal Target As Range)
If n = 0 Then Auto_Open
End Sub
\
Mục đích của mình vẫn giữ nguyên Shadow sau khi rê chuột ra ngoài vì sau khi Link đến sheet trùng với tên Shape và khi trở lại sheet chính vẫn thấy được sheet nào vừa kích hoạt.
Thanks 2 anh !
File e đang dùng nó giống y như vậy.
pen
Các đối tượng được Wrap từ lúc mở file. Lúc đó name szLabelName chưa có giá trị (rỗng) nên sẽ không bao giờ chọn được Lable lblBgrnd như trường hợp anh nói. Nếu đang chạy file mà gọi lại sub AutThắng thí nghiệm vầy nha:
- Đặt con trỏ chuột tại cell A1
- Alt + F8 chạy lại sub Aut
- Xong, chọn chuột vào cell B2
Xem thử thấy gì?
Ẹc... Ẹc...
pen thì mới có hiện tượng này do lúc này name szLabelName đã có giá trị, muốn khắc phục thì chỉ cần cho cái Lable lblBgrnd ẩn đi trong sub Autpen hoặc gán szLabelName bằng rỗng là được thôi mà.
Các đối tượng được Wrap từ lúc mở file. Lúc đó name szLabelName chưa có giá trị (rỗng) nên sẽ không bao giờ chọn được Lable lblBgrnd như trường hợp anh nói. Nếu đang chạy file mà gọi lại sub Aut
pen để phục hồi... Và đây chính là lúc vấn đề xảy ra (khi click chuột vào vùng chứa Lable background)
E thay đổi như thế này được ko a?
Sub ShadowSetup(ByVal Shape As Shape, ByVal ShadowType As Long, ByVal ShadowVisible As Boolean)
With Shape.Shadow
.Visible = ShadowVisible
'.Parent.TextFrame.Characters.Font.Bold = ShadowVisible
If ShadowVisible Then
[COLOR=#ff0000].Style = msoShadowStyleOuterShadow[/COLOR]
[COLOR=#ff0000] .Blur = 9[/COLOR]
.OffsetX = 0
.OffsetY = 0
[COLOR=#ff0000].Transparency = 0.3999999762[/COLOR]
.Size = 102
End If
End With
End SubShadowSetup Sheet1.Shapes(szShapeName), [COLOR=#ff0000]25[/COLOR], FalseSub ShadowSetup(ByVal Shape As Shape, [COLOR=#ff0000]ByVal ShadowStyle As Long, [/COLOR][COLOR=#0000cd]ByVal Blurriness As Long[/COLOR], _
[COLOR=#006400]ByVal ShadowTransparency As Double[/COLOR], ByVal ShadowVisible As Boolean)
With Shape.Shadow
.Visible = ShadowVisible
If ShadowVisible Then
[B] [COLOR=#ff0000].Style = ShadowStyle
[/COLOR][COLOR=#0000cd].Blur = Blurriness[/COLOR][/B]
[COLOR=#006400][B].Transparency = ShadowTransparency[/B][/COLOR]
.OffsetX = 0
.OffsetY = 0
.Size = 102
End If
End With
End SubShadowSetup .Shapes(szShapeName), [COLOR=#ff0000][B]2[/B][/COLOR], [B][COLOR=#0000cd]9[/COLOR][/B], [COLOR=#006400][B]0.3999999762[/B][/COLOR], FalseWith Application.ActiveSheet.Shapes(lbl.Name)
.Visible = False
End WithPrivate Sub lbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error Resume Next
If UCase(lbl.Name) <> UCase(szLabelName) Then
[COLOR=#ff0000] lbl.Visible = False[/COLOR]
'show labelbe4
With ActiveSheet
[COLOR=#ff0000].OLEObjects(szLabelName)[/COLOR].Visible = True
[COLOR=#ff0000] ShadowSetup .Shapes(szShapeName), 2, 9, 0.3999999762, False [/COLOR]'shape_be4
szLabelName = lbl.Name
szShapeName = Replace(szLabelName, "label", "", , , vbTextCompare)
[COLOR=#ff0000]ShadowSetup .Shapes(szShapeName), 2, 9, 0.3999999762, True[/COLOR] 'shape_mousemove
End With
End If
End SubCái "mẹo" ấy người ta dùng dùng đấy thôi
Tôi thấy bài này trở đi là đã rất mượt mà rồi, tuy nhiên tôi thấy rằng khi hiệu ứng được tạo ra, khi rê chuột ngang qua các Shape nó còn chuyển con trỏ thành cái nắm (mũi tên 4 chiều).
").
