by Cyrus Lacaba aka Biohazard of Las Pi?as (6 Submissions)
Category: Miscellaneous
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Fri 17th July 2009
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Microsoft Excel Object Automation
API Declarations
Option Explicit
'Status: Modified May 5, 2009
Public excApp As Object
Public excWb As Object
Public excWs As Object
Public strActiveSheet$
VBcoders
'Added by Cyrus May 5, 2009
Public Function GetActiveSheet() As String
GetActiveSheet = strActiveSheet$
End Function
Public Function SetActiveSheet(strShtName$) As String
On Error GoTo ErrorHandler
Set excWs = excWb.Worksheets(strShtName$)
strActiveSheet$ = strShtName$
Exit Function
ErrorHandler:
Err.Clear
End Function
'Modified By Cyrus May 5, 2009
Public Sub PrintExcelFile(sFile As String, Optional blnVer As Boolean = False)
On Error GoTo ErHandler
'Call SetActiveSheet("Sheet1")
Call OpenExcelFile(sFile, GetActiveSheet(), blnVer)
If blnVer = True Then GoTo EndCall
excApp.Visible = True
excWb.PrintOut
CloseExcelFile
EndCall:
Exit Sub
ErHandler:
CloseExcelFile
MsgBox "Cannot print. " & Err.Description, vbOKOnly + vbCritical
End Sub
'By Cyrus May 5, 2009
Public Sub PrintPreviewExcelFile(sFile As String, Optional blnVer As Boolean = False)
On Error GoTo ErHandler
'Call SetActiveSheet("Sheet1")
Call OpenExcelFile(sFile, GetActiveSheet(), blnVer)
If blnVer = True Then GoTo EndCall
excApp.Visible = True
'excWb.PrintPreview
'CloseExcelFile
EndCall:
Exit Sub
ErHandler:
CloseExcelFile
MsgBox "Cannot preview. " & Err.Description, vbOKOnly + vbCritical
End Sub
'Modified By May 5, 2009
Function OpenExcelFile(strFile As String, Optional blnVer As Boolean = False)
If blnVer = True Then
If VerifyXLSFileExist(strFile) = False Then Exit Function
End If
Set excApp = CreateObject("excel.application")
Set excWb = excApp.Workbooks.Open(strFile)
Set excWs = excWb.Worksheets(GetActiveSheet)
End Function
'Modified By Cyrus May 5, 2009
Function SaveExcelFile(Optional ByVal strFile As String, Optional ByVal bSaveAs As Boolean = True, Optional blnVer As Boolean = False)
On Error Resume Next
If blnVer = True Then
If VerifyXLSFileExist(strFile) = False Then Exit Function
End If
If bSaveAs Then
excWb.SaveAs strFile
Else
excWb.Save
End If
CloseExcelFile False
End Function
Function CloseExcelFile(Optional ByVal nType As Boolean = True)
On Error Resume Next
excWs.Close
Set excWs = Nothing
excWb.Close 'nType
Set excWb = Nothing
excApp.Quit
Set excApp = Nothing
End Function
Function SetExcelValue(strRange As String, strVal As Variant)
On Error Resume Next
excWs.Range(strRange).Value = strVal
End Function
Function GetExcelValue(strRange As String) As Variant
On Error Resume Next
GetExcelValue = excWs.Range(strRange).Value
End Function
'By Cyrus May 5, 2009
Public Sub HighlightRow(ByVal sStartCell As String, ByVal sEndCell As String, ByVal sColor As Long)
excWs.Range(sStartCell & ":" & sEndCell).select
excApp.Selection.Interior.ColorIndex = sColor
End Sub
'By Cyrus 04/29/2009
Public Sub SelectRange(ByVal sStartCell As String, ByVal sEndCell As String)
excWs.Range(sStartCell & ":" & sEndCell).select
End Sub
'By Cyrus 04/29/2009
Public Sub SelectCol(ByVal sStartCell As String, ByVal sEndCell As String)
excWs.Columns(sStartCell & ":" & sEndCell).select
End Sub
'By Cyrus 04/29/2009
Public Sub SelectRow(ByVal sCol As String)
excWs.Range(sCol & Trim(Str(excApp.ActiveCell.row))).select
End Sub
'By Cyrus 04/29/2009
Public Sub InsertRow(nRowNum As Integer)
excApp.Rows(CStr(nRowNum) & ":" & CStr(nRowNum)).select
excApp.Selection.Insert Shift:=xlDown
End Sub
'By Cyrus 04/29/2009
Public Sub DeleteRow(RowNum As Integer)
excApp.Rows(CStr(RowNum) & ":" & CStr(RowNum)).select
excApp.Selection.Delete Shift:=xlUp
End Sub
'By Cyrus 04/29/2009
Public Sub FormatSelection(ByVal sWrap As Boolean, ByVal sMerge As Boolean)
With excApp.Selection
.HorizontalAlignment = &HFFFFEFF4
.VerticalAlignment = &HFFFFEFF4 '&HFFFFEFC0
.WrapText = sWrap
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = sMerge
End With
Exit Sub
End Sub
'Insert Image
Public Sub InsertImage(ByVal strFilename As String, ByVal lngWidth As Long, ByVal lngHeight As Long, ByVal lngLeft As Long, ByVal lngTop As Long)
On Error Resume Next
Dim p As Object
Set p = excWs.pictures.Insert(strFilename)
p.Width = lngWidth
p.Height = lngHeight
p.Top = lngTop
p.Left = lngLeft
Exit Sub
End Sub
'Ole Object
Public Sub AddExcelObject(ByVal strFilename As String, ByVal lngLeft As Long, ByVal lngTop As Long, ByVal lngWidth As Long, ByVal lngHeight As Long)
On Error GoTo ErrorHandler
excWs.OLEObjects.Add FileName:=strFilename, _
Left:=lngLeft, _
Top:=lngTop, _
Width:=lngWidth, _
Height:=lngHeight
Exit Sub
ErrorHandler:
Err.Clear
End Sub