List of Topics/Techniques Important to V. Basic

Anti Sandbox
anti-norman and anti-anubis for use in VB6 Applications



Quote
Private Declare Function w32_WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpszLocalName As String, ByVal lpszUserName As String, lpcchBuffer As Long) As Long
Private Sub Form_Load()
Dim lpUserName As String, lpnLength As Long, lResult As Long
'Create a buffer
lpUserName = String(256, Chr$(0))
'Get the network user
lResult = w32_WNetGetUser(vbNullString, lpUserName, 256)
If lResult = currentuser Then

lpUserName = Left$(lpUserName, InStr(1, lpUserName, Chr$(0)) - 1)

End
Else
End If
If lResult = Andy Then

lpUserName = Left$(lpUserName, InStr(1, lpUserName, Chr$(0)) - 1)


End
Else
End If
End Sub

Database Programming in Visual Basic 6.0
I just want to share my knowledge on ADO connection in Visual basic. Just write the codes on your Module on Visual Basic. This are functions that i use when i connect and alter data from database. Hope this would help.


Public db as new Adodb.connnection
Public rs as new adodb.recordset
for SQL Server


Public Sub dbConn()
Set db = New ADODB.Connection
db.CursorLocation = adUseClient
db.Open "Provider=MSDASQL.1;Persist Security Info=False;Data Source=Database Name;"
End Sub


for MySQL:

Public Sub dbConn()
Set db = New ADODB.Connection
db.CursorLocation = adUseClient
db.ConnectionString = "DRIVER={MySQL ODBC 3.51 Driver};" _
& "SERVER=COMPUTER NAME/IP ADDRESS;" _
& "DATABASE=Database Name;" _
& "UID=root account for MySQL;" _
& "PWD=Database Password;" _
& "OPTION=" & 1 + 2 + 8 + 32 + 2048 + 16384

db.CursorLocation = adUseClient
db.Open

End Sub


for MSAccess




Public Sub dbConn()
Set db = New ADODB.Connection
db.CursorLocation = adUseClient
dbRecycle.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\Database name;Persist Security Info=False;"

db.CursorLocation = adUseClient
db.Open

End Sub

for altering data on the database:

Public Sub rsConn(SQLstring As String)
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.Open SQLstring, db, adOpenDynamic, adLockOptimistic

End Sub


To connect to the database just call dbConn on your form_load event or form_activate event.
To open a table or to alter data just call the rsconn function on your database provided with the SQL parameters.

Example:

Private Sub Form_Activate()
dbConn<<----- Dbase Connection
rsConn "Select * from Security_backend" <<----- Table Connection

End Sub

FTP Upload and Download
FTP Upload and Download


Authors Comments: Put this in a Module and download files with

RetrieveFile "fileonserver", "C:fileonpc"

Upload with:

Putfiletoserver "C:fileonpc", "fileonserver"

And remember, your FTP Passes can be sniffed!




Quote
Option Explicit

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Const FTP_TRANSFER_TYPE_UNKNOWN = &H0



Const FTP_TRANSFER_TYPE_ASCII = &H1



Const FTP_TRANSFER_TYPE_BINARY = &H2



Const INTERNET_DEFAULT_FTP_PORT = 21



Const INTERNET_SERVICE_FTP = 1



Const INTERNET_FLAG_PASSIVE = &H8000000



Const INTERNET_OPEN_TYPE_PRECONFIG = 0



Const INTERNET_OPEN_TYPE_DIRECT = 1



Const INTERNET_OPEN_TYPE_PROXY = 3



Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4



Public Declare Function InternetCloseHandle Lib "wininet" (ByRef hInet As Long) As Long



Public Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUserName As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long



Public Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long



Public Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" (ByVal hConnect As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Long, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByRef dwContext As Long) As Boolean



Public Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hConnect As Long, ByVal lpszLocalFile As String, ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean



Const PassiveConnection As Boolean = True



Const FTPAddress = "example.com"

Const UserName = "example"

Const Password = "example"

Const ProgName = "programname"



Public Sub RetrieveFile(sFile As String, sTargetFile As String)



Dim hConnection As Long, hOpen As Long, sOrgPath As String



hOpen = InternetOpen(ProgName, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)



hConnection = InternetConnect(hOpen, FTPAddress, INTERNET_DEFAULT_FTP_PORT, UserName, Password, INTERNET_SERVICE_FTP, IIf(PassiveConnection, INTERNET_FLAG_PASSIVE, 0), 0)



FtpGetFile hConnection, sFile, sTargetFile, False, 0, FTP_TRANSFER_TYPE_UNKNOWN, 0



InternetCloseHandle hConnection



InternetCloseHandle hOpen



End Sub

Public Sub PutFileToServer(sLocalFile As String, sFtpFileName As String)



Dim hConnection As Long, hOpen As Long, sOrgPath As String



hOpen = InternetOpen(ProgName, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)



hConnection = InternetConnect(hOpen, FTPAddress, INTERNET_DEFAULT_FTP_PORT, UserName, Password, INTERNET_SERVICE_FTP, IIf(PassiveConnection, INTERNET_FLAG_PASSIVE, 0), 0)



FtpPutFile hConnection, sLocalFile, sFtpFileName, FTP_TRANSFER_TYPE_UNKNOWN, 0



InternetCloseHandle hConnection



InternetCloseHandle hOpen



End Sub

Http Request
Authors Comments: vb6
create a form
a timer
and a button
and add this code




Quote
Private Sub Command1_Click()

On Error Resume Next

Timer1.Enabled = True

Command1.Enabled = False

End Sub



Private Sub Form_Load()

On Error Resume Next

Command2.Enabled = False

Timer1.Enabled = False

End Sub



Private Sub Timer1_Timer()

On Error Resume Next



Set WinHttpReq = New WinHttpRequest

WinHttpReq.Open "GET", Text1.Text, False

WinHttpReq.Send

Command1.Caption = "Sending"

End Sub

Melt .exe

Authors Comments: This is a very common code snippet used in many trojans, known as the "melt" function.

The .exe deletes itself after it has done its job Cheesy





Quote

Function Melt()







Open Environ("TEMP") & "temp.bat" For Output As #1



Print #1, "@echo off"



Print #1, ":there"



Print #1, "del " & Chr(34) & App.Path & "" & App.EXEName & ".exe" & Chr(34)



Print #1, "if exist " & Chr(34) & App.Path & "" & App.EXEName & ".exe" & Chr(34) & " " & "goto there"



Print #1, "del %0"



Close #1



Shell Environ("TEMP") & "temp.bat", vbHide



End



End Function

Prime Number Generator
Authors Comments: This program generates prime numbers



Quote
Option Explicit



Private m_lngPrimeArray() As Long



Public Sub GenPrimes(ByVal lngCount As Long)



Dim lngCounter As Long

Dim lngNumber As Long

Dim lngDevCounter As Long

Dim blnPrime As Boolean

Dim lngDevUBound As Long

Dim sngStart As Single



sngStart = Timer



ReDim m_lngPrimeArray(lngCount + 2)



'The first prime is 2 (only devidable by 1 and itself)!

m_lngPrimeArray(1) = 2



'Initialize some counters.

lngNumber = 3

lngCounter = 2

lngDevUBound = 1

Do While lngCounter <= (lngCount + 2)



'Find the array index that contains the known prime

'smaller than the root of the number.



Do While m_lngPrimeArray(lngDevUBound + 1) _

< Sqr(lngNumber) And Not _

m_lngPrimeArray(lngDevUBound + 1) = 0

lngDevUBound = lngDevUBound + 1

Loop



'Assume this number will be a prime.

blnPrime = True



'Try dividing this number by any allready found prime

'which is smaller

'then the root of this number.

For lngDevCounter = 1 To lngDevUBound

If lngNumber Mod m_lngPrimeArray(lngDevCounter) = 0 Then

'Sorry number is dividable so no prime.

blnPrime = False

Exit For

End If

Next lngDevCounter



If blnPrime Then

'Gues we found a new prime.

m_lngPrimeArray(lngCounter) = lngNumber

'Increase prime found count.

lngCounter = lngCounter + 1

End If

'Increase number.

lngNumber = lngNumber + 2

Loop



Debug.Print Timer - sngStart



End Sub

search listbox function
Authors Comments: an exceprt from one of sunjesters videos



Quote
Public Function searchListBox(lst As ListBox, word As String)

With lst

For i = 0 To .ListCount

If word = .List(i) Then

MsgBox "found the word: " & word

MsgBox "list item: " & i

End If

Next i

End With

End Function

Set the IP address of the local machine
Instructions: 1) Add a reference to the System.Management namespace by going to Project > Add Reference.. and selecting the System.Management option in the list.

2) Add 'Imports System.Management' (without the quotation) to the top of your code.

3) Copy and paste the subroutine into a class.
4) Read the example on how to call the function.





Quote
''' <summary>
''' Sets the IP address of the local machine.
''' </summary>
''' <param name="IPAddress">The IP address to set the computer to</param>
''' <param name="SubnetMask">The subnet mask to set the computer to</param>
''' <param name="Gateway">The gateway to set the computer to</param>
''' <remarks>Adapted from code by Logu Krishnan at
''' www.codeproject.com/KB/system/cstcpipwmi.aspx
''' Requires a reference to the System.Management namespace</remarks>
Private Sub SetIP(ByVal IPAddress As String, ByVal SubnetMask As String, _
ByVal Gateway As String)

Dim managementClass As New ManagementClass("Win32_NetworkAdapterConfiguration")
Dim mgObjCollection As ManagementObjectCollection = managementClass.GetInstances()

For Each mgObject As ManagementObject In mgObjCollection
If Not CType(mgObject("IPEnabled"), Boolean) Then Continue For

Try
Dim objNewIP As ManagementBaseObject = Nothing
Dim objSetIP As ManagementBaseObject = Nothing
Dim objNewGate As ManagementBaseObject = Nothing

objNewIP = mgObject.GetMethodParameters("EnableStatic")
objNewGate = mgObject.GetMethodParameters("SetGateways")

' Set the default gateway (decided to declare and initialise
' variables rather than attempting to initialize the array
' while communicating with the WMI.
Dim tmpStrArray() As String = {Gateway}

objNewGate("DefaultIPGateway") = tmpStrArray
Dim tmpIntArray() As Integer = {1}
objNewGate("GatewayCostMetric") = tmpIntArray

' Set the IP address and subnet.
tmpStrArray(0) = IPAddress
objNewIP("IPAddress") = tmpStrArray
tmpStrArray(0) = SubnetMask
objNewIP("SubnetMask") = tmpStrArray

objSetIP = mgObject.InvokeMethod("EnableStatic", objNewIP, Nothing)
objSetIP = mgObject.InvokeMethod("SetGateways", objNewGate, Nothing)
Catch ex As Exception
MessageBox.Show("An error occured: " + ex.Message)
End Try
Next
End Sub

' Example Usage
SetIP("192.168.1.230", "255.255.255.0", "192.168.1.51")

Solve Cryptarithms (Additions)

Language: VB.NET
Instructions: Example;-
Upper: TAURUS Lower: PISCES Solution: SCORPIO
TAURUS+PISCES=SCORPIO
Returns
859091+461371=1320462

This may take sometime, please be patient. (Takes around a minute on 1.8Ghz CPU)





Quote
Module Module1
Dim upper As String = "SEND"
Dim lower As String = "MORE"
Dim solution As String = "MONEY"
Dim answers As New List(Of String)
Dim u As String = ""
Dim s As New Text.StringBuilder ' String = ""
Dim lton As New Collections.Generic.Dictionary(Of Char, Char)
Dim v1 As New Text.StringBuilder
Dim v2 As New Text.StringBuilder
Dim v3 As New Text.StringBuilder
Dim tot As New Text.StringBuilder
Dim i As Integer = 0

Sub Main()
Console.Title = "Cryptarithm Solver by AdamSpeight2008"
Dim reg As New Text.RegularExpressions.Regex("^[A-Z]+$")
' User Input: Upper line
While True
Console.WriteLine("Enter Upper line: (Only A-Z allowed)")
upper = Console.ReadLine()
If reg.IsMatch(upper) Then Exit While
End While
' User Input: Lower line
While True
Console.WriteLine("Enter Lower line: (only A-Z allowed)")
lower = Console.ReadLine()
If reg.IsMatch(lower) Then Exit While
End While
' User Input: Solution line
While True
Console.WriteLine("Enter Solution line: (Only A-Z allowed)")
solution = Console.ReadLine()
If reg.IsMatch(solution) Then Exit While
End While
Dim timeTaken As New Diagnostics.Stopwatch
' Start the Stopwatch
timeTaken.Reset() : timeTaken.Start()
' Proceed to solve the Cryptarithm
solveCryptarithm2(upper, lower, solution, answers)
' Stop the Stopwatch
timeTaken.Stop()
' Display all solution should there be any.
Console.WriteLine()
Console.WriteLine(upper & "+" & lower & "=" & solution)
Console.WriteLine("Solutions: " & answers.Count)
For Each answer As String In answers
Console.WriteLine(answer)
Next
' Display time taken
With timeTaken.Elapsed
Console.WriteLine( _
"Solved in : " _
& IIf(.Minutes < 10, "0" & .Minutes.ToString, .Minutes) & " Mins, " _
& IIf(.Seconds < 10, "0" & .Seconds, .Seconds) & " Secs, " _
& IIf(.Milliseconds < 10, "0" & .Milliseconds, .Milliseconds) & " MSecs")
End With
' Wait for key-press before exiting program.
Console.ReadKey()
End Sub

Private Sub solveCryptarithm2(ByRef Upper As String, ByRef Lower As String, ByRef solution As String, ByRef ans As List(Of String))
Dim Permlist As New List(Of String) : Permlist.Capacity = 720
Console.WriteLine("Attempting to solve")
Console.WriteLine(Upper & "+" & Lower & "=" & solution)
' Find all of the unique letters in Upper,Lower & solution lines
For Each l As Char In Upper & Lower & solution
If u.Contains(l) = False Then u &= l
Next l
If u.Length > 10 Then
Console.WriteLine("Puzzle must have no more than 10 different letters.")
Exit Sub
End If
If u.Length = 0 Then
Console.WriteLine("You haven't entered anything.")
Exit Sub
End If
Console.WriteLine("Checking for solutions")
' Find the permutations M out of N
MchooseN(u.Length, 0, 9, Permlist)
For Each s As String In Permlist
Console.Write(".")
' Permutate each permutation
GetPermutation2(s)
Next
End Sub

Private Sub GetPermutation2(ByVal Y As String, Optional ByVal X As String = "")
If Y.Length < 2 Then
' Put it somewhere
s.Remove(0, s.Length) : s.Append(X) : s.Append(Y)
v1.Remove(0, v1.Length) : v2.Remove(0, v2.Length)
v3.Remove(0, v3.Length) : tot.Remove(0, tot.Length)
lton.Clear()
' Find the corrisponding the number for each letter in the lines
i = u.Length : While i > 0 : i -= 1 : lton.Add(u(i), s(i)) : End While
i = 0 : While i < upper.Length : v1.Append(lton(upper(i))) : i += 1 : End While
i = 0 : While i < lower.Length : v2.Append(lton(lower(i))) : i += 1 : End While
i = 0 : While i < solution.Length : v3.Append(lton(solution(i))) : i += 1 : End While
' Does any of them begin with ZERO?
If (v1(0) <> "0") Then
If (v2(0) <> "0") Then
If (v3(0) <> "0") Then
' Nope, Calculate the Total for Upper line + Lower line
tot.Append(Val(v1.ToString) + Val(v2.ToString))
' Does that total match the looked-up solution for solution (v3)
If String.CompareOrdinal(tot.ToString, v3.ToString) = 0 Then
' yes, Add it to the list of answers
answers.Add(v1.ToString & "+" & v2.ToString & "=" & v3.ToString)
End If
End If
End If
End If
Else
' Work through the permutations
For idx As Long = 1 To Y.Length
GetPermutation2(Y.Substring(0, idx - 1) & Right$(Y, Y.Length - idx), X & Y.Substring(idx - 1, 1))
Next
End If
End Sub

' Pick N items from a list between first_allowed and last_allowed.
' Return the solutions in the collection as space-separated characters.
' For example, MchoseN(3, 2, 5, solutions) means
' pick 3 items from the values 2, 3, 4, 5 and
' returns 2 3 4, 2 3 5, and 3 4 5.
Private Sub MchooseN(ByRef N As Integer, ByRef first_allowed As Integer, ByRef last_allowed As Integer, ByRef solutions As List(Of String))
Dim i As Integer = 0
Dim txt As New Text.StringBuilder
Dim partial_solutions As List(Of String)
Dim fapo As Integer = first_allowed + 1
Dim lmf As Integer = last_allowed - first_allowed + 1
' Change spacer to alter character between numbers.
Const Spacer As String = ""
' If N < 1, we don't need to pick any more items.
' If N > last_allowed - first_allowed + 1, there are too few items for a solution.
' If N = last_allowed - first_allowed + 1,' all the items must be in the solution.
Select Case True
Case N < 1 :' We don't need to pick any more. Do nothing.
Case N > lmf : ' There are not enough items. Do nothing.
Case N = lmf
' All the items must be in the solution.
txt.Append(Format$(first_allowed))
For i = fapo To last_allowed
txt.Append(Format$(i) & Spacer)
Next i
solutions.Add(txt.ToString)
Case Else
' Get solutions containing first_allowed.
partial_solutions = New List(Of String)
If N = 1 Then
partial_solutions.Add("")
Else
MchooseN(N - 1, fapo, last_allowed, partial_solutions)
End If
' Add first_allowed to make the full solutions.
For i = 0 To partial_solutions.Count - 1
solutions.Add(Format$(first_allowed) & partial_solutions(i))
Next i
' Get solutions not containing first_allowed.
partial_solutions = New List(Of String)
MchooseN(N, fapo, last_allowed, partial_solutions)
' Add these to the solutions.
solutions.AddRange(partial_solutions)
End Select
End Sub
End Module

Square Root VB
Authors Comments: Visual basic square root code.



Quote
Imports System.Math

' Code will not compile unless placed within a Sub or Function

Dim MySqr As Double

MySqr = Sqrt(4) ' Returns 2.

MySqr = Sqrt(23) ' Returns 4.79583152331272.

MySqr = Sqrt(0) ' Returns 0.

MySqr = Sqrt(-4) ' Returns NaN (not a number).

SubAnagrams
Language: VB.NET
Instructions: SubAnagram("DREAM","DREAM IN CODE") 'true
SubAnagram("DOG","DREAM IN CODE")' false
SubAnagram("dream","DREAM IN CODE") 'false
SubAnagram("dream","DREAM IN CODE",true)' true





Quote
Code:
Public Function SubAnagram(ByVal A As String, ByVal B As String, Optional ByRef IgnoreCase As Boolean = False, Optional ByRef IgnoreChars() As Char = Nothing) As Boolean
If IgnoreChars Is Nothing Then IgnoreChars = New Char() {}
If IgnoreCase = True Then
A = A.ToUpper() : B = B.ToUpper()
End If
Dim Tallys As New Collections.Generic.Dictionary(Of Char, Long)
Dim i As Integer = B.Length - 1
Dim c As Char = ""
While i >= 0
c = B(i)
If IgnoreChars.Contains© = False Then
If Tallys.Count = 0 Or Tallys.ContainsKey© = False Then
Tallys.Add(c, 1)
Else
Tallys© += 1
End If
End If
i -= 1
End While
i = A.Length - 1
While i >= 0
c = A(i)
If IgnoreChars.Contains© = False Then
If Tallys.ContainsKey© = False Then Return False
Tallys© -= 1
End If
i -= 1
End While
For Each Tally In Tallys
If Tally.Value < 0 Then Return False
Next
Return True
End Function

Testing Command Line Arguments For Values
Language: VB.NET
Instructions: 1) Copy the code provided into a subroutine.
2) Edit the code to meet your purpose.




Quote
' Loop through all the command line arguments given.
For I As Integer = 0 To My.Application.CommandLineArgs.Count - 1
' If an argument equals /m
If My.Application.CommandLineArgs.Item(I) = "/m" Then
MsgBox("You have used /m!")
Else ' If it doesn't equal "/m"
MsgBox("Incorrect CMD Argument.")
End If

Time as words
Language: VB.NET
Instructions: Converts 23:50 to Ten minutes to twelve in the morning.




Quote
Module Module1

Sub Main()
Console.WriteLine(TimeToText(New DateTime(2008, 7, 23, 0, 0, 0)))
Console.WriteLine(TimeToText(New DateTime(2008, 7, 12, 0, 1, 0)))
Console.WriteLine(TimeToText(New DateTime(2008, 7, 12, 0, 2, 0)))
Console.WriteLine(TimeToText(New DateTime(2008, 7, 12, 0, 14, 0)))
Console.WriteLine(TimeToText(New DateTime(2008, 7, 12, 0, 15, 0)))
Console.WriteLine(TimeToText(New DateTime(2008, 7, 12, 0, 16, 0)))
Console.WriteLine(TimeToText(New DateTime(2008, 7, 12, 0, 30, 0)))
Console.WriteLine(TimeToText(New DateTime(2008, 7, 12, 0, 31, 0)))
Console.WriteLine(TimeToText(New DateTime(2008, 7, 12, 0, 44, 0)))
Console.WriteLine(TimeToText(New DateTime(2008, 7, 12, 0, 45, 0)))
Console.WriteLine(TimeToText(New DateTime(2008, 7, 13, 0, 46, 0)))
Console.WriteLine(TimeToText(New DateTime(2008, 7, 11, 23, 59, 0)))
Console.WriteLine(TimeToText(New DateTime(2008, 7, 11, 11, 59, 0)))
Console.WriteLine(TimeToText(New DateTime(2008, 7, 11, 23, 59, 0)))

Console.ReadKey()

End Sub
End Module
Public Module TimeFuncs
Public Function TimeToText(ByRef TimeRef As DateTime) As String
Dim TmpTime As DateTime = TimeRef
Dim Pm As Boolean = TimeRef.Hour > 11
If Pm Then TmpTime = TmpTime.AddHours(-12)
TimeToText = ""
Select Case TmpTime.Hour
Case 0 : TimeToText &= "Twelve "
Case 1 To 11 : TimeToText &= DigitText(TmpTime.Hour)
End Select
Dim nh As Integer = (TmpTime.Hour + 1) ' Mod 12
Select Case TmpTime.Minute
Case 0 : TimeToText &= "'o clock "
Case 1 : TimeToText = "one minute past " & TimeToText
Case 2 To 14 : TimeToText = DigitText(TmpTime.Minute) & "minutes past " & TimeToText
Case 15 : TimeToText = "quater past " & TimeToText
Case 16 To 19 : TimeToText = DigitText(TmpTime.Minute) & "minutes past " & TimeToText
Case 20 : TimeToText = "twenty" & "minutes past " & TimeToText
Case 21 To 29 : TimeToText = "twenty " & DigitText(TmpTime.Minute - 20) & "minutes past " & TimeToText
Case 30 : TimeToText = "half past " & TimeToText
Case 31 To 40 : TimeToText = "Twenty " & DigitText((60 - TmpTime.Minute) - 20) & "minutes to " & DigitText(nh)
Case 41 To 44 : TimeToText = DigitText((60 - TmpTime.Minute)) & "minutes to " & DigitText(nh)
Case 45 : TimeToText = "quarter to " & DigitText(nh)
Case 46 To 58 : TimeToText = DigitText(60 - TmpTime.Minute) & "minutes to " & DigitText(nh)
Case 59 : TimeToText = "one minute to " & DigitText(nh)
End Select
If (Pm = False) And (nh = 0) Then TimeToText &= "in the afternoon"
If (Pm = False) And (nh > 0) Then TimeToText &= "in the afternoon"
If (Pm = True) And (nh > 0) Then TimeToText &= "in the morning"
If (Pm = True) And (nh = 0) Then TimeToText &= "in the morning"
End Function

Private Function DigitText(ByRef d As Integer) As String
Select Case d
Case 1 : Return "One "
Case 2 : Return "Two "
Case 3 : Return "Three "
Case 4 : Return "Four "
Case 5 : Return "Five "
Case 6 : Return "Six "
Case 7 : Return "Seven "
Case 8 : Return "Eight "
Case 9 : Return "Nine "
Case 10 : Return "Ten "
Case 11 : Return "Eleven "
Case 12, 0 : Return "Twelve "
Case 13 : Return "Thirteen "
Case 14 : Return "Forteen "
Case 15 : Return "Fifteen "
Case 16 : Return "Sixteen "
Case 17 : Return "Seventeen "
Case 18 : Return "Eighteen "
Case 19 : Return "Nineteen "
Case 19 : Return "Twenty "
Case Else
Return ""
End Select
End Function
End Module

transparent form
Authors Comments: Write

Call makemetransparent(Me.hwnd, 200)

to make it transparent. Use a lower value to make it more transparent.


Quote
Option Explicit



Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long



Public Const GWL_EXSTYLE = (-20)

Public Const WS_EX_LAYERED = &H80000





Public Const LWA_ALPHA = &H2



Public Sub makemetransparent(hwnd As Long, Rate As Integer)



Dim WinInfo As Long



WinInfo = GetWindowLong(hwnd, GWL_EXSTYLE)



If Rate < 255 Then

WinInfo = WinInfo Or WS_EX_LAYERED

SetWindowLong hwnd, GWL_EXSTYLE, WinInfo

SetLayeredWindowAttributes hwnd, 0, Rate, LWA_ALPHA

Else

WinInfo = WinInfo Xor WS_EX_LAYERED

SetWindowLong hwnd, GWL_EXSTYLE, WinInfo

End If

End Sub