function.vbs

报表设计器

			Next
		Next		
		.Invalidate
	End With
End Sub

'垂直居中对齐
Public Sub cmdAlignMiddle_click()
	With CellWeb1
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		CurCol = .GetCurrentCol
	        CurRow = .GetCurrentRow
	        CurSheet = .GetCurSheet
	        vAlign = .GetCellAlign(CurCol, CurRow, CurSheet)
	        If (HAlign and 32) = 32 Then
	        	vAlign = 0
	        Else
	        	vAlign = 32
		End If
		For i = StartCol To EndCol
			For j = StartRow To EndRow
			    hAlign = .GetCellAlign( i, j, CurSheet) and (1+2+4)
			    align = vAlign + hAlign
			    .SetCellAlign i, j, CurSheet, align
			Next
		Next		
		.Invalidate
	End With
End Sub

'居下对齐
Public Sub cmdAlignBottom_click()
	With CellWeb1
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		CurCol = .GetCurrentCol
	        CurRow = .GetCurrentRow
	        CurSheet = .GetCurSheet
	        vAlign = .GetCellAlign(CurCol, CurRow, CurSheet)
	        If (HAlign and 16) = 16 Then
	        	vAlign = 0
	        Else
	        	vAlign = 16
		End If
		For i = StartCol To EndCol
			For j = StartRow To EndRow
			    hAlign = .GetCellAlign( i, j, CurSheet) and (1+2+4)
			    align = vAlign + hAlign
			    .SetCellAlign i, j, CurSheet, align
			Next
		Next		
		.Invalidate
	End With
End Sub

'画边框线
Public Sub cmdDrawBorder_click()
	With CellWeb1
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		CurSheet = .GetCurSheet
		.DrawGridLine StartCol, StartRow, EndCol, EndRow, 0, BorderTypeSelect.value, -1
        End With
End Sub

'抹框线
Public Sub cmdEraseBorder_click()
	With CellWeb1
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		CurSheet = .GetCurSheet
		.ClearGridLine StartCol, StartRow, EndCol, EndRow, 0
        End With
End Sub

'货币符号
Public Sub cmdCurrency_click()
	With CellWeb1
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		CurSheet = .GetCurSheet
		For i = StartCol To EndCol
			For j = StartRow To EndRow
			    .SetCellCurrency i, j, CurSheet, 2
			Next
		Next		
		.Invalidate
        End With
End Sub

'百分号
Public Sub cmdPercent_click()
	With CellWeb1
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		CurCol = .GetCurrentCol
	        CurRow = .GetCurrentRow
	        CurSheet = .GetCurSheet
	        If .GetCellNumType( CurCol, CurRow, CurSheet) = 5 Then
			For i = StartCol To EndCol
				For j = StartRow To EndRow
				    .SetCellNumType i, j, CurSheet, 0
				Next
			Next		
		Else 
			For i = StartCol To EndCol
				For j = StartRow To EndRow
				    .SetCellNumType i, j, CurSheet, 5
				Next
			Next	
		End If	
		.Invalidate
	End With
End Sub

'千分位
Public Sub cmdThousand_click()
	With CellWeb1
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		CurCol = .GetCurrentCol
	        CurRow = .GetCurrentRow
	        CurSheet = .GetCurSheet
	        If .GetCellSeparator( CurCol, CurRow, CurSheet) = 2 Then
	        	For i = StartCol To EndCol
				For j = StartRow To EndRow
				    .SetCellNumType i, j, CurSheet, 1
				    .SetCellSeparator i, j, CurSheet, 1
                            	Next
			Next		
		Else 
			For i = StartCol To EndCol
				For j = StartRow To EndRow
				    .SetCellNumType i, j, CurSheet, 1
				    .SetCellSeparator i, j, CurSheet, 2
				Next
			Next	
		End If	
		.Invalidate
	End With
End Sub

'关于华表插件
Public Sub cmdAbout_click()
	CellWeb1.AboutBox
End Sub

'插入列
Public Sub cmdInsertCol_click()
	With CellWeb1
		StartCol = 0: StartRow = 0: EndCol = 0: EndRow = 0
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		.InsertCol StartCol, EndCol - StartCol + 1, .GetCurSheet
	End With
End Sub

'插入行
Public Sub cmdInsertRow_click()
	With CellWeb1
		StartCol = 0: StartRow = 0: EndCol = 0: EndRow = 0
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		.InsertRow StartRow, EndRow - StartRow + 1, .GetCurSheet
	End With
End Sub

'追加列
Public Sub cmdAppendCol_click()
	With CellWeb1
		StartCol = 0: StartRow = 0: EndCol = 0: EndRow = 0
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		.InsertCol .GetCols(.GetCurSheet), EndCol - StartCol + 1, .GetCurSheet
	End With
End Sub

'追加行
Public Sub cmdAppendRow_click()
	With CellWeb1
		StartCol = 0: StartRow = 0: EndCol = 0: EndRow = 0
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		.InsertRow .GetRows(.GetCurSheet), EndRow - StartRow + 1, .GetCurSheet
	End With
End Sub

'删除列
Public Sub cmdDeleteCol_click()
	With CellWeb1
		StartCol = 0: StartRow = 0: EndCol = 0: EndRow = 0
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		.DeleteCol StartCol, EndCol - StartCol + 1, .GetCurSheet
	End With
End Sub

'删除行
Public Sub cmdDeleteRow_click()
	With CellWeb1
		StartCol = 0: StartRow = 0: EndCol = 0: EndRow = 0
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		.DeleteRow StartRow, EndRow - StartRow + 1, .GetCurSheet
	End With
End Sub

'表页尺寸
Public Sub cmdSheetSize_click()
	With CellWeb1
		.SetCols .GetCurrentCol + 1, .GetCurSheet
		.SetRows .GetCurrentRow + 1, .GetCurSheet
	End With
End Sub

'行组合
Public Sub cmdMergeRow_click()
	With CellWeb1
		StartCol = 0: StartRow = 0: EndCol = 0: EndRow = 0
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		For i = StartRow To EndRow
			.MergeCells StartCol, i, EndCol, i
		Next
        End With
End Sub

'列组合
Public Sub cmdMergeCol_click()
	With CellWeb1
		StartCol = 0: StartRow = 0: EndCol = 0: EndRow = 0
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		For i = StartCol To EndCol
			.MergeCells i, StartRow, i, EndRow
		Next
        End With
End Sub

'设置汇总公式
Public Sub cmdFormulaSum3D_click()
	With CellWeb1
           StartCol = 0: StartRow = 0: EndCol = 0: EndRow = 0
           .GetSelectRange StartCol, StartRow, EndCol, EndRow
           If .GetTotalSheets() > 1 Then
                For i = StartCol To EndCol
                    For j = StartRow To EndRow
                        If .GetCurSheet() = 0 Then
                            .SetFormula i, j, .GetCurSheet, "Sum3D( CurCell() , loopsheet() >=" & CStr(2) & " AND loopsheet() <=" & CStr(.GetTotalSheets()) & ")"
                        Else
                            .SetFormula i, j, .GetCurSheet, "Sum3D( CurCell() , loopsheet() >= 1 AND loopsheet() <= " & CStr(.GetCurSheet()) & ")"
                        End If
                    Next
                Next
            Else:
                MsgBox "当前单元格只有一页，不能进行汇总。", vbExclamation
            End If
            .Invalidate
	End With
End Sub

'单元格只读
Public Sub cmdReadOnly_click()
	With CellWeb1
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		CurCol = .GetCurrentCol
	        CurRow = .GetCurrentRow
	        CurSheet = .GetCurSheet
	        If .GetCellInput( CurCol, CurRow, CurSheet) = 5 Then
			For i = StartCol To EndCol
				For j = StartRow To EndRow
				    .SetCellInput i, j, .GetCurSheet, 1
				Next
			Next
		Else
			For i = StartCol To EndCol
				For j = StartRow To EndRow
				    .SetCellInput i, j, .GetCurSheet, 5
				Next
			Next
		End If
		.Invalidate
        End With
End Sub


'*****************************************************************
'**********      表格中的右键菜单
'*****************************************************************
Dim TotalMenu

'设置右键菜单
Public Sub CellWeb1_MenuStart( ByVal col, ByVal row, ByVal section)
With CellWeb1
    If section = 1 Then '鼠标在表格区内
        .AddPopMenu 1001, "剪切(&T)", 0
        .AddPopMenu 1002, "复制(&C)", 0
        .AddPopMenu 1003, "粘贴(&P)", 0
        .AddPopMenu 1004, "选择性粘贴(&S)...", 0
        .AddPopMenu 1000, "", 0
        .AddPopMenu 1005, "输入公式(&I)", 0
        .AddPopMenu 1006, "格式刷(&M)", 0
        .AddPopMenu 1000, "", 0
        .AddPopMenu 1007, "清除内容(&N)     Del", 0
        .AddPopMenu 1008, "清除公式(&L)", 0
        .AddPopMenu 1009, "清除全部(&A)", 0
        .AddPopMenu 1000, "", 0
        .AddPopMenu 1010, "单元格格式(&C)...", 0
        .AddPopMenu 1011, "超级链接(&H)...", 0
    ElseIf section = 2 Then '鼠标在行标上
        .AddPopMenu 1001, "剪切(&T)", 0
        .AddPopMenu 1002, "复制(&C)", 0
        .AddPopMenu 1003, "粘贴(&P)", 0
        .AddPopMenu 1004, "选择性粘贴(&S)...", 0
        .AddPopMenu 1000, "", 1
        .AddPopMenu 1012, "插入表行(&I)", 0
        .AddPopMenu 1013, "删除表行(&D)", 0
        .AddPopMenu 1014, "追加表行(&A)", 0
        .AddPopMenu 1000, "", 0
        .AddPopMenu 1015, "行高(&H)...", 0
        .AddPopMenu 1016, "最适合行高(&B)", 0
        .AddPopMenu 1017, "隐藏(&N)", 0
        .AddPopMenu 1018, "取消隐藏(&U)", 0
    ElseIf section = 3 Then '鼠标在列标上
        .AddPopMenu 1001, "剪切(&T)", 0
        .AddPopMenu 1002, "复制(&C)", 0
        .AddPopMenu 1003, "粘贴(&P)", 0
        .AddPopMenu 1004, "选择性粘贴(&S)...", 0
        .AddPopMenu 1000, "", 0
        .AddPopMenu 1019, "插入表列(&I)", 0
        .AddPopMenu 1020, "删除表列(&D)", 0
        .AddPopMenu 1021, "追加表列(&A)", 0
        .AddPopMenu 1000, "", 0
        .AddPopMenu 1022, "列宽(&W)", 0
        .AddPopMenu 1023, "最适合列宽(&W)", 0
        .AddPopMenu 1024, "隐藏(&N)", 0
        .AddPopMenu 1025, "取消隐藏(&U)", 0
    ElseIf section = 4 Then '鼠标在左上角
    	.AddPopMenu 1001, "剪切(&T)", 0
        .AddPopMenu 1002, "复制(&C)", 0
        .AddPopMenu 1003, "粘贴(&P)", 0
        .AddPopMenu 1004, "选择性粘贴(&S)...", 0
        .AddPopMenu 1000, "", 0
        .AddPopMenu 1007, "清除内容(&N)     Del", 0
        .AddPopMenu 1008, "清除公式(&L)", 0
        .AddPopMenu 1009, "清除全部(&A)", 0
        .AddPopMenu 1000, "", 0
        .AddPopMenu 1010, "单元格格式(&C)...", 0
        .AddPopMenu 1026, "表页尺寸(&S)", 0
        .AddPopMenu 1027, "表页另存为(&O)...", 0
    ElseIf section = 5 Then '鼠标在页签上
        .AddPopMenu 1028, "插入表页(&I)...", 0
        .AddPopMenu 1029, "删除表页(&D)...", 0
        .AddPopMenu 1030, "追加表页(&A)...", 0
        .AddPopMenu 1000, "", 0
        .AddPopMenu 1031, "重命名(&R)...", 0
        .AddPopMenu 1032, "表页排序(&S)...", 0
        .AddPopMenu 1000, "", 0
        .AddPopMenu 1026, "表页尺寸(&F)...", 0
        .AddPopMenu 1027, "表页另存为(&O)...", 0
        If .IsSheetProtect(.GetCurSheet) Then
            .AddPopMenu 1033, "表页解锁(&L)...", 0
        Else
            .AddPopMenu 1033, "表页保护(&L)...", 0
        End If
    ElseIf section = 6 Then '鼠标在页签的操作按扭上时
    	CurSheet = .GetCurSheet
    	TotalMenu = .GetTotalSheets
        For i = 1 To TotalMenu
            If i - 1 = CurSheet Then
                .AddPopMenu 1040 + i, .GetSheetLabel(i - 1), 8
            Else
                .AddPopMenu 1040 + i, .GetSheetLabel(i - 1), 0
            End If
        Next
    End If
End With
End Sub

'清除内容
Public Sub cmdClearContent_Click()
	CellWeb1.Clear 1
End Sub

'清除公式
Public Sub cmdClearFormula_Click()
	CellWeb1.Clear 2
End Sub

'清除全部
Public Sub cmdClearAll_Click()
	CellWeb1.Clear 32
End Sub


'右键菜单命令
Public Sub CellWeb1_MenuCommand(ByVal col, ByVal row, ByVal itemid)
    '单元格中的右键菜单
    With CellWeb1
        Select Case itemid
            Case 1001: mnuEditCut_Click				'剪切
            Case 1002: mnuEditCopy_Click			'复制
            Case 1003: mnuEditPaste_Click			'粘贴
            Case 1004: mnuEditPasteSpecial_Click		'选择性粘贴
            Case 1005: mnuFormulaInput_Click			'输入公式
            Case 1006: CellWeb1.FormatPainter			'格式刷
            Case 1007: cmdClearContent_Click			'清除内容
            Case 1008: cmdClearFormula_Click			'清除公式
            Case 1009: cmdClearAll_Click			'清除全部
            Case 1010: mnuFormatCellProperty_click		'单元格属性
            Case 1011: mnuEditHyperlink_Click			'超级链接
            
            '行标菜单
            Case 1012 cmdInsertRow_click			'插入表行
            Case 1013 cmdDeleteRow_click 			'删除行
            Case 1014 cmdAppendRow_click			'追加行
            Case 1015: mnuRowHeight_click			'行高
            Case 1016: mnuRowBestHeight_click			'最适合行高
            Case 1017: mnuRowHide_click				'隐藏行
            Case 1018: mnuRowUnhide_click			'取消隐藏行
            
            '列标菜单
            Case 1019 cmdInsertCol_click			'插入列
            Case 1020 cmdDeleteCol_click			'删除列
            Case 1021 cmdAppendCol_click			'追加列
            Case 1022: mnuColWidth_click			'列宽
            Case 1023: mnuColBestWidth_click			'最适合列宽
            Case 1024: mnuColHide_click				'隐藏列
            Case 1025: mnuColUnhide_click			'取消隐藏列
            
            
            '表页菜单
            Case 1026: mnuSheetSize_click			'表页尺寸
            Case 1027: mnuFileSheetSaveAs_click			'表页另存为
            Case 1028: .InsertSheet .GetCurSheet, 1		'插入表页
            Case 1029: .DeleteSheet .GetCurSheet, 1		'删除表页
            Case 1030: .InsertSheet .GetTotalSheets, 1		'追加表页
            Case 1031: mnuSheetRename_Click			'重命名页签
            Case 1032: mnuSheetSortStyle_click			'表页排序
            Case 1033: mnuSheetProptect_click			'表页保护
        End Select
    End With
    
    '鼠标在页签的操作按扭上的菜单
    For i = 1 To TotalMenu
        If itemid = 1040 + i Then
        	CellWeb1.SetCurSheet i - 1
        	Exit For
        End If
    Next
End Sub

'*****************************************************************
'**********      下拉列表框中的事件
'*****************************************************************
'设置显示比例
Public Sub changeViewScale( ByVal value )
	zoom = value/100.0
	CellWeb1.SetScreenScale CellWeb1.GetCurSheet, zoom
End Sub

'设置字体
Public Sub changeFontName( ByVal value )
    With CellWeb1
        .GetSelectRange StartCol, StartRow, EndCol, EndRow
        CurSheet = .GetCurSheet
        lFontName = .FindFontIndex( value, 1)
        For i = StartCol To EndCol
            For j = StartRow To EndRow
                .SetCellFont i, j, CurSheet, lFontName
            Next
        Next
        .Invalidate
    End With
End Sub

'设置字号
Public Sub changeFontSize( ByVal value )
    msgbox(value)
    With CellWeb1
        .GetSelectRange StartCol, StartRow, EndCol, EndRow
        CurSheet = .GetCurSheet
        lFontSize = value
        For i = StartCol To EndCol
            For j = StartRow To EndRow
                .SetCellFontSize i, j, CurSheet, lFontSize
            Next
        Next
        .Invalidate
    End With

End Sub

'填充类型
Public Sub changeFillType( ByVal value )
	CellWeb1.Fill value
End Sub

'日期类型
Public Sub changeDateType( ByVal value )
    With CellWeb1
        .GetSelectRange StartCol, StartRow, EndCol, EndRow
        CurSheet = .GetCurSheet
        For i = StartCol To EndCol
            For j = StartRow To EndRow
                .SetCellDouble i, j, CurSheet, CSng(Now())
                .SetCellNumType i, j, CurSheet, 3
                .SetCellDateStyle i, j, CurSheet, value
            Next
        Next
    End With
	
End Sub

'时间类型
Public Sub changeTimeType( ByVal value )
    With CellWeb1
        .GetSelectRange StartCol, StartRow, EndCol, EndRow
        CurSheet = .GetCurSheet
        For i = StartCol To EndCol
            For j = StartRow To EndRow
                .SetCellDouble i, j, CurSheet, CSng(Now())
                .SetCellNumType i, j, CurSheet, 4
                .SetCellTimeStyle i, j, CurSheet, value
            Next
        Next
    End With
End Sub