function.vbs

报表设计器

Public Sub mnuSheetProptect_click()
	With CellWeb1
		If .IsSheetProtect( .GetCurSheet ) Then '已经被保护了
			a = .SheetUnprotectDlg()
			MsgBox a
			If .SheetUnprotectDlg() = 0 Then
				MsgBox "密码不对，表页解锁失败！", vbExclamation
				Exit Sub
			Else
				MsgBox "恭喜你，表页解锁成功！", vbExclamation
				Exit Sub
			End If
		Else
			.SheetProtectDlg
		End If
	End With
End Sub

'插入表页
Public Sub mnuSheetInsert_click()
	CellWeb1.InsertSheetDlg
End Sub

'删除表页
Public Sub mnuSheetDelete_click()
	CellWeb1.DeleteSheetDlg
End Sub

'追加表页
Public Sub mnuSheetAppend_click()
	CellWeb1.AppendSheetDlg
End Sub

'格式页排序
Public Sub mnuSheetSortStyle_click()
	CellWeb1.SortStyleSheetDlg
End Sub

'数据页排序
Public Sub mnuSheetSortValue_click()
	CellWeb1.SortValueSheetDlg
End Sub

'**************************************************
'		公式菜单
'**************************************************

'输入公式
Public Sub mnuFormulaInput_click
	With CellWeb1
		.FormulaWizard .GetCurrentCol, .GetCurrentRow
	End With	
End Sub

'批量录入公式
Public Sub mnuFormulaBatchInput_click()
	CellWeb1.BatchInputFormulaDlg
End Sub

'填充公式序列
Public Sub mnuFormulaSerial_click()
	CellWeb1.FormulaFillSerial
End Sub

'定义单元格显示公式
Public Sub mnuFormulaCellShow_click()
	CellWeb1.SetCellFormulaShowDlg
End Sub

'定义单元格颜色公式
Public Sub mnuFormulaCellColor_click()
	CellWeb1.SetCellFormulaColorDlg
End Sub

'公式列表
Public Sub mnuFormulaList_click()
	CellWeb1.FormulaListDlg
End Sub

'重算全表
Public Sub mnuFormulaReCalc_click()
	CellWeb1.CalculateAll '重算全表
	MsgBox "计算完毕", vbExclamation
End Sub

'定义自定义函数
Public Sub mnuUserFuncDefine_click()
	Str = """我的函数"" Any XX( String str, [Double num] )"
	Str = Str & vbCrLf & "BEGIN_HELP"
	Str = Str & vbCrLf & "XX( String str, [Double num] )"
	Str = Str & vbCrLf & "本函数演示如何使用缺省参数"
	Str = Str & vbCrLf & "END_HELP"
	MsgBox Str, vbInformation
	CellWeb1.DefineFunctions Str
End Sub

'增加自定义函数
Public Sub mnuUserFuncAdd_click()
    Str = """我的函数"" Any YY( String str, Double num )"
    Str = Str & vbCrLf & "BEGIN_HELP"
    Str = Str & vbCrLf & "YY( String str, Double num )"
    Str = Str & vbCrLf & "本函数演示在实用过程中更改函数定义"
    Str = Str & vbCrLf & "END_HELP"
    Str = Str & vbCrLf & """我的函数"" Any ZZ( String str, Double num )"
    Str = Str & vbCrLf & "BEGIN_HELP"
    Str = Str & vbCrLf & "ZZ( String str, Double num )"
    Str = Str & vbCrLf & "本函数演示函数向导"
    Str = Str & vbCrLf & "END_HELP"
    MsgBox Str, vbInformation
    CellWeb1.DefineFunctions Str
End Sub

'删除自定义函数
Public Sub mnuUserFuncDelete_click()
	    CellWeb1.DelUserFunction "XX"
End Sub

'修改自定义函数
Public Sub mnuUserFuncModify_click()
	Str = """我的函数"" Any YY( String str )"
	Str = Str & vbCrLf & "BEGIN_HELP"
	Str = Str & vbCrLf & "YY( String str )"
	Str = Str & vbCrLf & "现在本函数只有一个参数了"
	Str = Str & vbCrLf & "END_HELP"
	MsgBox Str, vbInformation
	CellWeb1.DefineFunctions Str
End Sub

'**************************************************
'		数据菜单
'**************************************************

'数据转置
Public Sub mnuDataRangeRotate_click()
	CellWeb1.RangeRotateDlg
End Sub

'舍位平衡
Public Sub mnuDataRangeBlance_click()
	CellWeb1.BlanceDlg
End Sub

'区域排序
Public Sub mnuDataRangeSort_click()
	CellWeb1.RangeSortDlg
End Sub

'区域分类汇总
Public Sub mnuDataRangeClassSum_click()
	CellWeb1.RangeClassSumDlg
End Sub

'区域查询
Public Sub mnuDataRangeQuery_click()
	CellWeb1.RangeQueryDlg
End Sub

'简单区域汇总
Public Sub mnuDataRange3DEasySum_click()
	CellWeb1.Range3DEasySumDlg
End Sub

'页间区域汇总
Public Sub mnuDataRange3DSum_click()
	CellWeb1.Range3DSumDlg
End Sub

'页间区域透视
Public Sub mnuDataRange3DView_click()
	CellWeb1.Range3DViewDlg
End Sub

'页间区域查询
Public Sub mnuDataRange3DQuery_click()
	CellWeb1.Range3DQueryDlg
End Sub

'条形码向导
Public Sub mnuDataWzdBarcode_click()
	CellWeb1.WzdBarCodeDlg
End Sub

'图表向导
Public Sub mnuDataWzdChart_click()
	CellWeb1.WzdChartDlg
End Sub

Public Sub menuDefineVarDlg_click()
	CellWeb1.DefineVariableDlg
End Sub


'******************************************************************************************
'****************          工具条中的命令
'******************************************************************************************

'升序排序
Public Sub cmdSortAscending_click()
	CellWeb1.GetSelectRange StartCol, StartRow, EndCol, EndRow
	If StartRow = EndRow And StartCol <> EndCol Then
		CellWeb1.SortRow 1, StartRow, StartCol, StartRow, EndCol, EndRow
	ElseIf StartCol = EndCol And StartRow <> EndRow Then
		CellWeb1.SortCol 1, StartCol, StartCol, StartRow, EndCol, EndRow
	ElseIf StartRow <> EndRow And StartCol <> EndCol Then
		mnuDataRangeSort_click
	End If
End Sub

'降序排序
Public Sub cmdSortDescending_click()
	CellWeb1.GetSelectRange StartCol, StartRow, EndCol, EndRow
	If StartRow = EndRow And StartCol <> EndCol Then
		CellWeb1.SortRow 0, StartRow, StartCol, StartRow, EndCol, EndRow
	ElseIf StartCol = EndCol And StartRow <> EndRow Then
		CellWeb1.SortCol 0, StartCol, StartCol, StartRow, EndCol, EndRow
	ElseIf StartRow <> EndRow And StartCol <> EndCol Then
		mnuDataRangeSort_Click
	End If
End Sub

'水平求和
Public Sub cmdFormulaSumH_click()
	With CellWeb1
		StartCol = 0: StartRow = 0: EndCol = 0: EndRow = 0
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		If StartCol = EndCol Then
			MsgBox "请选择一个矩形区域！", vbExclamation
			Exit Sub
		Else
			For i = StartRow To EndRow
				formula = "sum(" & .CellToLabel(StartCol, i) & ":" & .CellToLabel(EndCol - 1, i) & ")"
				.SetFormula EndCol, i, .GetCurSheet, formula
			Next
		End If
		.Invalidate
	End With
End Sub

'垂直求和
Public Sub cmdFormulaSumV_click()
	With CellWeb1
		StartCol = 0: StartRow = 0: EndCol = 0: EndRow = 0
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		If StartRow = EndRow Then
			MsgBox "请选择一个矩形区域！", vbExclamation
			Exit Sub
		Else
			For i = StartCol To EndCol
				formula = "sum(" & .CellToLabel(i, StartRow) & ":" & .CellToLabel(i, EndRow - 1) & ")"
				.SetFormula i, EndRow, .GetCurSheet, formula
			Next
		End If
		.Invalidate
	End With
End Sub

'双向求和
Public Sub cmdFormulaSumHV_click()
	With CellWeb1	
		StartCol = 0: StartRow = 0: EndCol = 0: EndRow = 0
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		If StartRow = EndRow Or StartCol = EndCol Then
			MsgBox "请选择一个矩形区域！", vbExclamation
			Exit Sub
		Else
			For i = StartRow To EndRow - 1
				formula = "sum(" & .CellToLabel(StartCol, i) & ":" & .CellToLabel(EndCol - 1, i) & ")"
				.SetFormula EndCol, i, .GetCurSheet, formula
			Next
			For i = StartCol To EndCol - 1
				formula = "sum(" & .CellToLabel(i, StartRow) & ":" & .CellToLabel(i, EndRow - 1) & ")"
				.SetFormula i, EndRow, .GetCurSheet, formula
			Next
			formula = "sum(" & .CellToLabel(StartCol, StartRow) & ":" & .CellToLabel(EndCol - 1, EndRow - 1) & ")"
			.SetFormula EndCol, EndRow, .GetCurSheet, formula
		End If
		.Invalidate
	End With
End Sub

'设置粗体
Public Sub cmdBold_click()
	With CellWeb1
	        .GetSelectRange StartCol, StartRow, EndCol, EndRow
	        CurCol = .GetCurrentCol
	        CurRow = .GetCurrentRow
	        CurSheet = .GetCurSheet
	        FontStyle = .GetCellFontStyle(CurCol, CurRow, CurSheet)
	        If (FontStyle And 2) = 2 Then
                    For i = StartCol To EndCol
                        For j = StartRow To EndRow
                            FontStyle = .GetCellFontStyle(i, j, CurSheet)
                            .SetCellFontStyle i, j, CurSheet, (FontStyle AND (8+4))
                        Next
                    Next
                Else
                    For i = StartCol To EndCol
                        For j = StartRow To EndRow
                            FontStyle = .GetCellFontStyle(i, j, CurSheet)
                            .SetCellFontStyle i, j, CurSheet,  FontStyle OR 2
                        Next
                    Next
                End If
                .Invalidate
       	End With
End Sub

'设置斜体
Public Sub cmdItalic_click()
	With CellWeb1
	        .GetSelectRange StartCol, StartRow, EndCol, EndRow
	        CurCol = .GetCurrentCol
	        CurRow = .GetCurrentRow
	        CurSheet = .GetCurSheet
	        FontStyle = .GetCellFontStyle(CurCol, CurRow, CurSheet)
	        If (FontStyle And 4) = 4 Then
                    For i = StartCol To EndCol
                        For j = StartRow To EndRow
                            FontStyle = .GetCellFontStyle(i, j, CurSheet)
                            .SetCellFontStyle i, j, CurSheet, (FontStyle AND (8+2))
                        Next
                    Next
                Else
                    For i = StartCol To EndCol
                        For j = StartRow To EndRow
                            FontStyle = .GetCellFontStyle(i, j, CurSheet)
                            .SetCellFontStyle i, j, CurSheet,  FontStyle OR 4
                        Next
                    Next
                End If
                .Invalidate
       	End With	
End Sub

'设置下划线
Public Sub cmdUnderline_click()
	With CellWeb1
	        .GetSelectRange StartCol, StartRow, EndCol, EndRow
	        CurCol = .GetCurrentCol
	        CurRow = .GetCurrentRow
	        CurSheet = .GetCurSheet
	        FontStyle = .GetCellFontStyle(CurCol, CurRow, CurSheet)
	        If (FontStyle And 8) = 8 Then
                    For i = StartCol To EndCol
                        For j = StartRow To EndRow
                            FontStyle = .GetCellFontStyle(i, j, CurSheet)
                            .SetCellFontStyle i, j, CurSheet, (FontStyle AND (4+2))
                        Next
                    Next
                Else
                    For i = StartCol To EndCol
                        For j = StartRow To EndRow
                            FontStyle = .GetCellFontStyle(i, j, CurSheet)
                            .SetCellFontStyle i, j, CurSheet,  FontStyle OR 8
                        Next
                    Next
                End If
                .Invalidate
       	End With	
End Sub

'设置背景色
Public Sub cmdBackColor_click()
	With CellWeb1
	        On Error Resume Next
	        CommonDialog1.Flags = &H2 or &H8
	        CommonDialog1.ShowColor
	        .GetSelectRange StartCol, StartRow, EndCol, EndRow
	        For i = StartCol To EndCol
	            For j = StartRow To EndRow
	                If .FindColorIndex(CommonDialog1.Color, 1) <> -1 Then
	                    If Err <> 32755 Then
	                        .SetCellBackColor i, j, CurSheet, .FindColorIndex(CommonDialog1.Color, 1)
	                     End If
	                End If
	            Next
	        Next
	        .Invalidate
        End With
End Sub

'设置前景色
Public Sub cmdForeColor_click()
	With CellWeb1
	        On Error Resume Next
	        CommonDialog1.Flags = &H2 or &H8
	        CommonDialog1.ShowColor
	        .GetSelectRange StartCol, StartRow, EndCol, EndRow
	        For i = StartCol To EndCol
	            For j = StartRow To EndRow
	                If .FindColorIndex(CommonDialog1.Color, 1) <> -1 Then
	                    If Err <> 32755 Then
	                        .SetCellTextColor i, j, CurSheet, .FindColorIndex(CommonDialog1.Color, 1)
	                    End If
	                End If
	            Next
	        Next
	        .Invalidate
	End With
End Sub

'自动折行
Public Sub cmdWordWrap_click()
	With CellWeb1
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		CurCol = .GetCurrentCol
	        CurRow = .GetCurrentRow
	        CurSheet = .GetCurSheet
		If .GetCellTextStyle(CurCol, CurRow, CurSheet) = 2 Then'当前单元格为折行状态
		     For i = StartCol To EndCol
                        For j = StartRow To EndRow
                            .SetCellTextStyle i, j, CurSheet, 0
                        Next
                     Next
                Else
                     For i = StartCol To EndCol
                        For j = StartRow To EndRow
                            .SetCellTextStyle i, j, CurSheet, 2
                        Next
                     Next
                End If
                .Invalidate
	End With
End Sub

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

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

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

'居上对齐
Public Sub cmdAlignTop_click()
	With CellWeb1
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		CurCol = .GetCurrentCol
	        CurRow = .GetCurrentRow
	        CurSheet = .GetCurSheet
	        vAlign = .GetCellAlign(CurCol, CurRow, CurSheet)
	        If (HAlign and 8) = 8 Then
	        	vAlign = 0
	        Else
	        	vAlign = 8
		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