|
|
楼主 |
发表于 2009-7-30 16:53
|
显示全部楼层
有很多的朋友，没有装vb6，我将源码贴出来，请多提宝贵建议
Option Explicit
Private WithEvents objExcelApp As Excel.Application
Private WithEvents objButton As Office.CommandBarButton
'========================================================================
''启动时执行的任务
'========================================================================
Private Sub AddinInstance_OnConnection(ByVal Application As Object, ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, ByVal AddInInst As Object, custom() As Variant)
Set objExcelApp = Application
If CInt(objExcelApp.Version) < 12 Then
Call CreateMenu '如果是2007及以上的版本，则不支持
Else
objExcelApp.COMAddIns("ExcelCellWrapText.Connect").Connect = False '取消链接
Set objExcelApp = Nothing '否则取消关联
End If
End Sub
'========================================================================
'移除时执行的任务
'========================================================================
Private Sub AddinInstance_OnDisconnection(ByVal RemoveMode As AddInDesignerObjects.ext_DisconnectMode, custom() As Variant)
Call DeleteMenu
Set objButton = Nothing
Set objExcelApp = Nothing
End Sub
'========================================================================
'创建按钮和关联对象
'========================================================================
Private Sub CreateMenu()
Call DeleteMenu
'objExcelApp.CommandBars("Formatting").Visible = True
Set objButton = before:=10, Temporary:=True)
With objButton
.Caption = "自动换行"
.Visible = True
.FaceId = 194
.Style = msoButtonIconAndCaption
.Tag = "objButton1"
End With
End Sub
'========================================================================
'删除按钮
'========================================================================
Private Sub DeleteMenu()
On Error Resume Next
'CommandBars(1).Reset
End Sub
'========================================================================
'按钮的动作
'========================================================================
Private Sub objButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
On Error GoTo RangeErr
objExcelApp.Selection.WrapText = Not objExcelApp.Selection.WrapText
With objButton
If .State = msoButtonDown Then
.State = msoButtonUp
ElseIf .State = msoButtonUp Then
.State = msoButtonDown
End If
End With
RangeErr:
If Err.Number = "1004" Then MsgBox "该工作表有保护，请取消工作表保护后再设置自动换行！", vbExclamation, Title:="请检查！"
End Sub
'========================================================================
'切换工作表时的检测
'========================================================================
Private Sub objExcelApp_SheetActivate(ByVal Sh As Object)
If objExcelApp.ActiveCell.WrapText = True Then
objButton.State = msoButtonDown
Else
objButton.State = msoButtonUp
End If
End Sub
'========================================================================
'切换单元格区域时的检测
'========================================================================
Private Sub objExcelApp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
If Target.WrapText = True Then
objButton.State = msoButtonDown
Else
objButton.State = msoButtonUp
End If
End Sub
'========================================================================
'切换工作簿时的检测
'========================================================================
Private Sub objExcelApp_WorkbookActivate(ByVal Wb As Excel.Workbook)
If objExcelApp.ActiveCell.WrapText = True Then
objButton.State = msoButtonDown
Else
objButton.State = msoButtonUp
End If
End Sub
'========================================================================
'关闭工作簿时的检测
'========================================================================
Private Sub objExcelApp_WorkbookDeactivate(ByVal Wb As Excel.Workbook)
If objExcelApp.Workbooks.Count = 1 Then objButton.State = msoButtonUp
End Sub
[ 本帖最后由 三戒 于 2009-8-12 15:52 编辑 ] |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-7-30 16:51
