Temperature And Conversions

'UserForm1

'A) Normal Reference Add

'A1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'A2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE
'A3) Name: stdole, Description: OLE Automation, FullPath: C:\WINDOWS\system32\STDOLE2.TLB
'A4) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'A5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\WINDOWS\system32\FM20.DLL
'A6) Name: MSComctlLib, Description: Microsoft Windows Common Controls 6.0 (SP6), FullPath: C:\WINDOWS\system32\MSCOMCTL.OCX [Picture= 1]

'B) Tools Add on UserForm1\

'B1. Frame1
'B2. Frame1\Label1, Label2, Image1
'B3. ListBox1, ListBox2
'B4. TextBox1, TextBox2
'B5. Label3, Label4, Label5, Label6, Label7
'B6. ImageList (Automatic setup in Class1 module with private dimention)

Option Explicit
Private i As Single
Private Durum As Boolean, Seçenek As String
Private Derece As Double, Derecesi As Double
Private KD As String, HD As String
Private F°C°H As Variant, K°C°H As Variant, R°C°H As Variant, N°C°H As Variant, D°C°H As Variant, C°C°H As Variant
Private C°K°H As Variant, F°K°H As Variant, R°K°H As Variant, N°K°H As Variant, D°K°H As Variant, K°K°H As Variant
Private C°F°H As Variant, K°F°H As Variant, R°F°H As Variant, N°F°H As Variant, D°F°H As Variant, F°F°H As Variant
Private C°R°H As Variant, F°R°H As Variant, K°R°H As Variant, N°R°H As Variant, D°R°H As Variant, R°R°H As Variant
Private C°D°H As Variant, F°D°H As Variant, K°D°H As Variant, N°D°H As Variant, R°D°H As Variant, D°D°H As Variant
Private C°N°H As Variant, F°N°H As Variant, K°N°H As Variant, R°N°H As Variant, D°N°H As Variant, N°N°H As Variant
Private F°C°F As Variant, K°C°F As Variant, R°C°F As Variant, N°C°F As Variant, D°C°F As Variant, C°C°F As Variant
Private C°K°F As Variant, F°K°F As Variant, R°K°F As Variant, N°K°F As Variant, D°K°F As Variant, K°K°F As Variant
Private C°F°F As Variant, K°F°F As Variant, R°F°F As Variant, N°F°F As Variant, D°F°F As Variant, F°F°F As Variant
Private C°R°F As Variant, F°R°F As Variant, K°R°F As Variant, N°R°F As Variant, D°R°F As Variant, R°R°F As Variant
Private C°D°F As Variant, F°D°F As Variant, K°D°F As Variant, N°D°F As Variant, R°D°F As Variant, D°D°F As Variant
Private C°N°F As Variant, F°N°F As Variant, K°N°F As Variant, R°N°F As Variant, D°N°F As Variant, N°N°F As Variant
Private EkranBezeme As New Class1
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] Temperature And Conversion"
Durum = False
Application.Visible = False
Application.VBE.MainWindow.Visible = False
Set EkranBezeme.ResimEkle = Me
Set EkranBezeme.Ekran1 = Me
Call EkranDüzenle
Call SıcaklıkTanımları
Durum = True
ListBox1.ListIndex = 0
ListBox2.ListIndex = 1

End Sub
Private Sub UserForm_Resize()

On Error Resume Next
With Me

.Top = (Application.Height - .Height) / 2
.Left = (Application.Width - .Width) / 2

End With

End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

On Error Resume Next
Application.Visible = True
End

End Sub
Private Sub ListBox1_Click()

On Error Resume Next
Call SÇHveSÇFHazırlığı

End Sub
Private Sub ListBox2_Click()

On Error Resume Next
Call SÇHveSÇFHazırlığı

End Sub
Private Sub TextBox1_Change()

On Error Resume Next
Call SÇHveSÇFHazırlığı

End Sub
Private Sub EkranDüzenle() '[Form regulation]

On Error Resume Next
With Me

.Width = 256
.Height = 184
.BackColor = &H80000016
With Frame1

.Caption = ""
.BorderStyle = fmBorderStyleNone
.Top = 0
.Left = 0
.Height = 36
.Width = Me.Width + 12
.SpecialEffect = fmSpecialEffectFlat
.Picture = Resim(URL1)
'.Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\zarifVİSTA.bmp")
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
With Label1

.Caption = " " & "Mustafa ULUSARAÇ"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 6
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000

End With
With Label2

.Caption = " " & "01ulusarac@superonline.com"
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.Left = 30
.Top = 18
.Height = 12
.Width = 198
.Font.Bold = True
.ForeColor = &HFF0000

End With
With Image1

.BackStyle = fmBackStyleTransparent
.BorderColor = &HFF0000
.BorderStyle = fmBorderStyleSingle
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.Picture = Resim(URL2)
'.Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\Örnekİkonlar\PBİD.ico")

End With

End With
With Label3

.Left = 6
.Top = 42
.Width = 120
.Height = 12
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignCenter
.Caption = "Kaynak Isı Tanımları"

End With
With Label4

.Left = 126
.Top = 42
.Width = 120
.Height = 12
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignCenter
.Caption = "Hedef Isı Tanımları"

End With
With Label5

.Left = 6
.Top = 116
.Width = 28
.Height = 18
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignCenter
.Caption = ""

End With
With Label6

.Left = 126
.Top = 116
.Width = 24
.Height = 18
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignCenter
.Caption = ""

End With
With Label7

.Left = 6
.Top = 136
.Width = 240
.Height = 18
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignCenter
.Caption = ""

End With
With ListBox1

.Top = 54
.Left = 6
.Width = 120
.Height = 61.5
.BackColor = &H80000018
.SpecialEffect = fmSpecialEffectEtched
.ColumnCount = 2
.ColumnWidths = "36;74"

End With
With ListBox2

.Top = 54
.Left = ListBox1.Left + ListBox1.Width
.Width = 120
.Height = 61.5
.BackColor = &H80000018
.SpecialEffect = fmSpecialEffectEtched
.ColumnCount = 2
.ColumnWidths = "36;74"

End With
With TextBox1

.Left = 30
.Top = 116
.Height = 18
.Width = 96
.SpecialEffect = fmSpecialEffectEtched
.ForeColor = vbBlue
.TextAlign = fmTextAlignCenter

End With
With TextBox2

.Left = 150
.Top = 116
.Height = 18
.Width = 96
.SpecialEffect = fmSpecialEffectEtched
.ControlTipText = "FormGuid Major"
.BackColor = &H80000018
.Locked = True
.ForeColor = vbBlack
.TextAlign = fmTextAlignCenter

End With

End With

End Sub
Private Sub SıcaklıkTanımları() '[Description]

On Error Resume Next
ListBox1.AddItem "C°": ListBox1.List(0, 1) = "Celsius"
ListBox1.AddItem "F°": ListBox1.List(1, 1) = "Fahrenhayt"
ListBox1.AddItem "K°": ListBox1.List(2, 1) = "Kelvin"
ListBox1.AddItem "N°": ListBox1.List(3, 1) = "Newton"
ListBox1.AddItem "D°": ListBox1.List(4, 1) = "Delisle"
ListBox1.AddItem "R°": ListBox1.List(5, 1) = "Rankin"
ListBox2.List() = ListBox1.List()
ListBox1.ListIndex = 5
ListBox2.ListIndex = 5

End Sub
Private Sub SÇHveSÇFHazırlığı() '[Prapere]

On Error GoTo Hata
If Durum = False Then Exit Sub
If VBA.IsNumeric(TextBox1.Value) = False Then

Derecesi = 0

Else

Derecesi = TextBox1.Value

End If
Label5.Caption = ListBox1.List(ListBox1.ListIndex, 0)
Label6.Caption = ListBox2.List(ListBox2.ListIndex, 0)
TextBox2.Value = SÇH(Label5.Caption, Label6.Caption, Derecesi)
Label7.Caption = SÇF(Label5.Caption, Label6.Caption)
Exit Sub
Hata:
TextBox2.Value = ""
Label7.Caption = ""

End Sub
Private Function SÇH(KD, HD, Derece) 'Sıcaklık Çevirim Hesabı [temperature and conversion ]

On Error Resume Next
F°C°H = (Derece - 32) * (5 / 9)
K°C°H = (Derece - 273.15)
R°C°H = (Derece * (5 / 9)) - 273.15
N°C°H = (Derece * (300 / 99))
D°C°H = (100 - (Derece / 1.5))
C°K°H = (Derece + 273.15)
F°K°H = ((Derece - 32) * (5 / 9) + 273.15)
R°K°H = (Derece * (5 / 9))
N°K°H = (Derece / (1 / 3) + 273.15)
D°K°H = ((273.15 + 100) - (Derece - Derece * (1 / 3)))
C°F°H = ((9 / 5) * Derece + 32)
K°F°H = ((9 / 5) * (Derece - 273.15) + 32)
R°F°H = (Derece - 459.67)
N°F°H = (Derece * ((300 / 99) * 9 / 5) + 32)
D°F°H = (212 - (Derece * 1.2))
C°R°H = ((9 / 5) * (Derece + 273.15))
F°R°H = (Derece + 459.67)
K°R°H = ((9 / 5) * Derece)
N°R°H = (491.67 + (300 / 99) * (9 / 5) * Derece)
D°R°H = ((459.67 + 212) - Derece * 1.2)
C°D°H = (150 - (Derece * 1.5))
F°D°H = (212 - Derece) / 1.2
K°D°H = (459.67 + 100) - (Derece * 1.5)
N°D°H = 150 - (Derece * (300 / 99) * 1.5)
R°D°H = (459.67 + 100) - (Derece * (1 / 1.2))
C°N°H = (Derece * 1 / 3)
F°N°H = (Derece * ((32 / ((300 / 99) * (9 / 5))) / 32)) - (32 / ((300 / 99) * (9 / 5)))
K°N°H = Derece * 1 / 3 - (273.15 / 3)
R°N°H = ((32 / ((300 / 99) * (9 / 5))) / 32) * (Derece - 491.67)
D°N°H = (150 * 0.22) - (Derece * 0.22)
C°C°H = Derece
F°F°H = Derece
K°K°H = Derece
N°N°H = Derece
D°D°H = Derece
R°R°H = Derece
Seçenek = HD
Select Case Seçenek

Case "C°": SÇH = VBA.Switch(KD & HD = "F°C°", F°C°H, KD & HD = "K°C°", K°C°H, KD & HD = "R°C°", R°C°H, KD & HD = "N°C°", N°C°H, KD & HD = "D°C°", D°C°H, KD & HD = "C°C°", C°C°H)
Case "K°": SÇH = VBA.Switch(KD & HD = "C°K°", C°K°H, KD & HD = "F°K°", F°K°H, KD & HD = "R°K°", R°K°H, KD & HD = "N°K°", N°K°H, KD & HD = "D°K°", D°K°H, KD & HD = "K°K°", K°K°H)
Case "F°": SÇH = VBA.Switch(KD & HD = "C°F°", C°F°H, KD & HD = "K°F°", K°F°H, KD & HD = "R°F°", R°F°H, KD & HD = "N°F°", N°F°H, KD & HD = "D°F°", D°F°H, KD & HD = "F°F°", F°F°H)
Case "R°": SÇH = VBA.Switch(KD & HD = "C°R°", C°R°H, KD & HD = "F°R°", F°R°H, KD & HD = "K°R°", K°R°H, KD & HD = "N°R°", N°R°H, KD & HD = "D°R°", D°R°H, KD & HD = "R°R°", R°R°H)
Case "D°": SÇH = VBA.Switch(KD & HD = "C°D°", C°D°H, KD & HD = "F°D°", F°D°H, KD & HD = "K°D°", K°D°H, KD & HD = "N°D°", N°D°H, KD & HD = "R°D°", R°D°H, KD & HD = "D°D°", D°D°H)
Case "N°": SÇH = VBA.Switch(KD & HD = "C°N°", C°N°H, KD & HD = "F°N°", F°N°H, KD & HD = "K°N°", K°N°H, KD & HD = "R°N°", R°N°H, KD & HD = "D°N°", D°N°H, KD & HD = "N°N°", N°N°H)

End Select

End Function
Private Function SÇF(KD, HD) 'Sıcaklık Çevirim Formülleri [Temperature and conversion formulas]

On Error Resume Next
F°C°F = "(F°-32)*(5/9)"
K°C°F = "(K°-273.15)"
R°C°F = "(R°*(5/9))-273.15"
N°C°F = "(Derece * (300 / 99))"
D°C°F = "(N°-(N°/1.5))"
C°K°F = "(Derece + 273.15)"
F°K°F = "((C°-32)*(5/9)+273.15)"
R°K°F = "(R°*(5/9))"
N°K°F = "(N°/(1/3)+273.15)"
D°K°F = "((273.15+100)-(D°-D°*(1/3)))"
C°F°F = "((9/5)*C°+32)"
K°F°F = "((9/5)*(K°-273.15)+32)"
R°F°F = "(R°-459.67)"
N°F°F = "(N°*((300/99)*9/5)+32)"
D°F°F = "(212-(D°*1.2))"
C°R°F = "((9/5)*(C°+273.15))"
F°R°F = "(F°+459.67)"
K°R°F = "((9/5)*K°)"
N°R°F = "(491.67+(300/99)*(9/5)*N°)"
D°R°F = "((459.67+212)-D°*1.2)"
C°D°F = "(150-(C°*1.5))"
F°D°F = "(212-F°)/1.2"
K°D°F = "(459.67+100)-(K°*1.5)"
N°D°F = "150-(N°*(300/99)*1.5)"
R°D°F = "(459.67+100)-(R°*(1/1.2))"
C°N°F = "(C°*1/3)"
F°N°F = "(F°*((32/((300/99)*(9/5)))/32))-(32/((300/99)*(9/5)))"
K°N°F = "K°*1/3-(273.15/3)"
R°N°F = "((32/((300/99)*(9/5)))/32)*(R°-491.67)"
D°N°F = "(150*0.22)-(D°*0.22)"
C°C°F = "C°"
F°F°F = "F°"
K°K°F = "K°"
N°N°F = "N°"
D°D°F = "D°"
R°R°F = "R°"
Seçenek = HD
Select Case Seçenek

Case "C°": SÇF = VBA.Switch(KD & HD = "F°C°", F°C°F, KD & HD = "K°C°", K°C°F, KD & HD = "R°C°", R°C°F, KD & HD = "N°C°", N°C°F, KD & HD = "D°C°", D°C°F, KD & HD = "C°C°", C°C°F)
Case "K°": SÇF = VBA.Switch(KD & HD = "C°K°", C°K°F, KD & HD = "F°K°", F°K°F, KD & HD = "R°K°", R°K°F, KD & HD = "N°K°", N°K°F, KD & HD = "D°K°", D°K°F, KD & HD = "K°K°", K°K°F)
Case "F°": SÇF = VBA.Switch(KD & HD = "C°F°", C°F°F, KD & HD = "K°F°", K°F°F, KD & HD = "R°F°", R°F°F, KD & HD = "N°F°", N°F°F, KD & HD = "D°F°", D°F°F, KD & HD = "F°F°", F°F°F)
Case "R°": SÇF = VBA.Switch(KD & HD = "C°R°", C°R°F, KD & HD = "F°R°", F°R°F, KD & HD = "K°R°", K°R°F, KD & HD = "N°R°", N°R°F, KD & HD = "D°R°", D°R°F, KD & HD = "R°R°", R°R°F)
Case "D°": SÇF = VBA.Switch(KD & HD = "C°D°", C°D°F, KD & HD = "F°D°", F°D°F, KD & HD = "K°D°", K°D°F, KD & HD = "N°D°", N°D°F, KD & HD = "R°D°", R°D°F, KD & HD = "D°D°", D°D°F)
Case "N°": SÇF = VBA.Switch(KD & HD = "C°N°", C°N°F, KD & HD = "F°N°", F°N°F, KD & HD = "K°N°", K°N°F, KD & HD = "R°N°", R°N°F, KD & HD = "D°N°", D°N°F, KD & HD = "N°N°", N°N°F)

End Select

End Function

'Module1

Option Explicit
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Public Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As Any, ByRef ppvRet As Any) As Long
Public IPic(15) As Byte
Public Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}" 'It may take a few seconds, please wait.
Public Const URL1 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S7rn6KHVfNI/AAAAAAAACRs/fxVMg9YGzb4/s1600/VectorBackround.jpg" 'Microsoft Office Excel® Kod Klavuzu [Vector Backround]
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg" 'Microsoft Office Excel® Kod Kılavuzu [PBİD Icon]
Public URL As String
Sub FormAç() 'Open UserForm

On Error Resume Next
Load UserForm1

End Sub
Public Function Resim(URL) As Picture 'Picture load frome web address...

On Error Resume Next
CLSIDFromString StrPtr(ClsID), IPic(0)
OleLoadPicturePath StrPtr(URL), 0&, 0&, 0&, IPic(0), Resim

End Function
'Sub References_List()

' On Error Resume Next
' Dim Eleman, No
' No = 1
' For Each Eleman In ThisWorkbook.VBProject.References

' Sheets(1).Cells(No, 1) = No & ") Name: "
' Sheets(1).Cells(No, 2) = Eleman.Name
' Sheets(1).Cells(No, 3) = ", Description: "
' Sheets(1).Cells(No, 4) = Eleman.Description
' Sheets(1).Cells(No, 5) = ", FullPath: "
' Sheets(1).Cells(No, 6) = Eleman.FullPath
' No = No + 1

' Next Eleman

'End Sub

'Class1

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal ClassName As String, ByVal WindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal Index As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal Index As Long, ByVal NewLong As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Const PDSM As Long = &H80000 'Pencere Düzeni Sistem Menülü
Private Const PDTD As Long = &H30000 'Pencere Düzeni Tam Düğmeli
Private Const PDKD As Long = &H20000 'Pencere Düzeni Küçültme Düğmeli
Private Const PDBD As Long = &H10000 'Pencere Düzeni Büyültme Düğmeli
Private Const PDDÇ As Long = &H1 'Pencere Düzeni DiyalogÇerçeveli (Excel 4.0)
Private Const PDEA As Long = &H80 'Pencere Düzeni Eski Araçlı
Private Const PDYÇ As Long = -16 'Pencere Düzeni Yeni Çağırmalı
Private Const PDEÇ As Long = -20 'Pencere Düzeni Eski Çağırmalı
Private Const PDGA As Long = 3 'Pencere Düzeni Geniş Açmalı
Private Const PDNA As Long = 5 'Pencere Düzeni Normal Açmalı
Private Pencere As Long, Çerçeve As Long
Private Resimlik As New ImageList
Private Simge
Public Property Set ResimEkle(ByVal Ekran As Object)

On Error Resume Next
Resimlik.ListImages.Add 1, "R1", LoadPicture("C:\Program Files\Microsoft Office\OFFICE11\MSN.ico")
Simge = Resimlik.ListImages(1).Picture
If Val(Application.Version) = 8 Then

Pencere = FindWindow("ThunderXFrame", Ekran.Caption)

Else

Pencere = FindWindow("ThunderDFrame", Ekran.Caption)

End If
If Pencere = 0 Then Exit Property
SendMessage Pencere, PDEA, True, Simge: SendMessage Pencere, PDEA, False, Simge
Çerçeve = GetWindowLong(Pencere, PDEÇ): Çerçeve = Çerçeve And Not PDDÇ
SetWindowLong Pencere, PDEÇ, Çerçeve
DrawMenuBar Pencere

End Property
Public Property Set Ekran1(ByVal Ekran As Object) '[+][-][+]

On Error Resume Next
Pencere = FindWindow(vbNullString, Ekran.Caption)
Çerçeve = GetWindowLong(Pencere, (PDYÇ)) Or PDKD
SetWindowLong Pencere, (PDYÇ), Çerçeve
ShowWindow Pencere, PDNA
DrawMenuBar Pencere

End Property