function.vbs

报表设计器

' VBScript source code
'**************************************************
'		文件菜单
'**************************************************

'新建
Public Sub mnuFileNew_click()
	If CellWeb1.IsModified() Then '文档已经被更改
		rtn = MsgBox( "文档已被更改，是否保存？", vbExclamation Or vbYesNoCancel)
		If rtn = vbYes Then
			mnuFileSave_click
		ElseIf rtn = vbCancel Then
			Exit Sub
		End If
	End If
	CellWeb1.ResetContent
End Sub

'打开本地文档
Public Sub mnuFileOpen_click()
	CellWeb1.OpenFile "", ""
End Sub

'打开远程文档
Public Sub mnuFileWebOpen_click()
	strFilename = InputBox( "请输入远程服务器上的华表文件名", "打开华表文件", "HTTP://" )
	If strFilename <> "" Then CellWeb1.OpenFile strFilename, ""
End Sub

'保存
Public Sub mnuFileSave_click()
	CellWeb1.SaveFile
End Sub

'表页另存为
Public Sub mnuFileSheetSaveAs_click()
	CellWeb1.SaveSheet CellWeb1.GetCurSheet
End Sub

'读入文本文件
Public Sub mnuFileImportText_click()
	CellWeb1.ImportTextDlg
End Sub

'读入CSV文件
Public Sub mnuFileImportCSV_click()
	On Error Resume Next
	Dim strOpenFileName
	CommonDialog1.Flags = &H4
	CommonDialog1.Filter = "CSV（逗号分隔）文件(*.csv)|*.csv|所有文件 (*.*)|*.*"
	CommonDialog1.FilterIndex = 0
	
	CommonDialog1.Filename = ""
	CommonDialog1.ShowOpen
	If Err <> 32755 Then    ' 用户选择“取消”。
		strOpenFileName = CommonDialog1.Filename
		CellWeb1.ImportCSVFile strOpenFileName, CellWeb1.GetCurSheet()
	End If
End Sub 

'读入Excel文件
Public Sub mnuFileImportExcel_click()
	CellWeb1.ImportExcelDlg
End Sub

'输出文本文件
Public Sub mnuFileExportText_click()
	CellWeb1.ExportTextDlg
End Sub

'输出CSV文件
Public Sub mnuFileExportCSV_click()
	' 如果选择“取消”，则返回空字符串。
	On Error Resume Next
	Dim Filename
	Filename = "新报表.csv"
	CommonDialog1.Flags = &H4 Or &H2 Or &H10 Or &H800
	CommonDialog1.DefaultExt = ".csv"
	CommonDialog1.DialogTitle = "输出CSV文件"
	CommonDialog1.Filter = "CSV（逗号分隔）文件(*.csv)|*.csv|所有文件 (*.*)|*.*"
	CommonDialog1.FilterIndex = 0
	CommonDialog1.Filename = Filename
	CommonDialog1.ShowSave
	If Err <> 32755 Then    ' 用户选择“取消”。
		Filename = CommonDialog1.Filename
	Else
		Filename = ""
	End If
	If Filename <> "" Then
		CellWeb1.ExportCSVFile Filename, CellWeb1.GetCurSheet()
	End If
End Sub

'输出Excel文件
Public Sub mnuFileExportExcel_click()
	CellWeb1.ExportExcelDlg
End Sub

'输出PDF文件
Public Sub mnuFileExportPDF_click()
	' 如果选择“取消”，则返回空字符串。
	On Error Resume Next
	Dim Filename
	Filename = "新报表.pdf"
	CommonDialog1.Flags = &H4 Or &H2 Or &H10 Or &H800
	CommonDialog1.DefaultExt = ".pdf"
	CommonDialog1.DialogTitle = "输出PDF文件"
	CommonDialog1.Filter = "Adobe PDF 文件(*.pdf)|*.pdf|所有文件 (*.*)|*.*"
	CommonDialog1.FilterIndex = 0
	CommonDialog1.Filename = Filename
	CommonDialog1.ShowSave
	If Err <> 32755 Then    ' 用户选择“取消”。
		Filename = CommonDialog1.Filename
	Else
		Filename = ""
	End If
	If Filename <> "" Then
		Dim CurSheet
		Dim Pages
		CurSheet = CellWeb1.GetCurSheet()
		Pages = CellWeb1.PrintGetPages(CurSheet)
		CellWeb1.ExportPdfFile Filename, CurSheet, 0, Pages
	End If
End Sub

'页面设置
Public Sub mnuFilePageSetup_click()
	CellWeb1.PrintPageSetup
End Sub

'打印预览
Public Sub mnuFilePrintPreview_click()
	CellWeb1.PrintPreview True, CellWeb1.GetCurSheet
End Sub

'打印
Public Sub mnuFilePrint_click()
	CellWeb1.PrintSheet True, CellWeb1.GetCurSheet
End Sub

'退出
Public Sub mnuFileExit_click()
	If CellWeb1.IsModified() Then
		rtn = MsgBox( "文档已被更改，是否保存？", vbExclamation or vbYesNoCancel)
		If rtn = vbYes Then
			mnuFileSave_click
		ElseIf rtn = vbCancel Then
			Exit Sub
		End If
	End If
	window.parent.close
End Sub

'**************************************************
'		编辑菜单
'**************************************************
'撤消操作
Public Sub mnuEditUndo_click()
	CellWeb1.Undo
End Sub

'重新操作
Public Sub mnuEditRedo_click()
	CellWeb1.Redo
End Sub

'剪切操作
Public Sub mnuEditCut_click()
 	CellWeb1.GetSelectRange Startcol, Startrow, Endcol, Endrow
    	CellWeb1.CutRange Startcol, Startrow, Endcol, Endrow
End Sub

'复制操作
Public Sub mnuEditCopy_click()
 	CellWeb1.GetSelectRange Startcol, Startrow, Endcol, Endrow
    	CellWeb1.CopyRange Startcol, Startrow, Endcol, Endrow
End Sub

'粘贴操作
Public Sub mnuEditPaste_click()
 	CellWeb1.Paste CellWeb1.GetCurrentCol, CellWeb1.GetCurrentRow, 0, False, False
End Sub

'选择性粘贴
Public Sub mnuEditPasteSpecial_Click()
	CellWeb1.PasteSpecialDlg
End Sub

'查找
Public Sub mnuEditFind_click()
	CellWeb1.FindDialog 0
End Sub

'替换
Public Sub mnuEditReplace_click()
	CellWeb1.FindDialog 1
End Sub

'定位
Public Sub mnuEditGoto_click()
	MsgBox "暂无此功能"
End Sub

'全选
Public Sub mnuEditSelectAll_click()
	With CellWeb1
		If IsSelectAll Then
		    .ClearSelection
		    .Invalidate
		Else
		    .SelectRange 1, 1, .GetCols(.GetCurSheet) - 1, .GetRows(.GetCurSheet) - 1
		    .Invalidate
		End If
	End With	
End Sub

'判断表格是否处于全选状态
Public Function IsSelectAll()
	With CellWeb1
	        .GetSelectRange StartCol, StartRow, EndCol, EndRow
	        If StartCol = 1 And StartRow = 1 And _
	        EndCol = .GetCols(.GetCurSheet) - 1 And EndRow = .GetRows(.GetCurSheet) - 1 Then
	            IsSelectAll = True
	        Else
	            IsSelectAll = False
	        End If
    End With
End Function

'垂直填充
Public Sub mnuEditFillV_click()
	CellWeb1.FillBetweenSheet
End Sub

'插入特殊符号
Public Sub mnuEditInsertSpeChar_click()
	CellWeb1.InsertSpecialCharDlg
End Sub

'超级链接
Public Sub mnuEditHyperlink_click()
	CellWeb1.HyperlinkDlg
End Sub

'**************************************************
'		视图菜单
'**************************************************

'判断表页是否存在不滚动行列
Public Function IsFreezed()
    With CellWeb1
        '设置不滚动行列
        .GetFixedCol StartCol, EndCol
        .GetFixedRow StartRow, EndRow
        '判断是否存在不滚动行或列
        If (EndCol > 0 And StartCol > 0) Or (EndRow > 0 And StartRow > 0) Then
		IsFreezed = True
        Else
       		IsFreezed = False
        End If
    End With
End Function

'设置不滚动行列
Public Sub mnuViewFreezed_click()
	If IsFreezed Then
		CellWeb1.SetFixedCol 0, -1
        	CellWeb1.SetFixedRow 0, -1
        Else
        	CellWeb1.SetFixedCol 1, CellWeb1.GetCurrentCol - 1
        	CellWeb1.SetFixedRow 1, CellWeb1.GetCurrentRow - 1
        End If
End Sub

'页签
Public Sub mnuViewSheetLabel_click()
	With CellWeb1
		If .GetSheetLabelState(.GetCurSheet) Then
			.ShowSheetLabel 0, .GetCurSheet
		Else 
			.ShowSheetLabel 1, .GetCurSheet
		End If
	End With
End Sub

'行标
Public Sub mnuViewRowLabel_click()
	With CellWeb1
		If .GetTopLabelState(.GetCurSheet) Then
			.ShowTopLabel 0, .GetCurSheet
		Else 
			.ShowTopLabel 1, .GetCurSheet
		End If
	End With
End Sub

'列标
Public Sub mnuViewColLabel_click()
	With CellWeb1
		If .GetSideLabelState(.GetCurSheet) Then
			.ShowSideLabel 0, .GetCurSheet
		Else 
			.ShowSideLabel 1, .GetCurSheet
		End If
	End With
End Sub

'水平滚动条
Public Sub mnuViewHScroll_click()
	With CellWeb1
		If .GetHScrollState(.GetCurSheet) Then
			.ShowHScroll 0, .GetCurSheet
		Else 
			.ShowHScroll 1, .GetCurSheet
		End If
	End With
End Sub

'垂直滚动条
Public Sub mnuViewVScroll_click()
	With CellWeb1
		If .GetVScrollState(.GetCurSheet) Then
			.ShowVScroll 0, .GetCurSheet
		Else 
			.ShowVScroll 1, .GetCurSheet
		End If
	End With
End Sub


'**************************************************
'		格式菜单
'**************************************************
'单元格属性
Public Sub mnuFormatCellProperty_click()
	CellWeb1.CellPropertyDlg
End Sub
'画/抹表格线
Public Sub mnuFormatDrawborder_click()
	CellWeb1.DrawLineDlg
End Sub

'插入图片
Public Sub mnuFormatInsertPic_click()
	CellWeb1.SetCellImageDlg
	CellWeb1.Invalidate
End Sub

'删除图片
Public Sub mnuFormatRemovePic_click()
	curSheet = CellWeb1.GetCurSheet
	CellWeb1.GetSelectRange Startcol, Startrow, Endcol, Endrow
	
	For col =  Startcol to Endcol
		For row = Startrow to Endrow
			CellWeb1.RemoveCellImage col, row, curSheet
		Next
	Next
End Sub

'设置单元格组合
Public Sub mnuFormatMergeCell_click()
	CellWeb1.GetSelectRange StartCol, StartRow, EndCol, EndRow
	CellWeb1.MergeCells StartCol, StartRow, EndCol, EndRow
End Sub

'取消单元格组合
Public Sub mnuFormatUnMergeCell_click()
	CellWeb1.GetSelectRange StartCol, StartRow, EndCol, EndRow
	For col = StartCol To EndCol
		For row = StartRow To EndRow
		    CellWeb1.GetMergeRange col, row, StartCol1, StartRow1, EndCol1, EndRow1
		    CellWeb1.UnmergeCells StartCol1, StartRow1, EndCol1, EndRow1
		Next
	Next
End Sub

Public Sub menuAddRowCompage_click()
CellWeb1.GetSelectRange col1,row1,col2,row2
CellWeb1.AddRowCompages row1,row2 
End Sub

Public Sub menuDelRowCompage_click()
CellWeb1.GetSelectRange col1,row1,col2,row2
CellWeb1.DeleteRowCompages row1,row2 
End Sub

Public Sub menuAddColCompage_click()
CellWeb1.GetSelectRange col1,row1,col2,row2
CellWeb1.AddColCompages col1,col2 
End Sub

Public Sub menuDelColCompage_click()
CellWeb1.GetSelectRange col1,row1,col2,row2
CellWeb1.DeleteColCompages col1,col2 
End Sub

Public Sub menuDelAllCompage_click()
CellWeb1.RemoveAllCompages
End Sub       

       
'**************************************************
'		表行列菜单
'**************************************************

'插入表行
Public Sub mnuRowInsert_click()
	CellWeb1.InsertRowDlg
End Sub

'删除表行
Public Sub mnuRowDelete_click()
	CellWeb1.DeleteRowDlg
End Sub

'追加表行
Public Sub mnuRowAppend_click()
	CellWeb1.AppendRowDlg
End Sub

'行高
Public Sub mnuRowHeight_click()
	CellWeb1.RowHeightDlg
End Sub

'隐藏行
Public Sub mnuRowHide_click()
	CellWeb1.GetSelectRange StartCol, StartRow, EndCol, EndRow
	CellWeb1.SetRowHidden StartRow, EndRow
End Sub

'取消隐藏行
Public Sub mnuRowUnhide_click()
	CellWeb1.GetSelectRange StartCol, StartRow, EndCol, EndRow
	CellWeb1.SetRowUnhidden StartRow, EndRow
End Sub

'最合适行高
Public Sub mnuRowBestHeight_click()
	With CellWeb1
		CurSheet = .GetCurSheet
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		For i = StartRow To EndRow
		    BestHeight = .GetRowBestHeight(i)
		    If BestHeight <> 0 Then
		    	.SetRowHeight 1, BestHeight, i, CurSheet
		    End If
		Next
		.Invalidate
	End With
End Sub

'插入表列
Public Sub mnuColInsert_click()
	CellWeb1.InsertColDlg
End Sub

'删除表列
Public Sub mnuColDelete_click()
	CellWeb1.DeleteColDlg
End Sub

'追加表列
Public Sub mnuColAppend_click()
	CellWeb1.AppendColDlg
End Sub

'列宽
Public Sub mnuColWidth_click()
	CellWeb1.ColWidthDlg
End Sub

'隐藏列
Public Sub mnuColHide_click()
	CellWeb1.GetSelectRange StartCol, StartRow, EndCol, EndRow
	CellWeb1.SetColHidden StartCol, EndCol
End Sub

'取消隐藏列
Public Sub mnuColUnhide_click()
	CellWeb1.GetSelectRange StartCol, StartRow, EndCol, EndRow
	CellWeb1.SetColUnhidden StartCol, EndCol
End Sub

'最合适列宽
Public Sub mnuColBestWidth_click()
	With CellWeb1
		CurSheet = .GetCurSheet
		.GetSelectRange StartCol, StartRow, EndCol, EndRow
		For i = StartCol To EndCol
		    BestWidth = .GetColBestWidth(i)
		    If BestWidth <> 0 Then
		        .SetColWidth 1, BestWidth, i, .GetCurSheet
		        .Invalidate
		    End If
		Next
	End With
End Sub

'**************************************************
'		表页菜单
'**************************************************

'页签改名字
Public Sub mnuSheetRename_click()
	CellWeb1.SheetLabelRenameDlg
End Sub

'表页尺寸
Public Sub mnuSheetSize_click()
	CellWeb1.SetSheetSizeDlg
End Sub

'表页保护