Visual Basic Helper Routines
Pure VB: Temperature Conversion Routines
     
Posted:   Monday March 25, 2002
Updated:   Monday December 26, 2011
     
Applies to:   VB4-32, VB5, VB6
Developed with:   VB6, Windows XP
OS restrictions:   None
Author:   VBnet - Randy Birch
     
 Prerequisites
None.

Here are a set of straightforward routines to convert one temperature to another - enter a value in one text box, and the others change to the correct value. The code for validating the entry actually took much longer to write than the code to convert the temperatures, as the demo will show.

The formulas for temperature conversion are:

  Celsius (C) to Kelvin (K) = C + 273.15
  Celsius (C) to Fahrenheit (F) = (C * 9/5) + 32
  Fahrenheit (F) to Kelvin (K) = (F - 32)/1.8 + 273.15
  Fahrenheit (F) to Celsius (C) = (F - 32)/1.8
  Kelvin (K) to Fahrenheit (F) = (K - 273.15) * 9/5 + 32
  Kelvin (K) to Celsius (C) = K - 273.15
 BAS Module Code
None.

 Form Code
Add three text boxes (Text1, Text2, Text3) to a form with the following code:

Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright 1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce 
'               or publish this code on any web site,
'               online service, or distribute as source 
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'flag to prevent recursive Change events
Dim bInTransaction As Boolean

Private Sub Form_Load()

   bInTransaction = True
   
   Text1.Text = "0"
   Text2.Text = "0"
   Text3.Text = "0"

   bInTransaction = False
   
End Sub


Private Sub Text1_Change()

  'bail out if change was fired by
  'another routine changing the
  'textbox contents
   If bInTransaction Then Exit Sub

  'validate the entered data
   If Len(Text1.Text) > 0 Then
      If FieldCheck(Text1) = True Then
   
        'about to update other controls,
        'so set the flag and process
         bInTransaction = True
         Text2.Text = CelsiusToFahrenheit(CSng(Text1.Text))
         Text3.Text = CelsiusToKelvin(CSng(Text1.Text))
         bInTransaction = False
      
      End If  'If FieldCheck2(Text1)
   End If  'If Len(Text1.Text)
   
End Sub


Private Sub Text2_Change()

   If bInTransaction Then Exit Sub

   If Len(Text2.Text) > 0 Then
      If FieldCheck(Text2) = True Then

         bInTransaction = True
         Text1.Text = FahrenheitToCelsius(CSng(Text2.Text))
         Text3.Text = FahrenheitToKelvin(CSng(Text2.Text))
         bInTransaction = False
   
      End If  'If FieldCheck2(Text1)
   End If  'If Len(Text1.Text)
   
End Sub


Private Sub Text3_Change()

   If bInTransaction Then Exit Sub

   If Len(Text3.Text) > 0 Then
      If FieldCheck(Text3) = True Then

         bInTransaction = True
         Text1.Text = KelvinToCelsius(CSng(Text3.Text))
         Text2.Text = KelvinToFahrenheit(CSng(Text3.Text))
         bInTransaction = False
   
      End If  'If FieldCheck2(Text1)
   End If  'If Len(Text1.Text)
   
End Sub


Private Function CelsiusToFahrenheit(ByVal temperature As Single) As Single

  'Celsius(C) to Fahrenheit(F) = (C * 9/5) + 32
   CelsiusToFahrenheit = (temperature * 1.8) + 32
   
End Function


Private Function KelvinToFahrenheit(ByVal temperature As Single) As Single

  'Kelvin(K) to Fahrenheit(F) = (K * 9/5) + 32
   KelvinToFahrenheit = ((temperature - 273.15) * 1.8) + 32
   
End Function



Private Function CelsiusToKelvin(ByVal temperature As Single) As Single

  'Celsius(C) to Kelvin(K) = C + 273.15
   CelsiusToKelvin = temperature + 273.15
   
End Function


Private Function FahrenheitToCelsius(ByVal temperature As Single) As Single

  'Fahrenheit(F) to Celsius(C) = (F - 32)/1.8
   FahrenheitToCelsius = (temperature - 32) / 1.8

'sngValue = (sngValue - 32) / 1.8

End Function

Private Function KelvinToCelsius(ByVal temperature As Single) As Single

  'Kelvin(K) to Celsius(C) = K - 273.15
   KelvinToCelsius = temperature - 273.15

End Function


Private Function FahrenheitToKelvin(ByVal temperature As Single) As Single

  'Fahrenheit(F) to Kelvin(K) = (F - 32)/1.8 + 273.15
   FahrenheitToKelvin = ((temperature - 32) / 1.8) + 273.15

End Function


Private Function FieldCheck(txt As TextBox) As Boolean
  
  Const sValidChrs As String = "1234567890."
  
  Dim buff     As String   'string buffer
  Dim errmsg   As String   'error msg
  Dim bValid   As Boolean  'flag
  Dim decimals As Long     'counter var
  Dim dashes   As Long     'counter var
  Dim commas   As Long     'counter var
  Dim cnt      As Long     'counter
  Dim char     As String   'char of interest
  
 'setup
  bValid = False
  decimals = 0
  dashes = 0
  commas = 0
  
 'retrieve text from the passed control
  buff = txt.Text
  
 'see if user entering a negative number
 'or decimal, and if so bail if just
 '- or . is present
   If Len(buff) = 1 And (buff = "-") Or (buff = ".") Then
      bValid = False
      Exit Function
   End If
   
  bValid = True
  
  'loop through the buffer
   For cnt = 1 To Len(buff)
    
     'extract a character and validate
      char = Mid$(buff, cnt, 1)
      bValid = InStr(sValidChrs, char) > 0
      
     'total up any special characters
      decimals = decimals + Abs(char = ".")
      dashes = dashes + Abs(char = "-")
      commas = commas + Abs(char = ",")
            
   Next cnt
   
  'if the buffer data matches the valid string
  'and there are was only 1 decimal and/or dash
  'and no commas, then bValid = True
   bValid = bValid And _
           (decimals <= 1) And _
           (dashes <= 1) And _
           (commas = 0)
  
   If bValid = False Then
      
      errmsg = "The value entered in " + txt.Name + _
               " is not valid. (valid = 1234567890.-)"

      If decimals > 1 Then
         errmsg = errmsg & vbCrLf & txt.Name + _
                  " contains more than one decimal."
      End If
       
      If dashes > 1 Then
         errmsg = errmsg & vbCrLf & txt.Name + _
                  " contains more than one dash."
      End If
      
      If commas > 1 Then
         errmsg = errmsg & vbCrLf & txt.Name + _
                  " cannot contain commas."
      End If
      
      If Len(buff) = 0 Then
         errmsg = errmsg & vbCrLf & txt.Name + " is empty."
      End If
      
      txt.SetFocus
      MsgBox errmsg, vbOKOnly Or vbInformation
   
   End If
   
   FieldCheck = bValid
    
End Function
 Comments

 
 

PayPal Link
Make payments with PayPal - it's fast, free and secure!

 
 
 
 

Copyright 1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy

 

Hit Counter