kembalilah ke MS Excel
Rename sheet 1 menjadi AWWAL dan sheet2 menjadi TSANI
kode form di atas adalah sebagai berikut
Private Sub CMDHT_Click()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("TSANI")
'menemukan baris kosong pada database
iRow = ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1,
0).Row
'check untuk sebuah kota
If Trim(Me.TKOTA.Value) = "" Then
Me.TKOTA.SetFocus
MsgBox "NAMA
KOTANYA GUS"
Exit Sub
End If
KOTA
= Me.TKOTA.Value
'memasukkan dalam variabel
DLIN = Me.TDL.Value
MLIN = Me.TML.Value
SLIN = Me.TSL.Value
'mengubah menjadi desimal
lintang = Abs(DLIN) + MLIN / 60 + SLIN / 3600
If DLIN < 0 Then
lintang = lintang * -1
lintang = lintang
End If
'mengubah menjadi DMS
LINTANGDMS = DMS(lintang)
'memasukkan dalam variabel
DBU = Me.TDB.Value
MBU = Me.TMB.Value
SBU = Me.TSB.Value
'mengubah menjadi desimal
bujur = Abs(DBU) + MBU / 60 + SBU / 3600
If DBU < 0 Then
bujur = bujur * -1
bujur = bujur
End If
'mengubah menjadi DMS
BUJURDMS = DMS(bujur)
'perhitungan arah qiblat
Pi = Application.Pi()
r = 180 / Pi
lintangmakkah = 21 + 25 / 60 + 14 / 3600
bujurmakkah = 39 + 49 / 60 + 41 / 3600
'PENGUJUIAN POSISI I
If bujur = bujurmakkah Then
Select Case
lintang
Case Is = lintangmakkah
QIBLATK =
"KA'BAH SENDIRI"
ket1 =
""
ket2 =
""
Case Is > lintangmakkah
QIBLATK =
"SELATAN"
ket1 =
""
ket2 =
""
Case Else
QIBLATK =
"UTARA"
ket1 =
""
ket2 =
""
End Select
ElseIf bujur = bujurmakkah + 180 - 360 Then
Select Case
lintang
Case Is = -lintangmakkah
QIBLATK =
"SEGALA ARAH"
ket1 =
""
ket2 =
""
Case Is < -lintangmakkah
QIBLATK =
"SELATAN"
ket1 =
""
ket2 =
""
Case Else
QIBLATK =
"UTARA"
ket1 =
""
ket2 =
""
End Select
Else
selisihbujur = bujurmakkah - bujur
jarakr = Application.Acos(Cos(lintang / r) * Cos(lintangmakkah
/ r) * Cos(selisihbujur / r) + Sin(lintang / r) * Sin(lintangmakkah / r))
jarak = jarakr * r
qiblatr = Application.Asin((Sin(lintangmakkah / r) - Cos(jarakr)
* Sin(lintang / r)) / (Cos(lintang / r) * Sin(jarakr)))
QIBLATDES = qiblatr * r
QIBLATK = DMS(QIBLATDES)
End If
'PENGUJIAN POSISI II
'TEPAT ARAH BARAT/TIMUR
BTr = Atn(Tan(lintangmakkah / r) / Cos(selisihbujur
/ r))
BT = BTr * r
If bujur > bujurmakkah Then
ket1 = "BARAT - "
Else
ket1 = "TIMUR - "
End If
If lintang > BT Then
ket2 = "SELATAN"
Else
ket2 = "UTARA"
End If
URUT = iRow - 2
'copy data ke database
ws.Cells(iRow, 1).Value = URUT
ws.Cells(iRow, 2).Value = KOTA
ws.Cells(iRow, 3).Value = LINTANGDMS
ws.Cells(iRow, 4).Value = BUJURDMS
ws.Cells(iRow, 5).Value = QIBLATK & " " & ket1
& ket2
MsgBox "QIBLAT " & KOTA & " ADALAH :" & QIBLATK
& " " & ket1 & ket2
Sheets("TSANI").Select
'clear data
Me.TKOTA.Value = ""
Me.TDL.Value = ""
Me.TML.Value = ""
Me.TSL.Value = ""
Me.TDB.Value = ""
Me.TMB.Value = ""
Me.TSB.Value = ""
Me.TKOTA.SetFocus
End Sub
Private Sub CMDTTP_Click()
Sheets("AWWAL").Select
MsgBox " Alhamdulillah"
Unload Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, _
CloseMode As Integer)
If CloseMode = vbFormControlMenu
Then
Cancel = True
MsgBox "MAKE TOMBOL
AJA YA GUS!"
End If
End Sub
'fungsi dms
Function DMS(y)
x = Abs(y)
derajat = Int(x)
If y < 0 Then
derajat = derajat * -1
derajat = derajat
End If
menit = Int(60 * x) Mod 60
sekonasal = 3600 * x
sekonutuh = Int(sekonasal)
sekonpecah = Round((sekonasal - sekonutuh), 2)
sekon = sekonutuh Mod 60 + sekonpecah
DMS = derajat & Chr(176) & " " & menit
& Chr(39) & " " & sekon & Chr(34)
End Function
kemudian kembali ke MS Excel buatlah tombol commaand Button untuk mrmunculkan form di atas dengan kode sebagai berikut :
Private Sub CMDMULAI_Click()
MsgBox "bismillaahirrohmanirrohiim"
UserForm1.Show
End Sub
MsgBox "bismillaahirrohmanirrohiim"
UserForm1.Show
End Sub
untuk file nya silakan download di :
Tidak ada komentar:
Posting Komentar