• Home
 · 
• Miscellaneous
 · 
• Microsoft Excel Object Automation

Microsoft Excel Object Automation

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$




Rate Microsoft Excel Object Automation

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

'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