Register DLL and Reg file with Excel VBA

Here is a function to register DLL or OCX components

 
Public Sub RegisterComponent(sFilename As String, Optional bUnRegister As Boolean = False, Optional bHideResults As Boolean = True)
    If Len(Dir$(sFilename)) = 0 Then
        'File is missing
        MsgBox "Unable to locate file "" & sFileName & """, vbCritical
    Else
        If bUnRegister Then
            'Unregister a component
            If bHideResults Then
                'Hide results
                Shell "regsvr32 /s /u " & """" & sFilename & """"
            Else
                'Show results
                Shell "regsvr32 /u " & """" & sFilename & """"
            End If
        Else
            'Register a component
            If bHideResults Then
                'Hide results
                Shell "regsvr32 /s " & """" & sFilename & """"
            Else
                'Show results
                Shell "regsvr32 " & """" & sFilename & """"
            End If
        End If
    End If
End Sub

For example :

 
Sub test()
    RegisterComponent ("c:\test.dll")
End Sub

Here is a function to export a section of registry to .reg file

Public Sub RegeditExport(sKey As String, sFilename As String)
    Shell "regedit.exe /s /e " & Chr(34) & sFilename & Chr(34) & " " & Chr(34) & sKey & Chr(34), vbHide
End Sub

Here is a function to import windows registry file (.reg file) to the registry

 
Public Sub RegeditImport(sFilename As String)
    Shell "regedit.exe /s /c " & Chr(34) & sFilename & Chr(34), vbHide
End Sub

For example:

 
Sub test()
    RegeditImport "C:\test.reg"
End Sub

Get or set computer name function

Here is a function to get or set the computer name

 
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpbuffer As String, nsize As Long) As Long
Private Declare Function SetComputerName Lib "kernel32" Alias "SetComputerNameA" (ByVal lpComputerName As String) As Long

'Purpose     :  Returns the name of the local machine/computer
'Inputs      :  N/A
'Outputs     :  Returns the name of the local machine
'Notes       :  Uses a private static for speed


Public Function MachineName() As String
    Dim lRet As Long
    Dim lMaxLen As Long
    Static ssMachineName As String
    
    If Len(ssMachineName) = 0 Then
        lMaxLen = 100
        ssMachineName = String$(lMaxLen, vbNullChar)
        lRet = GetComputerName(ssMachineName, lMaxLen)
        ssMachineName = Left$(ssMachineName, lMaxLen)
    End If
    MachineName = ssMachineName
End Function

'Purpose     :  Sets the name of the local machine/computer
'Inputs      :  sName           The new name of the local machine/computer
'Outputs     :  Returns True if failed to change local machine name


Function MachineNameSet(sName As String) As Boolean
    MachineNameSet = IIf(SetComputerName(sName & vbNullChar) = 0, False, True)
End Function

Credit : http://www.visualbasic.happycodings.com/Applications-VBA/code23.html

Read ini value

Function for read a value of each key from ini file.

 
Public Function ReadIniValue(ByVal INIpath As String, ByVal KEY As String, ByVal Variable As String) As String  
 Dim NF As Integer  
 Dim temp As String  
 Dim LcaseTemp As String  
 Dim ReadyToRead As Boolean  
 AssignVariables:  
     NF = FreeFile  
     ReadIniValue = ""  
     KEY = "[" & LCase$(KEY) & "]"  
     Variable = LCase$(Variable)  
 EnsureFileExists:  
   If Dir(INIpath) = "" Then  
    MsgBox " No file you are tring to read ", vbOKOnly, "Error"  
    Exit Function  
   End If  
   'Open INIpath For Binary As NF  
   ' Close NF  
   'SetAttr INIpath, vbArchive  
 LoadFile:  
   Open INIpath For Input As NF  
   While Not EOF(NF)  
      Line Input #NF, temp  
      LcaseTemp = LCase$(Trim(temp))  
      If InStr(LcaseTemp, "[") <> 0 Then ReadyToRead = False  
      If LcaseTemp = KEY Then ReadyToRead = True  
      If InStr(LcaseTemp, "[") = 0 And ReadyToRead = True Then  
       If InStr(LcaseTemp, Variable & "=") = 1 Then  
         ReadIniValue = Mid$(temp, 1 + Len(Variable & "="))  
         Close NF: Exit Function  
         End If  
      End If  
   Wend  
   Close NF  
 End Function  

Split function

Split function is used for separating any string to substring by using a specified delimiter.

Syntax
Split(expression[, delimiter[, limit[, compare]]])
For example:
Public Function SplitText(str, n, delim)
'Returns the nth element from a string,
'using a specified separator character
Dim x As Variant    x = Split(str, delim)
    If n > 0 And n - 1 <= UBound(x) Then
       SplitText= x(n - 1)
    Else       SplitText= ""
    End If
End Function

Example: Range("A1") = test1,test2,test3

Sub test()
Dim result1 As String
Dim result2 As String
Dim result3 As String   
   result1 = SplitText(Range("A1").Value, 1, ",") 'result = test1
   result2 = SplitText(Range("A1").Value, 2, ",") 'result = test2
   result3 = SplitText(Range("A1").Value, 3, ",") 'result = test3
End Sub

Open another program with Excel VBA

To open another program by using Excel VBA, we can use function "shell" to open it.

Syntax
Shell(pathname[,windowstyle])

pathname
Required; Variant (String). Name of the program to execute and any required arguments or command-line switches; may include directory or folder and drive.

The windowstyle named argument has these values:

Constant	Value	Description
vbHide	0	Window is hidden and focus is passed to the hidden window. The vbHide constant is not applicable on Macintosh platforms.
vbNormalFocus	1	Window has focus and is restored to its original size and position.
vbMinimizedFocus	2	Window is displayed as an icon with focus.
vbMaximizedFocus	3	Window is maximized with focus.
vbNormalNoFocus	4	Window is restored to its most recent size and position. The currently active window remains active.
vbMinimizedNoFocus	6	Window is displayed as an icon. The currently active window remains active.

Here is an example to open Internet Explorer:

-----------------------------------------------------------------------------------------------------------------------

Sub test()

'To search "test" with google

Dim ReturnValue As Double

   ReturnValue = Shell("C:\Program Files\Internet Explorer\iexplore.exe http://www.google.com", 1)
   Application.Wait (Now + TimeValue("0:00:01")) 'wait 1 seconds

   AppActivate ReturnValue

   Application.SendKeys "test" 'search "test" with google

   SendKeys "~", True 'enter

End Sub

-----------------------------------------------------------------------------------------------------------------------

Convert dd:hh:mm:ss to hour or second

Public Function ConvertToHR(str As String) As String

'dd:hh:mm:ss
Dim d, h As Integer
Dim tmp, m, s As String

If str = "" Then
   ConvertToHR = "no data"
   Exit Function
End If
d = CInt(Mid(str, 1, 2))
h = CInt(Mid(str, 4, 2))
m = Mid(str, 7, 2)
s = Mid(str, 10, 2)
'tmp = CStr((d * 24) + h) & "." & m & "." & s
tmp = CStr((d * 24) + h)
ConvertToHR = tmp

End Function




Public Function ConvertToSec(str As String) As String
'dd:hh:mm:ss
Dim d, h As Long
Dim tmp, m, s As String

If str = "" Then
   ConvertToSec = "no data"
   Exit Function
End If
d = CInt(Mid(str, 1, 2))
h = CInt(Mid(str, 4, 2))
m = Mid(str, 7, 2)
s = Mid(str, 10, 2)
'tmp = CStr((d * 24) + h) & "." & m & "." & s
tmp = CStr((((d * 24) + h) * 60 + m) * 60 + s)
ConvertToSec = tmp

End Function

Check existing value in array

Function InSArray(ByRef vArray() As String, ByVal vValue As String) As Boolean

'***Return true, if found this value in array***'
'***Return false, if not found this value in array***'

Dim i As Long


For i = LBound(vArray) To UBound(vArray)
   If vArray(i) = vValue Then
      InSArray = True
      Exit Function
   End If
Next i

InSArray = False

End Function

Get user name function

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
---------------------------------------------------------

Public Function CurrentUser() As String
'*********************************************************
'* Function to get the current logged on user in windows *
'*********************************************************


Dim strBuff As String * 255
Dim X As Long

CurrentUser = ""
X = GetUserName(strBuff, Len(strBuff) - 1)
If X > 0 Then
   'Look for Null Character, usually included
   X = InStr(strBuff, vbNullChar)
   'Trim off buffered spaces too
   If X > 0 Then
      CurrentUser = UCase(Left$(strBuff, X - 1)) 'UCase is optional
   Else
      CurrentUser = UCase(Left$(strBuff, X))
   End If
End If


End Function

GetFileSize function

Function GetFileSize(folderspec As String) As Variant

'   Returns an array of file size that match FileSpec

    Dim fs, f, f1, fc, s

    Dim FileArray() As Variant

    Dim FileCount As Integer

    Dim filesize As String

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set f = fs.GetFolder(folderspec)

    Set fc = f.Files

    FileCount = 0

    For Each f1 In fc

        s = f1.Size

        filesize = s

        FileCount = FileCount + 1

        ReDim Preserve FileArray(1 To FileCount)

        FileArray(FileCount) = filesize

        GetFileSize = FileArray

    Next

End Function

GetFileList function

Function GetFileList(filespec As String) As Variant
'***Function to get list of files in specific folder***'
' Returns an array of file names that match FileSpec

' If no matching files are found, it returns False

Dim FileArray() As Variant

Dim FileCount As Integer

Dim FileName As String

On Error GoTo NoFilesFound

FileCount = 0

FileName = Dir(filespec)

If FileName = "" Then GoTo NoFilesFound

' Loop until no more matching files are found

Do While FileName <> ""

   FileCount = FileCount + 1

   ReDim Preserve FileArray(1 To FileCount)

   FileArray(FileCount) = FileName

   FileName = Dir()

Loop

GetFileList = FileArray

Exit Function

' Error handler

NoFilesFound:

GetFileList = False

End Function