In VB6, the EXCEL function is output.

The following functions are a general model previously written in VB to facilitate the use of the Excel function and process the output and format.

 

 

 

Public xlsapp as new excel. Application
Public xlsbook as new excel. Workbook
Public xlssheet as new excel. Worksheet

 

'--------------------------------
'Draw a border of the Excel Selection Range
'--------------------------------
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
End sub

 

'--------------------------------
'The grid draws a line in a range-the grid or only the outer frame line
'--------------------------------
Public sub drawgrid (byref RA as Excel. Range, optional byval blnbox as Boolean = false, optional linestyle as xllinestyle = xlcontinuous, optional borderweight as xlborderweight = xlthin)
'Initialize first
RA. Borders (xldiagonaldown). linestyle = xlnone
RA. Borders (xldiagonalup). linestyle = xlnone

'Draw borders
Drawborder Ra, xledgetop, linestyle, borderweight
Drawborder Ra, xledgebottom, linestyle, borderweight
Drawborder Ra, xledgeleft, linestyle, borderweight
Drawborder Ra, xledgeright, linestyle, borderweight

'Draw internal lines
If not blnbox then
'If it is a gridline, you need to handle this operation. If it is only a box, you do not need to handle it.
Drawborder Ra, xlinsidevertical, linestyle, borderweight
Drawborder Ra, xlinsidehorizontal, linestyle, borderweight
End if
End sub

'--------------------------------
'Process the text format of the lattice so that the text can be wrapped
'--------------------------------
Public sub wraptext (byref RA as Excel. Range)
RA. Select
With xlsapp. Selection
. Horizontalalignment = xlcenter
. Verticalignment = xlbottom
. Wraptext = true
. Orientation = 0
. Addindent = false
. Shrinktofit = false
. Mergecells = false
End
End sub

'--------------------------------
'Process the text format of the lattice so that the text can be wrapped
'--------------------------------
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
End sub

'--------------------------------
'Add comments to a cell
'--------------------------------
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
End sub

'--------------------------------
'Based on one lattice, the formula is also used for other cells
'--------------------------------
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
Xlsapp. selection. AutoFill destination: = objdesragne, type: = nfilltype
End sub

'--------------------------------
'Directly output the documents in the RST to an Excel file.
'--------------------------------
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

'---------------------------------
'Obtain the subscript name of the corresponding column.
'Pbaseonchar-whether it is based on letters. If it is not, it indicates that it is directly based on coordinate numeric values.
'---------------------------------
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

'--------------------------------
'Generate a standard report Header
'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' indicates the first three columns of the specified start column on the left.
'Xyz, which represents three consecutive columns of the specified column on the right, respectively.
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, "Report ID:", "Report ID :")
. Range (Scola & nrow + 1). value = IIF (busechinese, "User ID:", "User ID :")
'Value
. Range (scolb & nrow). value = srptid
. Range (scolb & nrow + 1). value = suserid

. Range (scoly & nrow). value = IIF (busechinese, "date:", "date :")
. Range (scoly & nrow + 1). value = IIF (busechinese, "Time:", "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

Errrptheader:
If err. Number <> 0 then
Msgbox err. Description, vbokonly + vbexclamation, "prompt (exportrptheader ):"
End if
End sub

 

'Timeout '-----------------------------------------------------------------------------------------
'Get a temporary file name, including the complete path name and name of the file
'Timeout '-----------------------------------------------------------------------------------------
Public Function gettempfilefullname (optional byval extends xtname 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 = nothing
End Function