Get IP Address using VBA

Private Declare Function GetIpAddrTable_API Lib "IpHlpApi" Alias "GetIpAddrTable" (pIPAddrTable As Any, pdwSize As Long, ByVal bOrder As Long) As Long
' Returns an array with the local IP addresses (as strings).
Public Function GetIpAddrTable()
   Dim Buf(0 To 511) As Byte
   Dim BufSize As Long: BufSize = UBound(Buf) + 1
   Dim rc As Long
   rc = GetIpAddrTable_API(Buf(0), BufSize, 1)
   If rc <> 0 Then Err.Raise vbObjectError, , "GetIpAddrTable failed with return value " & rc
   Dim NrOfEntries As Integer: NrOfEntries = Buf(1) * 256 + Buf(0)
   If NrOfEntries = 0 Then GetIpAddrTable = Array(): Exit Function
   ReDim IpAddrs(0 To NrOfEntries - 1) As String
   Dim i As Integer
   For i = 0 To NrOfEntries - 1
      Dim j As Integer, s As String: s = ""
      For j = 0 To 3: s = s & IIf(j > 0, ".", "") & Buf(4 + i * 24 + j): Next
      IpAddrs(i) = s
      Next
   GetIpAddrTable = IpAddrs
   End Function

' Test program for GetIpAddrTable.
Public Sub Test()
   Dim IpAddrs
   IpAddrs = GetIpAddrTable
   Debug.Print "Nr of IP addresses: " & UBound(IpAddrs) - LBound(IpAddrs) + 1
   Dim i As Integer
   For i = LBound(IpAddrs) To UBound(IpAddrs)
      Debug.Print IpAddrs(i)
      Next
   End Sub

Custom number format

Without decimal : [>=100000]0,," M";[>=100]0," K";0," K"
With 1 decimal : [>=100000]0.0,," M";[>=100]0.0," K";0.0," K"

Example :

	without decimal	with 1 decimal
960000	1 M	1.0 M
1000	1 K	1.0 K
52000	52 K	52.0 K
8390000	8 M	8.4 M
949	0.9 K	0.9 K
951	1 K	1.0 K
9999	10 K	10.0 K
52000	52 K	52.0 K
600000	600 K	0.6 M
949000	949 K	0.9 M

Visual Basic For Applications - Microsoft Excel Specific

What is this VBA stuff, anyway?

• A real programming language with a few, usually forgettable, distinctions from standalone Visual Basic.
• And one important one: The program is embedded 'under' the spreadsheet and can not be run outside of Excel
• A way to write windows code without having to think about "APIs" and "Threads" and such
• Unfortunately, not fully standardized across Word, Excel, PowerPoint and Access. But the basics are the same.
• A way to use Excel as a formatting and layout tool so that coding effort is expended on getting getting the job done, not building the graphical user interface.

Do's and Dont's
Do's

• Do use the WITH statement (execution speed)
• Do use Option Explict
• Do use array and where appropriate custom strucutre typs
• Do learn and use Application Funcitons.

Dont's

• Do Not use the cells as variables (really slow)
• Do Not get caught with signed/unsigned variable issues.
• Do Not fail to make a clean user interface your first priority
• Do Not write routines other people have done before!

Convert numbers to Words using VBA

'This sub is used to create words from numbers

Function WordNum(MyNumber As Double) As String
Dim DecimalPosition As Integer, ValNo As Variant, StrNo As String
Dim NumStr As String, n As Integer, Temp1 As String, Temp2 As String
If Abs(MyNumber) > 999999999 Then
WordNum = "Value too large"
Exit Function
End If
SetNums
' String representation of amount (excl decimals)
NumStr = Right("000000000" & Trim(str(Int(Abs(MyNumber)))), 9)
ValNo = Array(0, Val(Mid(NumStr, 1, 3)), Val(Mid(NumStr, 4, 3)), Val(Mid(NumStr, 7, 3)))
For n = 3 To 1 Step -1 'analyse the absolute number as 3 sets of 3 digits
StrNo = Format(ValNo(n), "000")
If ValNo(n) > 0 Then
Temp1 = GetTens(Val(Right(StrNo, 2)))
If Left(StrNo, 1) <> "0" Then
Temp2 = Numbers(Val(Left(StrNo, 1))) & " hundred"
If Temp1 <> "" Then Temp2 = Temp2 & " and "
Else
Temp2 = ""
End If
If n = 3 Then
If Temp2 = "" And ValNo(1) + ValNo(2) > 0 Then Temp2 = "and "
WordNum = Trim(Temp2 & Temp1)
End If
If n = 2 Then WordNum = Trim(Temp2 & Temp1 & " thousand " & WordNum)
If n = 1 Then WordNum = Trim(Temp2 & Temp1 & " million " & WordNum)
End If
Next n
NumStr = Trim(str(Abs(MyNumber)))
' Values after the decimal place
DecimalPosition = InStr(NumStr, ".")
Numbers(0) = "Zero"
If DecimalPosition > 0 And DecimalPosition < Len(NumStr) Then
Temp1 = " point"
For n = DecimalPosition + 1 To Len(NumStr)
Temp1 = Temp1 & " " & Numbers(Val(Mid(NumStr, n, 1)))
Next n
WordNum = WordNum & Temp1
End If
'MsgBox WordNum & " Only"
sht_Ex1.Range("D19") = WordNum & " Only"
If Len(WordNum) = 0 Or Left(WordNum, 2) = " p" Then
WordNum = "Zero" & WordNum
End If
End Function
Function GetTens(TensNum As Integer) As String
' Converts a number from 0 to 99 into text.
If TensNum <= 19 Then
GetTens = Numbers(TensNum)
Else
Dim MyNo As String
MyNo = Format(TensNum, "00")
GetTens = Tens(Val(Left(MyNo, 1))) & " " & Numbers(Val(Right(MyNo, 1)))
End If
End Function
Public Sub Number_Words()
    WordNum sht_Ex1.Range("C14")
End Sub

Re-usable codes - Connecting various data bases using VBA

Connect to Ms-Access Database
**********************************

Public Sub ConnecttoDatabase()
    Dim strConstr As String
    On Error GoTo errhandler
    strDatabasePath = ThisWorkbook.path & "\<databasename>"
    If objCon.State <> adStateClosed Then objCon.Close
    strConstr = "ODBC;DBQ=" & Databasepath & ";PWD=<pwd>;Driver={Microsoft Access Driver (*.mdb)}"
    objCon.ConnectionString = strConstr
    objCon.Open strConstr ' open the database connection
    Exit Sub
errhandler:
    MsgBox Err.Number & ": " & Err.Description, vbInformation + vbOKOnly, ThisWorkbook.Name
End Sub
--------------------------------------------------------------------------------------------------------
Connect to Excel
**********************************
Private Sub ConnectToExcel()
    Dim cn As New ADODB.Connection
    Dim strconn
    strconn = "DRIVER={Microsoft Excel Driver (*.xls)};DriverId=790;" & _
                "ReadOnly=1;DBQ=" & ThisWorkbook.path & "\<Excelfilename>" ' & ThisWorkbook.Name & ";"
    cn.Open strconn
   
    'Getting Records
    Dim rs As New ADODB.Recordset
    rs.Open "Select * from [sheetname$]", cn, adOpenDynamic, adLockOptimistic
   
    'Paste into Excel
    Range("A1").CopyFromRecordset rs
    MsgBox "Connected"
End Sub
-------------------------------------------------------------------------------------------------------------
'Connect to Oracle
**********************************
Private Sub ConnectToOracle()
    Dim cn As New ADODB.Connection
    Dim cmd As New ADODB.Command
          
    Dim strconn As String
    strconn = "Provider=MSDAORA;Data Source=<datasourcename>;User Id=<userid>;Password=<pwd>"
    cn.Open strconn
       
    'Getting Records
    Dim rs As New ADODB.Recordset
    rs.Open "Select * from <tablename>", cn, adOpenDynamic, adLockOptimistic
   
    'Paste into Excel
    Range("A1").CopyFromRecordset rs
    MsgBox "Connected"
End Sub
-------------------------------------------------------------------------------------------------------------
 'Connect to SQL Server
*************************
Public Sub ConnectToSQLSERVER()
    Dim cn As New ADODB.Connection
    cn.Open "provider=SQLOLEDB;server=" & <servername>& "; uid=<userid>.;pwd=<pwd.;Database=<databasename>"
       
    Dim cmd As New ADODB.Command
   
    'Getting Records
    Dim rs As New ADODB.Recordset
    cmd.ActiveConnection = cn
    cmd.CommandText = <tablename>    \
    cmd.CommandType = adCmdStoredProc
    Set rs = cmd.Execute
   
    'rs.Open "Select * from <tablename>", cn, adOpenDynamic, adLockOptimistic
   
    'Paste into Excel
    Range("A1").CopyFromRecordset rs
    MsgBox "Connected"
   
End Sub
---------------------------------------------------------------------------------------------------------
'Connect to Csv format
*************************
Public Sub ConnectToCsv()
    Dim cn As New ADODB.Connection
    Dim str As String
    cn.Open "Driver={Microsoft Text Driver (*.txt; *.csv)};DBQ=" & _
        ThisWorkbook.path
   
End Sub