Showing posts with label String-Manipulation. Show all posts
Showing posts with label String-Manipulation. Show all posts

Tuesday, October 1, 2013

VB6 Hash Class - MD5 , SHA-1, SHA-256, SHA-384, SHA-512

VB6 Hash Class - MD5 , SHA-1, SHA-256, SHA-384, SHA-512
Option Explicit

Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" _
(ByRef phProv As Long, ByVal pszContainer As String, ByVal pszProvider As String, _
ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32.dll" _
(ByVal hProv As Long, ByVal Algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, _
ByRef phHash As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32.dll" _
(ByVal hHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32.dll" _
(ByVal hHash As Long, pbData As Any, ByVal cbData As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32.dll" _
(ByVal hHash As Long, ByVal dwParam As Long, pbData As Any, ByRef pcbData As Long, _
ByVal dwFlags As Long) As Long

Private Const PROV_RSA_FULL As Long = 1
Private Const PROV_RSA_AES As Long = 24
Private Const CRYPT_VERIFYCONTEXT As Long = &HF0000000

Private Const HP_HASHVAL As Long = 2
Private Const HP_HASHSIZE As Long = 4

Private Const ALG_TYPE_ANY As Long = 0
Private Const ALG_CLASS_HASH As Long = 32768

Private Const ALG_SID_MD2 As Long = 1
Private Const ALG_SID_MD4 As Long = 2
Private Const ALG_SID_MD5 As Long = 3
Private Const ALG_SID_SHA As Long = 4
Private Const ALG_SID_SHA_256 As Long = 12
Private Const ALG_SID_SHA_384 As Long = 13
Private Const ALG_SID_SHA_512 As Long = 14

Private Const CALG_MD2 As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD2)
Private Const CALG_MD4 As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD4)
Private Const CALG_MD5 As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5)
Private Const CALG_SHA As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA)
Private Const CALG_SHA_256 As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_256)
Private Const CALG_SHA_384 As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_384)
Private Const CALG_SHA_512 As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_512)

' Create Hash
Private Function CreateHash(abytData() As Byte, ByVal lngAlgID As Long) As String
Dim hProv As Long, hHash As Long
Dim abytHash(0 To 63) As Byte
Dim lngLength As Long
Dim lngResult As Long
Dim strHash As String
Dim i As Long
strHash = ""
If CryptAcquireContext(hProv, vbNullString, vbNullString, _
IIf(lngAlgID >= CALG_SHA_256, PROV_RSA_AES, PROV_RSA_FULL), _
CRYPT_VERIFYCONTEXT) <> 0& Then
If CryptCreateHash(hProv, lngAlgID, 0&, 0&, hHash) <> 0& Then
lngLength = UBound(abytData()) - LBound(abytData()) + 1
If lngLength > 0 Then lngResult = CryptHashData(hHash, abytData(LBound(abytData())), lngLength, 0&) _
Else lngResult = CryptHashData(hHash, ByVal 0&, 0&, 0&)
If lngResult <> 0& Then
lngLength = UBound(abytHash()) - LBound(abytHash()) + 1
If CryptGetHashParam(hHash, HP_HASHVAL, abytHash(LBound(abytHash())), lngLength, 0&) <> 0& Then
For i = 0 To lngLength - 1
strHash = strHash & Right$("0" & Hex$(abytHash(LBound(abytHash()) + i)), 2)
Next
End If
End If
CryptDestroyHash hHash
End If
CryptReleaseContext hProv, 0&
End If
CreateHash = LCase$(strHash)
End Function

' Create Hash From String(Shift_JIS)
Private Function CreateHashString(ByVal strData As String, ByVal lngAlgID As Long) As String
CreateHashString = CreateHash(StrConv(strData, vbFromUnicode), lngAlgID)
End Function

' Create Hash From File
Private Function CreateHashFile(ByVal strFileName As String, ByVal lngAlgID As Long) As String
Dim abytData() As Byte
Dim intFile As Integer
Dim lngError As Long
On Error Resume Next
If Len(Dir(strFileName)) > 0 Then
intFile = FreeFile
Open strFileName For Binary Access Read Shared As #intFile
abytData() = InputB(LOF(intFile), #intFile)
Close #intFile
End If
lngError = Err.Number
On Error GoTo 0
If lngError = 0 Then CreateHashFile = CreateHash(abytData(), lngAlgID) _
Else CreateHashFile = ""
End Function

' MD5
Public Function CreateMD5Hash(abytData() As Byte) As String
CreateMD5Hash = CreateHash(abytData(), CALG_MD5)
End Function
Public Function CreateMD5HashString(ByVal strData As String) As String
CreateMD5HashString = CreateHashString(strData, CALG_MD5)
End Function
Public Function CreateMD5HashFile(ByVal strFileName As String) As String
CreateMD5HashFile = CreateHashFile(strFileName, CALG_MD5)
End Function

' SHA-1
Public Function CreateSHA1Hash(abytData() As Byte) As String
CreateSHA1Hash = CreateHash(abytData(), CALG_SHA)
End Function
Public Function CreateSHA1HashString(ByVal strData As String) As String
CreateSHA1HashString = CreateHashString(strData, CALG_SHA)
End Function
Public Function CreateSHA1HashFile(ByVal strFileName As String) As String
CreateSHA1HashFile = CreateHashFile(strFileName, CALG_SHA)
End Function

' SHA-256
Public Function CreateSHA256Hash(abytData() As Byte) As String
CreateSHA256Hash = CreateHash(abytData(), CALG_SHA_256)
End Function
Public Function CreateSHA256HashString(ByVal strData As String) As String
CreateSHA256HashString = CreateHashString(strData, CALG_SHA_256)
End Function
Public Function CreateSHA256HashFile(ByVal strFileName As String) As String
CreateSHA256HashFile = CreateHashFile(strFileName, CALG_SHA_256)
End Function

' SHA-384
Public Function CreateSHA384Hash(abytData() As Byte) As String
CreateSHA384Hash = CreateHash(abytData(), CALG_SHA_384)
End Function
Public Function CreateSHA384HashString(ByVal strData As String) As String
CreateSHA384HashString = CreateHashString(strData, CALG_SHA_384)
End Function
Public Function CreateSHA384HashFile(ByVal strFileName As String) As String
CreateSHA384HashFile = CreateHashFile(strFileName, CALG_SHA_384)
End Function

' SHA-512
Public Function CreateSHA512Hash(abytData() As Byte) As String
CreateSHA512Hash = CreateHash(abytData(), CALG_SHA_512)
End Function
Public Function CreateSHA512HashString(ByVal strData As String) As String
CreateSHA512HashString = CreateHashString(strData, CALG_SHA_512)
End Function
Public Function CreateSHA512HashFile(ByVal strFileName As String) As String
CreateSHA512HashFile = CreateHashFile(strFileName, CALG_SHA_512)
End Function

Keywords: vb6, md5, hash, function, sha256, hashing, in, vb, sha512, generator, sha1, sha, vba, algorithm, sha512.dll

READ MORE - VB6 Hash Class - MD5 , SHA-1, SHA-256, SHA-384, SHA-512

Sunday, June 17, 2012

Encode Decode Base64 Menggunakan MSXML

Public Function Base64Enc(ByRef vxbData() As Byte) As String
With CreateObject("MSXML.DOMDocument").CreateElement(" Base64 ")
.DataType = "bin.base64"
.NodeTypedValue = vxbData
Base64Enc = .Text
End With
End Function

Public Function Base64Dec(ByRef vsData As String) As Byte()
With CreateObject("MSXML.DOMDocument").CreateElement("Base64")
.DataType = "bin.base64"
.Text = vsData
Base64Dec = .NodeTypedValue
End With
End Function
READ MORE - Encode Decode Base64 Menggunakan MSXML

Penyimpanan URL Seperti Pada Blogger - Blogspot

Private Function BloggerTitle(Title As String) As String
Dim strCaption() As String
strCaption = Split(Title, " ")
Dim i As Integer
Dim o As String
For i = 0 To UBound(strCaption)
If Len(Trim$(o) & " " & strCaption(i)) < 40 Then
o = Trim$(o) & " " & strCaption(i)
Else
Exit For
End If
Next
BloggerTitle = LCase(Replace(Trim$(o), " ", "-"))
End Function
READ MORE - Penyimpanan URL Seperti Pada Blogger - Blogspot

Spin Artikel Bahasa Indonesia

Apa yang dimaksud artikel spin/spin artikel/article spinner? bisa Anda baca di sini. Dengan kata lain artikel spin adalah mengganti kata dengan menggunakan sinonim dari kata tersebut secara besar-besaran. Tujuannya? Mengecoh mesin pencari agar artikel yang kita duplikatkan (copy paste) berubah menjadi sebuah konten unik menurut pengamatan robot/mesin pencari (bukan menurut pengamatan manusia). Contoh:

Saya akan pergi ke pasar. berubah menjadi
Ana berencana berangkat ke pasar. atau
Ane mau pergi ke pasar. atau
Aku berencana pergi ke pasar. atau
Gue akan berangkat ke pasar. atau
gw mo pergi ke pasar. atau
dan seterusnya. dan seterusnya.

Bukankah seluruh kalimat di atas tersebut unik menurut versi mesin pencari? Nah, bagaimana menurut versi manusia (saya dan Anda)?

Spin artikel bisa dikategorikan sebagai sebuah teknik SEO yang sedikit hitam yang dapat menyebabkan banyaknya duplikasi konten/sampah menurut pengamatan manusia. Tetapi dalam dunia sales online/reseller/affeliate hal ini tidak bisa dihindari. Ya saya ulangi, dalam dunia sales online hal ini tidak bisa dihindari. Satu produk dengan merk yang sama dijual oleh ribuah atau jutaan orang secara online.

Di bawah ini merupakan contoh kode spin artikel bahasa indonesia dengan menggunakan 5 kata dan sinonimnya (seharusnya 5000 kata beserta sinonimnya), yakni saya, pergi, blogger, gmail, akan.
Option Explicit 

Private Function
ChooseWord(choice As Variant, bWord, Optional bUnik As Boolean) As String

Dim i As Integer
Dim
strSpin() As String, strChooseWord As String
strSpin = Split(choice, ",")
If Not bUnik Then
Randomize
i =
CInt((UBound(strSpin) * Rnd) + 1)
strChooseWord = strSpin(i - 1)
Else
Do
Randomize
i =
CInt((UBound(strSpin) * Rnd) + 1)
strChooseWord = strSpin(i - 1)
Loop While strChooseWord = bWord
End If
ChooseWord = strChooseWord

End Function

Private Sub
cmdDoSpin_Click()
Dim strResult As String
Dim
strSource As String
strResult = txtResult.Text
strSource = txtSource.Text

strResult = LCase(strSource)

Dim
arrWord() As String
ReDim
arrWord(4) 'gantilah menjadi 40, 400, atau 4000
'apabila algoritmanya telah dimodif dan mantap maka
'tambahkan sinonim menjadi 40, 400, atau 4000
arrWord(0) = "saya, aku, ane, ana"
arrWord(1) = "pergi, berangkat"
arrWord(2) = " akan, berencana"
arrWord(3) = "blogger, blogspot, blog milik google (blogspot)"
arrWord(4) = "gmail, gmail.com, google mail, layanan email milik google (gmail)"
'--------------------------------------------------------
Dim i As Integer, k As Integer

For i =
LBound(arrWord) To UBound(arrWord)
Dim strSpin() As String
strSpin = Split(arrWord(i), ",")
For k = LBound(strSpin) To UBound(strSpin)
If InStr(1, strSource, strSpin(k)) > 0 Then
strResult = Replace(strResult, strSpin(k), ChooseWord(arrWord(i), strSpin(k), Check1.Value = 1))
Exit For
End If
Next
Next
txtResult.Text = Trim$(strResult)
End Sub

Cobalah Anda kembangkan. Semoga kode spin artikel bahasa indonesia di atas bermanfaat. Terima kasih atas kunjungannya.
READ MORE - Spin Artikel Bahasa Indonesia

Asc: Mengenal Fungsi String VB6

Asc - Kegunaan fungsi string dalam VB6.

Kegunaan Asc dalam VB6:

Fungsi Asc berguna untuk memperoleh nilai angka yang merupakan kode ANSI dari sebuah string.

Contoh Asc dalam VB6:

    txtHasil.Text = Asc("A") 'maka akan memperoleh nilai 65
'demikian juga
txtHasil.Text = Asc("AAA") 'maka akan memperoleh nilai 65
'demikian juga
txtHasil.Text = Asc("AB") 'akan memperoleh nilai 65

Catatan mengenai Asc dalam VB6:

Dari ketiga contoh di atas yang menjadi patokan adalah karakter pertama, selanjutnya karakter pertama tersebut akan dirubah menjadi kode ANSI berupa angka, yang secara kebetulan dalam contoh di atas adalah karakter A dan kode ANSI untuk karakter A adalah 65.

Demikian fungsi string Asc dalam VB6, semoga bermanfaat bagi mereka yang sedang ingin mengetahui fungsi-fungsi string dalam VB6 khususnya fungsi string Asc.

READ MORE - Asc: Mengenal Fungsi String VB6

LCase: Mengenal Fungsi String VB6

LCase - Mengenal fungsi-fungsi string dalam VB6

 Kegunaan LCase dalam VB6:

Fungsi LCase berguna untuk mengkonversi seluruh string menjadi huruf kecil.

Contoh LCase dalam VB6:

    Msgbox LCase("Jakarta Bandung") 'maka jakarta bandung
Demikian kegunaan fungsi string LCase dalam VB6, semoga bermanfaat.
READ MORE - LCase: Mengenal Fungsi String VB6

Filter: Mengenal Fungsi String VB6

Filter- Kegunaan fungsi string dalam VB6.

Kegunaan Filter dalam VB6:

Fungsi Filter berguna untuk memfilter sebuah array (include atau exclude).

Contoh Filter dalam VB6:

Option Explicit

'Contoh include (memperoleh string yang sama dengan "B" dari arrTest)
'dan case-sensitive (memperdulikan apakah B huruf besar atau huruf kecil)
Private Sub cmdEvaluate_Click()
Dim arrTest() As String
Dim arrMatch() As String

arrTest = Split("A,B,C,D,B,B,B,B,B,B,B,C", ",")
arrMatch = Filter(arrTest, "B", True)

MsgBox "Banyaknya string yang sesuai: " & UBound(arrMatch)
txtResult.Text = arrMatch(0) & " " & arrMatch(1) & " " & arrMatch(2) & " " & arrMatch(3)
End Sub

'Contoh include (memperoleh string yang sama dengan "B" dari arrTest)
'dan case-insensitive (tidak memperdulikan apakah B huruf besar atau huruf kecil)
Private Sub cmdEvaluate_Click()
Dim arrTest() As String
Dim arrMatch() As String

arrTest = Split("A,B,C,D,B,B,B,B,B,B,B,C", ",")
arrMatch = Filter(arrTest, "B", True, vbTextCompare)

MsgBox "Banyaknya string yang sesuai: " & UBound(arrMatch)
txtResult.Text = arrMatch(0) & " " & arrMatch(1) & " " & arrMatch(2) & " " & arrMatch(3)
End Sub

'contoh exclude (memperoleh string yang tidak sama dengan "B" dari arrTest)
Private Sub cmdEvaluate_Click()
Dim arrTest() As String
Dim arrMatch() As String

arrTest = Split("A,B,C,D,B,B,B,B,B,B,B,C", ",")
arrMatch = Filter(arrTest, "B", False)

MsgBox "Banyaknya string yang sesuai: " & UBound(arrMatch)
txtResult.Text = arrMatch(0) & " " & arrMatch(1) & " " & arrMatch(2) & " " & arrMatch(3)
End Sub
Demikian contoh fungsi string Filter sebuah Array dalam VB6.
READ MORE - Filter: Mengenal Fungsi String VB6

Chr: Mengenal Fungsi String VB6

Chr - Kegunaan fungsi string dalam VB6.

Kegunaan Chr dalam VB6:

Fungsi Chr berguna untuk memperoleh string dari kode karakter.

Contoh Chr dalam VB6:

    txtHasil.Text = Chr(65)    ' akan memperoleh A.
txtHasil.Text = Chr(97) ' akan memperoleh a.
txtHasil.Text = Chr(62) ' akan memperoleh >.
txtHasil.Text = Chr(37) ' akan memperoleh %.
Demikian fungsi string Chr dalam VB6, semoga bermanfaat.
READ MORE - Chr: Mengenal Fungsi String VB6

Right: Mengenal Fungsi String Dalam VB6

Right- Mengenal fungsi-fungsi string dalam VB6

Kegunaan Right dalam VB6:

Fungsi Right berguna untuk memperoleh string dari kiri ke kanan sejumlah yang telah ditentukan

Contoh Right dalam VB6:

Private Sub cmdEvaluate_Click()
MsgBox Right("abcdefghijklmnopqrstu", 1) 'akan memperoleh "u"
MsgBox Right("abcdefghijklmnopqrstu", 2) 'akam memperoleh "tu"
MsgBox Right("abcdefghijklmnopqrstu", 3) 'akan memperoleh "stu"
MsgBox Right("abcdefghijklmnopqrstu", 4) 'akan memperoleh "rstu"
MsgBox Right("abcdefghijklmnopqrstu", 5) 'akan memperoleh "qratu"

'dan seterusnya
End Sub
Demikian kegunaan fungsi string Right dalam VB6, semoga bermanfaat.
READ MORE - Right: Mengenal Fungsi String Dalam VB6

Left: Mengenal Fungsi String Dalam VB6

Left - Mengenal fungsi-fungsi string dalam VB6

 Kegunaan Left dalam VB6:

Fungsi LCase berguna untuk memperoleh string dari kiri ke kanan sejumlah yang telah ditentukan

Contoh Left dalam VB6:

Private Sub cmdEvaluate_Click()
    MsgBox Left("abcdefghijklmnopqrstu", 1) 'akan memperoleh "a"
    MsgBox Left("abcdefghijklmnopqrstu", 2) 'akam memperoleh "ab"
    MsgBox Left("abcdefghijklmnopqrstu", 3) 'akan memperoleh "abc"
    MsgBox Left("abcdefghijklmnopqrstu", 4) 'akan memperoleh "abcd"
    MsgBox Left("abcdefghijklmnopqrstu", 5) 'akan memperoleh "abcde"



'dan seterusnya
End Sub
Demikian kegunaan fungsi string Left dalam VB6, semoga bermanfaat.
READ MORE - Left: Mengenal Fungsi String Dalam VB6

UCase: Mengenal Fungsi String VB6

UCase - Mengenal fungsi-fungsi string dalam VB6

 Kegunaan UCase dalam VB6:

Fungsi UCase berguna untuk mengkonversi seluruh string menjadi huruf besar.

Contoh UCase dalam VB6:

    Msgbox LCase("Jakarta Bandung") 'maka akan menjadi JAKARTA BANDUNG
Demikian kegunaan fungsi string UCase dalam VB6, semoga bermanfaat.
READ MORE - UCase: Mengenal Fungsi String VB6

Encode-Decode String Base64 Secara Cepat

Option Explicit

Private Const clOneMask = 16515072 '000000 111111 111111 111111
Private Const clTwoMask = 258048 '111111 000000 111111 111111
Private Const clThreeMask = 4032 '111111 111111 000000 111111
Private Const clFourMask = 63 '111111 111111 111111 000000

Private Const clHighMask = 16711680 '11111111 00000000 00000000
Private Const clMidMask = 65280 '00000000 11111111 00000000
Private Const clLowMask = 255 '00000000 00000000 11111111

Private Const cl2Exp18 = 262144 '2 to the 18th power
Private Const cl2Exp12 = 4096 '2 to the 12th
Private Const cl2Exp6 = 64 '2 to the 6th
Private Const cl2Exp8 = 256 '2 to the 8th
Private Const cl2Exp16 = 65536 '2 to the 16th

Public Function Encode64(sString As String) As String

Dim bTrans(63) As Byte, lPowers8(255) As Long, lPowers16(255) As Long, bOut() As Byte, bIn() As Byte
Dim lChar As Long, lTrip As Long, iPad As Integer, lLen As Long, lTemp As Long, lPos As Long, lOutSize As Long

For lTemp = 0 To 63 'Fill the translation table.
Select Case lTemp
Case 0 To 25
bTrans(lTemp) = 65 + lTemp 'A - Z
Case 26 To 51
bTrans(lTemp) = 71 + lTemp 'a - z
Case 52 To 61
bTrans(lTemp) = lTemp - 4 '1 - 0
Case 62
bTrans(lTemp) = 43 'Chr(43) = "+"
Case 63
bTrans(lTemp) = 47 'Chr(47) = "/"
End Select
Next lTemp

For lTemp = 0 To 255 'Fill the 2^8 and 2^16 lookup tables.
lPowers8(lTemp) = lTemp * cl2Exp8
lPowers16(lTemp) = lTemp * cl2Exp16
Next lTemp

iPad = Len(sString) Mod 3 'See if the length is divisible by 3
If iPad Then 'If not, figure out the end pad and resize the input.
iPad = 3 - iPad
sString = sString & String(iPad, Chr(0))
End If

bIn = StrConv(sString, vbFromUnicode) 'Load the input string.
lLen = ((UBound(bIn) + 1) \ 3) * 4 'Length of resulting string.
lTemp = lLen \ 72 'Added space for vbCrLfs.
lOutSize = ((lTemp * 2) + lLen) - 1 'Calculate the size of the output buffer.
ReDim bOut(lOutSize) 'Make the output buffer.

lLen = 0 'Reusing this one, so reset it.

For lChar = LBound(bIn) To UBound(bIn) Step 3
lTrip = lPowers16(bIn(lChar)) + lPowers8(bIn(lChar + 1)) + bIn(lChar + 2) 'Combine the 3 bytes
lTemp = lTrip And clOneMask 'Mask for the first 6 bits
bOut(lPos) = bTrans(lTemp \ cl2Exp18) 'Shift it down to the low 6 bits and get the value
lTemp = lTrip And clTwoMask 'Mask for the second set.
bOut(lPos + 1) = bTrans(lTemp \ cl2Exp12) 'Shift it down and translate.
lTemp = lTrip And clThreeMask 'Mask for the third set.
bOut(lPos + 2) = bTrans(lTemp \ cl2Exp6) 'Shift it down and translate.
bOut(lPos + 3) = bTrans(lTrip And clFourMask) 'Mask for the low set.
If lLen = 68 Then 'Ready for a newline
bOut(lPos + 4) = 13 'Chr(13) = vbCr
bOut(lPos + 5) = 10 'Chr(10) = vbLf
lLen = 0 'Reset the counter
lPos = lPos + 6
Else
lLen = lLen + 4
lPos = lPos + 4
End If
Next lChar

If bOut(lOutSize) = 10 Then lOutSize = lOutSize - 2 'Shift the padding chars down if it ends with CrLf.

If iPad = 1 Then 'Add the padding chars if any.
bOut(lOutSize) = 61 'Chr(61) = "="
ElseIf iPad = 2 Then
bOut(lOutSize) = 61
bOut(lOutSize - 1) = 61
End If

Encode64 = StrConv(bOut, vbUnicode) 'Convert back to a string and return it.

End Function

Public Function Decode64(sString As String) As String

Dim bOut() As Byte, bIn() As Byte, bTrans(255) As Byte, lPowers6(63) As Long, lPowers12(63) As Long
Dim lPowers18(63) As Long, lQuad As Long, iPad As Integer, lChar As Long, lPos As Long, sOut As String
Dim lTemp As Long

sString = Replace(sString, vbCr, vbNullString) 'Get rid of the vbCrLfs. These could be in...
sString = Replace(sString, vbLf, vbNullString) 'either order.

lTemp = Len(sString) Mod 4 'Test for valid input.
If lTemp Then
Call Err.Raise(vbObjectError, "MyDecode", "Input string is not valid Base64.")
End If

If InStrRev(sString, "==") Then 'InStrRev is faster when you know it's at the end.
iPad = 2 'Note: These translate to 0, so you can leave them...
ElseIf InStrRev(sString, "=") Then 'in the string and just resize the output.
iPad = 1
End If

For lTemp = 0 To 255 'Fill the translation table.
Select Case lTemp
Case 65 To 90
bTrans(lTemp) = lTemp - 65 'A - Z
Case 97 To 122
bTrans(lTemp) = lTemp - 71 'a - z
Case 48 To 57
bTrans(lTemp) = lTemp + 4 '1 - 0
Case 43
bTrans(lTemp) = 62 'Chr(43) = "+"
Case 47
bTrans(lTemp) = 63 'Chr(47) = "/"
End Select
Next lTemp

For lTemp = 0 To 63 'Fill the 2^6, 2^12, and 2^18 lookup tables.
lPowers6(lTemp) = lTemp * cl2Exp6
lPowers12(lTemp) = lTemp * cl2Exp12
lPowers18(lTemp) = lTemp * cl2Exp18
Next lTemp

bIn = StrConv(sString, vbFromUnicode) 'Load the input byte array.
ReDim bOut((((UBound(bIn) + 1) \ 4) * 3) - 1) 'Prepare the output buffer.

For lChar = 0 To UBound(bIn) Step 4
lQuad = lPowers18(bTrans(bIn(lChar))) + lPowers12(bTrans(bIn(lChar + 1))) + _
lPowers6(bTrans(bIn(lChar + 2))) + bTrans(bIn(lChar + 3)) 'Rebuild the bits.
lTemp = lQuad And clHighMask 'Mask for the first byte
bOut(lPos) = lTemp \ cl2Exp16 'Shift it down
lTemp = lQuad And clMidMask 'Mask for the second byte
bOut(lPos + 1) = lTemp \ cl2Exp8 'Shift it down
bOut(lPos + 2) = lQuad And clLowMask 'Mask for the third byte
lPos = lPos + 3
Next lChar

sOut = StrConv(bOut, vbUnicode) 'Convert back to a string.
If iPad Then sOut = Left$(sOut, Len(sOut) - iPad) 'Chop off any extra bytes.
Decode64 = sOut

End Function
READ MORE - Encode-Decode String Base64 Secara Cepat

LTrim - RTrim - Trim: Mengenal Fungsi String Dalam VB6

LTrim - RTrim - Trim - Mengenal fungsi-fungsi string dalam VB6

Kegunaan LTrim - RTrim - Trim dalam VB6:

Fungsi LTrim berguna untuk menghilangkan spasi yang ada di sebelah kiri.
Fungsi RTrim berguna untuk menghilangkan spasi yang ada di sebelah kanan.
Fungsi Trim berguna untuk menghilangkan spasi di sebelah kiri dan kanan.

Contoh LTrim - RTrim - Trim dalam VB6:

Private Sub cmdEvaluate_Click()
MsgBox (" abc ") 'dengan spasi di kiri dan di kanan
MsgBox LTrim(" abc ") 'menjadi "abc " menghilangkan spasi kiri
MsgBox RTrim(" abc ") 'menjadi " abc" menghilangkan spasi kanan
MsgBox Trim(" abc ") 'menjadi "abc" menghilang spasi kiri dan kanan
End Sub
Demikian kegunaan fungsi string LTrim - RTrim - Trim dalam VB6, semoga bermanfaat.
READ MORE - LTrim - RTrim - Trim: Mengenal Fungsi String Dalam VB6

Mid: Mengenal Fungsi String Dalam VB6

Mid - Mengenal fungsi-fungsi string dalam VB6

Kegunaan Mid dalam VB6:

Fungsi Mid berguna untuk memperoleh string dari awal yang ditentukan dan jumlah yang ditentukan

Contoh Mid dalam VB6:

Private Sub cmdEvaluate_Click()
Debug.Print Mid("abcdefghijklmnopqrstu", 1, 1) 'akan memperoleh "a"
Debug.Print Mid("abcdefghijklmnopqrstu", 2, 1) 'akam memperoleh "b"
Debug.Print Mid("abcdefghijklmnopqrstu", 1, 3) 'akan memperoleh "abc"
Debug.Print Mid("abcdefghijklmnopqrstu", 2, 4) 'akan memperoleh "bcde"
Debug.Print Mid("abcdefghijklmnopqrstu", 2, 5) 'akan memperoleh "bcdef"

'dan seterusnya
End Sub
Demikian kegunaan fungsi string Mid dalam VB6, semoga bermanfaat.
READ MORE - Mid: Mengenal Fungsi String Dalam VB6

Tuesday, June 12, 2012

Validasi Numeric Yang Disertai Decimal Symbol - Visual Basic 6

Bagaimana logika untuk validasi numerik yang disertai angka dibelakang koma? Nah, dengan menggabungkan posting sebelumnya dan sebelumnya, maka kita memperoleh logika untuk membuat validasi numeric yang memperbolehkan angka di belakang koma. Adapun kodenya adalah sebagai berikut:
Private Sub Text1_KeyPress(KeyAscii As Integer) 
Dim intDummyDecimalSymbol As Integer
intDummyDecimalSymbol = IIf(InStr(1, Text1.Text, Chr(GetDecimalSymbol)) = 0, GetDecimalSymbol, 0)
If Not ((KeyAscii >= 48 And KeyAscii <= 57) Or KeyAscii = 8 Or KeyAscii = 45 Or KeyAscii = intDummyDecimalSymbol) Then KeyAscii = 0
End Sub

Private Function
GetDecimalSymbol() As Integer
'akan memperoleh 44 untuk koma (,) dan 46 untuk (.) dan lain sebagainya.
GetDecimalSymbol = Asc(Mid$(1 / 2, 2, 1))
End Function

Kode di atas akan sangat merepotkan, apabila harus memvalidasi banyak TextBox. Maka buatlah menjadi sederhana dengan menyimpannya pada module agar dapat diakses oleh seluruh form.
'Simpan dalam module 
Public Function GetNumericAndDecimal(txt As TextBox, Keyascii As Integer) As Integer
Dim
intDummyDecimalSymbol As Integer
intDummyDecimalSymbol = IIf(InStr(1, txt.Text, Chr(GetDecimalSymbol)) = 0, GetDecimalSymbol, 0)
If Not ((Keyascii >= 48 And Keyascii <= 57) Or Keyascii = 8 Or Keyascii = 45 Or Keyascii = intDummyDecimalSymbol) Then
GetNumericAndDecimal = 0
Else
GetNumericAndDecimal = Keyascii
End If
End Function

Public Function
GetDecimalSymbol() As Integer
'akan memperoleh 44 untuk koma (,) dan 46 untuk (.) dan lain sebagainya.
GetDecimalSymbol = Asc(Mid$(1 / 2, 2, 1))
End Function

Contoh penggunaan:
Private Sub Text1_KeyPress(KeyAscii As Integer) 
KeyAscii = GetNumericAndDecimal(Text1, KeyAscii)
End Sub



READ MORE - Validasi Numeric Yang Disertai Decimal Symbol - Visual Basic 6

Friday, June 8, 2012

Cara Membuat Prosedure Generator Nama Secara Acak (Random)

Fungsi untuk membuat nama secara random (acak) - Di bawah ini merupakan prosedur yang digunakan untuk membuat nama secara acak, fungsi ini memiliki satu parameter untuk mengatur jumlah huruf yang akan digenerate, sedangkan nilai defaultnya adalah 4 huruf. Bagaimana fungsi generator nama secara acak atau random, bisa Anda lihat di bawah ini:
Option Explicit 

Private Function
NamaAcak(Optional k As Integer = 4) As String
Dim
s(1) As String, l As String
Randomize
s(0) = ("aiueo")
s(1) = ("bcdfghjklmnpqrstvwxyz")
For i = 1 To k
l = l
& Mid(s(i Mod 2), Int((4 * Rnd) + 1), 1)
Next
NamaAcak = l
End Function
Contoh penggunaan fungsi di atas:
Private Sub Command1_Click() 
MsgBox NamaAcak(10) 'menampilkan nama acak yang memiliki jumlah huruf 10
'sedangkan contoh di bawah akan mengenerate 20 nama acak
'dengan jumlah huruf 10 karakter
Dim i As Integer
List1.Clear
For i = 1 To 20
List1.AddItem NamaAcak(6)
Next
End Sub
Apakah kegunaan dari generator nama secara acak/random ini? saya juga tidak tahu, mungkin Anda tahu?
READ MORE - Cara Membuat Prosedure Generator Nama Secara Acak (Random)

Thursday, June 7, 2012

Fungsi Personal Editor HTML Ordering List [OL]

Ini merupakan fungsi yang digunakan untuk membuat personal editor. Tag yang akan kita modifikasi adalah tag OL (Ordering List).
Option Explicit 

Function
OL(strText As String) As String
Dim
sText As String
Dim
aText() As String
Dim i As Integer
sText = strText
aText = Split(sText, vbCrLf)
For i = LBound(aText) To UBound(aText)
Select Case i
Case
LBound(aText)
sText = "<ol>" & "<li>" & aText(i) & "</li>" & vbCrLf
Case UBound(aText)
sText = sText & "<li>" & aText(i) & "</li>" & "</ol>"
Case Else
sText = sText & "<li>" & aText(i) & "</li>" & vbCrLf
End Select
Next
OL = sText
End Function
Cara penggunaan Fungsi Personal Editor HTML Ordering List <OL>
Private Sub Command1_Click() 
Text1.SelText = OL(Text1.SelText)
End Sub
READ MORE - Fungsi Personal Editor HTML Ordering List [OL]

Fungsi Personal Editor HTML Unordering List [UL]

Ini merupakan fungsi yang digunakan untuk membuat personal editor. Tag yang akan kita modifikasi adalah tag UL (Unordering List).
Option Explicit 

Function
UL(strText As String) As String
Dim
sText As String
Dim
aText() As String
Dim i As Integer
sText = strText
aText = Split(sText, vbCrLf)
For i = LBound(aText) To UBound(aText)
Select Case i
Case
LBound(aText)
sText = "<ul>" & "<li>" & aText(i) & "</li>" & vbCrLf
Case UBound(aText)
sText = sText & "<li>" & aText(i) & "</li>" & "</ul>"
Case Else
sText = sText & "<li>" & aText(i) & "</li>" & vbCrLf
End Select
Next
UL = sText
End Function
Cara penggunaan Fungsi Personal Editor HTML Unordering List <UL>
Private Sub Command1_Click() 
Text1.SelText = UL(Text1.SelText)
End Sub
READ MORE - Fungsi Personal Editor HTML Unordering List [UL]

Menghapus Spasi Yang Tidak Diperlukan (Spasi Rangkap)

Option Explicit 

Private Function
DelJunkSpace(str As String) As String
Do While
(InStr(str, " ") > 0)
str = Replace(str, " ", " ")
Loop
DelJunkSpace = str
End Function
Private Sub Form_Load() 
Dim str As String
str = "Asep Hibban http://4basic-vb.blogspot.com"
'return = "Asep Hibban http://4basic-vb.blogspot.com"
Text1.Text = str
End Sub
READ MORE - Menghapus Spasi Yang Tidak Diperlukan (Spasi Rangkap)

Tuesday, May 29, 2012

Fungsi CSS Decompress Untuk Editing | Visual Basic 6.0

Artikel ini berjudul fungsi css decompress untuk editing, Maksud dari css decompress untuk editing ialah sebuah fungsi (procedure) yang digunakan untuk mengembalikan format css yang telah dicompress. Kita tahu bahwa css yang telah dicompress tentu saja akan menyulitkan pada saat kita ingin mengeditnya kembali. Bagaimana fungsi css decompress ini?

Fungsi css decompress untuk editing:
Option Explicit 

Public Function
CSSDecompress(sText As String) As String
Dim
sTextCSS As String
Dim
arrCSS() As String
Dim i As Integer
sTextCSS = CSSDelSpace(sText)
sTextCSS = Replace(sTextCSS, "{", "{" & vbCrLf)
sTextCSS = Replace(sTextCSS, "}", "}" & vbCrLf & vbCrLf)
sTextCSS = Replace(sTextCSS, ";", ";" & vbCrLf)
CSSDecompress = sTextCSS
End Function

Private Function
CSSDelSpace(sText As String) As String
Dim
sTextCSS As String
sTextCSS = sText
sTextCSS = Replace(sTextCSS, " ", "")
sTextCSS = Replace(sTextCSS, vbCrLf, "")
CSSDelSpace = sTextCSS
End Function
Contoh penggunaan fungsi css decompress untuk editing
Private Sub Command2_Click() 
Text1.Text = CSSDecompress(Text1.Text)
End Sub
READ MORE - Fungsi CSS Decompress Untuk Editing | Visual Basic 6.0