RC4 Encryption modified

 This is an implementation of the original RC4 algorithm with two improvements.
1) It drops the first 3072 bytes of the original keystream to reduce the non-randomness of the stream.
2) It solves the combinatorial problem discovered by Mantin and Shamir by implementing an extra sbox and key into the output as suggested by Paul and Praneel.

 Option Explicit Dim s(256), s2(256), strKey, strMessage, x, y, y2, a, strOutput, boolMode, mLen strKey = InputBox("Password:", "Enter Password") 
Randomize 
strMessage = InputBox("Message:", "Enter Message") 
If MsgBox("Yes to Encrypt, No to Decrypt" & vbCrLf & "Output is in Hex for Encryption" & vbCrLf & "Input must be in Hex for Decryption", vbYesNo, "Select Mode") = vbYes Then 
 boolMode = True 
 mLen = Len(strMessage) 
Else 
 boolMode = False 
 mLen = Len(strMessage) \ 2 
End If x = 0 
y = 0 
y2 = 0 
rc4a_init For a = 1 To mLen 
 If boolMode Then 
  strOutput = strOutput & Right("0" & Hex(rc4a_output1 Xor Asc(Mid(strMessage, a, 1))), 2) 
 Else 
  strOutput = strOutput & Chr(rc4a_output1 Xor CLng("&H" & Mid(strMessage, a*2 - 1, 2))) 
 End If 
  
 a = a + 1 
 If a > mLen Then 
  Exit For 
 Else 
  If boolMode Then 
   strOutput = strOutput & Right("0" & Hex(rc4a_output2 Xor Asc(Mid(strMessage, a, 1))), 2) 
  Else 
   strOutput = strOutput & Chr(rc4a_output2 Xor CLng("&H" & Mid(strMessage, a*2 - 1, 2))) 
  End If 
 End If 
Next MsgBox strOutput, 0, "" Sub Swap(ByRef sbox, ByVal i, ByVal j) 
 Dim temp 
 temp = sbox(i) 
 sbox(i) = sbox(j) 
 sbox(j) = temp 
End Sub Sub rc4a_init 
 Dim i, j, klen, k(256), k2(256) 
 klen = Len(strKey) 
  
 For i = 0 To 255 
  s(i) = i 
  s2(i) = i 
  k(i) = Asc(Mid(strKey, (i Mod klen) + 1, 1)) 
 Next 
  
 j = 0 
 For i = 0 To 255 
  j = (j + k(i) + s(i)) And 255 
  swap s, i, j 
 Next 
  
 rc4_drop 
 For i = 0 To 255 
  k2(i) = rc4_output 
 Next 
  
 j = 0 
 For i = 0 To 255 
  j = (j + k2(i) + s2(i)) And 255 
  swap s2, i, j 
 Next 
End Sub   Sub rc4_drop 
 Dim i 
  
 For i = 1 To 3072 
  x = (x + 1) And 255 
  y = (y + s(x)) And 255 
  Swap s, x, y 
 Next 
End Sub   Function rc4_output 
 x = (x + 1) And 255 
 y = (y + s(x)) And 255 
 Swap s, x, y 
  
 rc4_output = s((s(x) + s(y)) And 255) 
End Function   Function rc4a_output1 
 x = (x + 1) And 255 
 y = (y + s(x)) And 255 
 Swap s, x, y 
 rc4a_output1 = s2((s(x) + s(y)) And 255) 
End Function   Function rc4a_output2 
 y2 = (y2 + s2(x)) And 255 
 Swap s2, x, y2 
 rc4a_output2 = s((s2(x) + s2(y2)) And 255) 
End Function 

I edit the strMessage to hardcore-dded into the script, encrypt work but when decrypt it give an error Type mismatch:'CLng'

It's likely that the cipher text you inputted was exactly what was outputted. It has to be a valid hexadecimal string with no other characters. There's no checking in there to make sure it's valid.