微信公众号搜"智元新知"关注
微信扫一扫可直接关注哦！

VB6 中，输出 Excel 功能合集

分类：VB作者：佚名

以下相关功能为以前在 VB中写的一个通用的 Model ，以方便调用Excel功能，并进行输出和格式处理。

Public xlsApp As New excel.Application
Public xlsBook As New excel.Workbook
Public xlsSheet As New excel.Worksheet


'--------------------------------
' 画一Excel 选择范围的边框
'--------------------------------
Public Sub DrawBorder(ByRef Ra As excel.Range,BordersIndex As XlBordersIndex,Optional Linestyle As XlLinestyle = xlContinuous,Optional BorderWeight As XlBorderWeight = xlThin)
With Ra.Borders(BordersIndex)
.Linestyle = Linestyle
If Linestyle = xlNone Then Exit Sub
.Weight = BorderWeight
.ColorIndex = xlAutomatic
End With
End Sub

'--------------------------------
' 为一个范围的格子画线－网格或仅为外框线
'--------------------------------
Public Sub DrawGrid(ByRef Ra As excel.Range,Optional ByVal blnBox As Boolean = False,Optional BorderWeight As XlBorderWeight = xlThin)
' 先初始化
Ra.Borders(xlDiagonalDown).Linestyle = xlNone
Ra.Borders(xlDiagonalUp).Linestyle = xlNone

' 画外框线
DrawBorder Ra,xlEdgetop,Linestyle,BorderWeight
DrawBorder Ra,xlEdgeBottom,xlEdgeLeft,xlEdgeRight,BorderWeight

' 画内部线
If Not blnBox Then
' 如为网格线，则需处理此处理，如仅为Box 外框则无需处理
DrawBorder Ra,xlInsideVertical,xlInsideHorizontal,BorderWeight
End If
End Sub

'--------------------------------
' 对格子的文字格式进行处理,使其中的文字可进行换行
'--------------------------------
Public Sub WrapText(ByRef Ra As excel.Range)
Ra.Select
With xlsApp.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.Addindent = False
.ShrinkToFit = False
.MergeCells = False
End With
End Sub

'--------------------------------
' 对格子的文字格式进行处理,使其中的文字可进行换行
'--------------------------------
Public Sub FormatCells(ByRef Ra As excel.Range,Optional HAlign As excel.Constants = xlCenter,_
Optional VAlign As excel.Constants = xlCenter,Optional bWrapText As Boolean = False,_
Optional norient As Long = 0,Optional bMerge As Boolean = False)
Ra.Select
With xlsApp.Selection
.HorizontalAlignment = HAlign
.VerticalAlignment = VAlign
.WrapText = bWrapText
.Orientation = norient
.Addindent = False
.ShrinkToFit = False
.MergeCells = bMerge
End With
End Sub

'--------------------------------
' 对一个格加入注释
'--------------------------------
Public Sub AddComment(ByRef objRange As excel.Range,ByVal sText As String,Optional ByVal bVisible As Boolean = False)
With objRange
.Select
.AddComment
.Comment.Visible = bVisible
.Comment.Text Text:="" & Chr(10) & sText & Chr(10) & ""
End With
End Sub

'--------------------------------
' 以一个格为基础，将其算式同样用于其它格
'--------------------------------
Public Sub AutoFill(ByRef objSouRange As excel.Range,ByRef objDesRagne As excel.Range,ByVal sFormulaR1C1 As String,ByVal nFillType As excel.XlAutoFillType)
With objSouRange
'ActiveCell.FormulaR1C1 = sFormulaR1C1
.Value = sFormulaR1C1
.Select
End With
xlsApp.Selection.AutoFill Destination:=objDesRagne,Type:=nFillType
End Sub


'--------------------------------
' 将Rst 中的资料直接输出至Excel文件中
'--------------------------------
Public Function RsToExcel(ByRef oRs As ADODB.Recordset,ByRef oXls As excel.Application,Optional ByVal lRow As Long = 1,Optional ByVal lCol As Long = 1,Optional ByVal bListCaption As Boolean = True) As Long

If oRs Is nothing Then Exit Function
If oRs.State = adStateClosed Then Exit Function

If bListCaption Then
Dim i As Long
For i = lCol To oRs.Fields.Count + lCol - 1
oXls.Cells(lRow,i) = "'" & oRs(i - 1).Name
Next i
Else
lRow = lRow - 1
End If

If oRs.EOF Then
Exit Function
End If

On Error GoTo RsToExcel_Error

oXls.Range(getExcelCol(lCol,False) & lRow + 1).copyFromrecordset oRs

Exit Function

RsToExcel_Error:

End Function

'---------------------------------
'取得对应栏的下标名称，用到此
' pBaSEOnChar - 是否基于字母的基础，不是则表示直接基于坐标数字值
'---------------------------------
Public Function getExcelCol(ByVal plCol As Long,Optional pBaSEOnChar As Boolean = True) As String
Dim nCol As Long

If pBaSEOnChar Then
nCol = plCol Mod 64
Else
nCol = plCol
End If

If nCol < 27 Then
getExcelCol = Chr(nCol + 64)
Else
'getExcelCol = Chr(nCol / 26 + 64) & Chr(nCol Mod 26 + 64)
getExcelCol = Chr((nCol - 1) / 26 + 64) & Chr(IIf(nCol Mod 26 = 0,26,nCol Mod 26) + 64)
End If

End Function

'--------------------------------
' 产生标准的报表表头
' add C/E Convertion function (Parameter : bUseChinese)
'--------------------------------
Public Sub ExportRptHeader(Sheet As excel.Worksheet,ByVal nRow As Long,ByVal sCol_Left As String,_
sCol_Right As String,ByVal sRptID As String,ByVal sUserID As String,_
ByVal sCompanyName As String,ByVal sSystemName As String,ByVal sReportName As String,_
Optional ByVal sCaptionFontSize As Integer = 14,Optional ByVal bUseChinese As Boolean = True)
On Error GoTo errRptHeader
' ABC,分别代表左边的指定开始列的前三列
' XYZ,分别代表右边的指定列的连续三列，指定列为Y
Dim sColA As String
Dim sColB As String
Dim sColC As String
Dim sColX As String
Dim sColY As String
Dim sColZ As String

sColA = sCol_Left
sColB = Chr(Asc(sColA) + 1)
sColC = Chr(Asc(sColA) + 2)

sColY = sCol_Right
sColX = Chr(Asc(sColY) - 1)
sColZ = Chr(Asc(sColY) + 1)

With Sheet
.Range(sColA & nRow).Value = IIf(bUseChinese,"报表ID ：","Report ID :")
.Range(sColA & nRow + 1).Value = IIf(bUseChinese,"用户ID ：","User ID :")
' value
.Range(sColB & nRow).Value = sRptID
.Range(sColB & nRow + 1).Value = sUserID

.Range(sColY & nRow).Value = IIf(bUseChinese,"日期 ：","Date :")
.Range(sColY & nRow + 1).Value = IIf(bUseChinese,"时间 ：","Time :")
' value
.Range(sColZ & nRow).Value = Format(Date,"dd Mmm yyyy")
.Range(sColZ & nRow).NumberFormat = "dd Mmm yyyy"
.Range(sColZ & nRow + 1).Value = Format(Time,"HH:MM")

' Factory Name / System / Report Name
.Range(sColC & nRow).Value = UCase(Trim(sCompanyName))
.Range(sColC & nRow + 1).Value = UCase(Trim(sSystemName))
.Range(sColC & nRow + 2).Value = UCase(Trim(sReportName))
'Merge Cells
.Range(sColC & nRow & ":" & sColX & nRow).MergeCells = True
.Range(sColC & nRow & ":" & sColX & nRow).HorizontalAlignment = xlCenter
.Range(sColC & nRow + 1 & ":" & sColX & nRow + 1).MergeCells = True
.Range(sColC & nRow + 1 & ":" & sColX & nRow + 1).HorizontalAlignment = xlCenter
.Range(sColC & nRow + 2 & ":" & sColX & nRow + 2).MergeCells = True
.Range(sColC & nRow + 2 & ":" & sColX & nRow + 2).HorizontalAlignment = xlCenter
'Font
.Range(sColC & nRow & ":" & sColX & nRow + 2).Font.Size = 14
.Range(sColC & nRow & ":" & sColX & nRow + 2).Font.Bold = True
End With

errRptHeader:
If Err.Number <> 0 Then
MsgBox Err.Description,vbOKOnly + vbExclamation,"Prompt ( ExportRptHeader ):"
End If
End Sub


'-----------------------------------------------------------------------------------------
' 取得一个临时文件名，包括完整的路径名及名件名
'-----------------------------------------------------------------------------------------
Public Function getTempFileFullName(Optional ByVal psExtName As String = "") As String
getTempFileFullName = ""

Dim fso,tempfile
Set fso = CreateObject("Scripting.FileSystemObject")

Dim tfolder,tname
Const TemporaryFolder = 2
Set tfolder = fso.GetSpecialFolder(TemporaryFolder)
tname = fso.GetTempName

getTempFileFullName = sfTrim(tfolder & "/" & tname) & psExtName Set fso = nothingEnd Function

版权声明：本文内容由互联网用户自发贡献，该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容， 请发送邮件至 dio@foxmail.com 举报，一经查实，本站将立刻删除。

相关推荐

VB Format函数
Format[$] ( expr [ , fmt ] ) format 返回变体型 format$ 强制返回为文本 -------------------------------- 数字类型的格式化 --------------------------------     固定格式参数：     General Number 普通数字，如可以用来去掉千位分隔号     format$("100,1
vb6/ASP FORMAT MM/DD/YYYY
VB6或者ASP 格式化时间为 MM/dd/yyyy 格式，竟然没有好的办法， Format 或者FormatDateTime 竟然结果和系统设置的区域语言的日期和时间格式相关。意思是尽管你用诸如 Format(Now, "MM/dd/yyyy")，如果系统的设置格式区域语言的日期和时间格式分隔符是"-",那他还会显示为 MM-dd-yyyy     只有拼凑： <%response.write
VB.net 捕获项目全局异常
在项目中添加如下代码：新建窗口来显示异常信息。 Namespace My ‘全局错误处理，新的解决方案直接添加本ApplicationEvents.vb 到工程即可 ‘添加后还需要一个From用来显示错误。如果到这步还不会则需要先打好基础啦 ‘======================================================== ‘以下事件
实现用VB.Net/(C#)开发K/3 BOS 插件的真正可行方法
转了这一篇文章，原来一直想用C#做k3的插件开发，vb没有C#用的爽呀，这篇文章写与2011年，看来我以前没有认真去找这个方法呀。 https://blog.csdn.net/chzjxgd/article/details/6176325 金蝶K3 BOS的插件官方是用VB6编写的，如果  能用.Net下的语言工具开发BOS插件是一件很愉快的事情，其中缘由不言而喻，而本文则是个人首创，实现在了用V
vb，wps，excel 分裂
Sub 分列() ‘以空格为分隔符，连续空格只算1个。对所选中的单元格进行处理 Dim m As Range, tmpStr As String, s As String Dim x As Integer, y As Integer, subStr As String If MsgBox("确定要分列处理吗？请确定分列的数据会覆盖它后面的单元格！", _
VB文件 hash 查看器
  窗体代码 1 Private Sub Text1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) 2 Dim path As String, hash As String 3 For Each fil
VB.NET MYSQL DataGridView 增删改查INSERT,SELECT,UPDATE,DELETE
  Imports MySql.Data.MySqlClient Public Class Form1 ‘ GLOBAL DECLARATIONS Dim conString As String = "Server=localhost;Database=net2;Uid=root;Pwd=123456;" Dim con As New MySqlConnection
VB.NET 使用ADODB連接資料庫滙出到EXCEL
‘導入命名空間 Imports ADODB Imports Microsoft.Office.Interop   Private Sub A1() Dim Sql As String Dim Cnn As New ADODB.Connection Dim Rs As New ADODB.Recordset Dim S As String   S = "Provider=OraOLEDB.Oracl
vb.net 多线程運用 ping
Imports System.IO Imports System.Threading Imports System.Diagnostics Public Class Form1 Dim A(254) As String    Function ping(ByVal IP As Integer) As String Dim IPAddress As String IPAddress = "10.0.
VB等待进程结束
VB运行EXE程序，并等待其运行结束 参考：https://blog.csdn.net/useway/article/details/5494084 Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Pr
苹果市值2025年有望达4万亿美元
pythonJavaScriptjavaHTMLPHPreactjsC#AndroidCSSNode.jssqlrpython-3.xMysqLjQueryc++pandasFlutterangularIOSdjangolinuxswifttypescript路由器JSON路由器设置无线路由器h3c华三华三路由器设置华三路由器电脑软件教程arraysdocker软件图文教程Cvue.jslaravelspring-boot