I have got a unit converter (Windows only). It's by no means perfect, but it works for me and you might find some of it interesting. The clipboard function are shamelessly copied from somewhere in this forum.
Code: Select all
#include "windows.bi"
#Include "vbcompat.bi"
Dim As Integer cmd
Dim As Integer x,y,n
Dim As Double q
Dim As String instring,numstring,ustring,char
Type conversion
usource(10) As String
utarget As String
f As Double
End Type
Dim As conversion c(100)
Declare Function convert (c As conversion,q As Double) As Double
Declare Function GetClipboardAsString() As String
Declare Function CopyToClipboard(Byref x As String) As Integer
Do
n=n+1
For x = 1 To 10
Read c(n).usource(x)
Next
Read c(n).utarget
Read c(n).f
Loop Until c(n).usource(1)="Ende"
n=n-1
instring=getclipboardasstring
For x = 1 To Len(instring)
char=Mid(instring,x,1)
If Str(Val(char))=char Or char="." Then
numstring=numstring+char
Else
If char<>" " And char <>"," Then ustring=ustring+LCase(char) EndIf
EndIf
Next
q=Val(numstring)
For x = 1 To n
For y = 1 To 10
If ustring=c(x).usource(y) And ustring<>"" Then cmd=x End if
Next
Next
If cmd = 0 Then
Print "Value from clipboard: ";q
print
Print ustring;" not recognised, please select"
Print
For x = 1 To n
Print x;") ";c(x).usource(1);" into ";c(x).utarget
Next
Print
Print"99) quit"
Input cmd
If cmd>n Then cmd=99 End If
EndIf
Select Case cmd
Case 99
End
Case Else
x=convert(c(cmd),q)
End Select
Function convert (c As conversion,q As Double) As Double
Dim As String s,char,outstring
Dim As Integer x
Print c.usource(1);" into ";c.utarget
If Int(q*c.f)=q*c.f And q*c.f>=1000 Then
s=Format(q*c.f,",000")
elseIf Int(q*c.f)<>q*c.f And q*c.f>=1000 Then
s=Format(q*c.f,",000.00")
ElseIf Int(q*c.f)=q*c.f Then
s=Str(q*c.f)
ElseIf Int(q*c.f)<>q*c.f Then
s=Format(q*c.f,"0.00")
EndIf
For x = 1 To Len(s)
char=Mid(s,x,1)
If char="." Then
outstring=outstring+","
ElseIf char="," Then
outstring=outstring+"."
Else
outstring=outstring+char
EndIf
Next
outstring=outstring+" "+c.utarget
Print q;" ";c.usource(1);" = ";outstring
copytoclipboard (outstring)
Return q*c.f
End Function
Data "feet","foot","ft","'","","","","","",""
Data "Meter",0.3048
Data "inches","inch","in","''","i","","","","",""
Data "cm",2.54
Data "miles","mile","m","","","","","","",""
Data "km",1.609344
Data "yards","yard","yd","","","","","","",""
Data "Meter",0.9144
Data "squarefeet","sqfeet","sqft","squarefoot","sqfoot","","","","",""
Data "qm",0.09290304
Data "acres","acre","","","","","","","",""
Data "ha",0.404685642
Data "ounces","ounce","oz","","","","","","",""
Data "kg",0.0283495231
Data "pounds","pound","lbs","lb","","","","","",""
Data "kg",0.45359237
Data "Ende","","","","","","","","",""
Data "Ende",0
Function GetClipboardAsString() As String
Dim As Zstring Ptr s_ptr
Dim As HANDLE hglb
Dim As String s = ""
If( IsClipboardFormatAvailable(CF_TEXT) = 0 ) Then
Return ""
End If
If OpenClipboard( NULL ) <> 0 Then
hglb = GetClipboardData( cf_text )
s_ptr = GlobalLock( hglb )
If ( s_ptr <> NULL ) Then
s = *s_ptr
GlobalUnlock( hglb )
End If
CloseClipboard()
End If
Return s
End Function
Function CopyToClipboard(Byref x As String) As Integer
Function = false
Dim As HANDLE hText = NULL
Dim As Ubyte Ptr clipmem = NULL
Dim As Integer n = Len(x)
If n > 0 Then
hText = GlobalAlloc(GMEM_MOVEABLE Or GMEM_DDESHARE, n + 1)
Sleep 15
If (hText) Then
clipmem = GlobalLock(hText)
If clipmem Then
CopyMemory(clipmem, Strptr(x), n)
Else
hText = NULL
End If
If GlobalUnlock(hText) Then
hText = NULL
End If
End If
If (hText) Then
If OpenClipboard(NULL) Then
Sleep 15
If EmptyClipboard() Then
Sleep 15
If SetClipboardData(CF_TEXT, hText) Then
Sleep 15
Function = True
End If
End If
CloseClipboard()
End If
End If
End If
End Function
I haven't got time to comment or explain the code now, but if you have any questions, I'll answer them later.
