800a01ad error while debugging VB6 DLL under IIS6.0 on Win2003SP1

The following issue was causing because of terminal server. This issue not causes if VB dll debugged on server itself.

There is one KB article on it but not that much helpful to get complete solution:
http://support.microsoft.com/kb/298926

Configuration: Windows Server 2003 SP1, IIS6.0

A VB6.0 DLL works fine when called from ASP page without debug mode. However when I try to run it in debug mode using Visual Studio 6 IDE I am getting following error:

Microsoft VBScript runtime error '800a01ad'
ActiveX component can't create object

The test code is very simple and given at the end.

I tried the following to run the dll in debug mode and to invoke from the ASP page but nothing worked.
- Grant full control permissions at OS level to all users (‘Everyone’) for the folder where DLL resides.
- Created the “VB ASP Debug” entry in DCOMCNFG by modifying the registry and then giving proper permissions.
- Checked all permissions within the “Directory Security” tab within IIS
- Given read permission to everyone for DLL entries in registry.
- Added appropriate users in ‘Debugger Users’ (under Computer Management, System Tools, and Local Users and Groups)
- Used RegMon, FileMon and ProcessMon but not get much information.
- There are no event log entries in the application/System event log.
- In DCOMCNFG set proper permission for ‘Debug Machine Manger’ as well as test DLL.
- In IIS tried changing user authentication modes (under Directory Security)
- Given read permission to ‘Everyone’ to “C:\Program Files\Common Files”
- Given permission to ‘Everyone’ by opening Properties of DCOMCONFIG and then selecting COM Security.
- Given IIS_WPG, IUSR_ AND IWAM_ accounts both have Read/Execute NTFS rights on the following folders cascaded down.
\program files\common files\System
\Windows
\InetPub\WWWRoot

- Reinstalled SP1

Checked following KB sites:

http://support.microsoft.com/default.aspx/kb/194801
http://support.microsoft.com/kb/259725

VB Code:
(CompileTest.DebugME)

Public Function TestMe() As String
TestMe = "TestOK" ‘ put debug point here
End Function

Asp Code:
<%
set objTest = Server.CreateObject( "CompileTest.DebugME" )
Response.write(objTest.TestMe())
%>

<%
set objTest = Server.CreateObject( "CompileTest.DebugME" )
Response.write(objTest.TestMe())
%>

Running 32-bit Applications on 64-bit Windows (IIS 6.0)

Several times there are issue occurs while running 32-bit Applications on 64-bit Windows (IIS 6.0) (E.g. Debugging VB components throws - "Microsoft VBScript runtime error '800a01ad' ActiveX component can't create object")

This is info for running 32-bit Applications on 64-bit Windows (IIS 6.0)

http://www.microsoft.com/technet/prodtechnol/WindowsServer2003/Library/IIS/0aafb9a0-1b1c-4a39-ac9a-994adc902485.mspx?mfr=true

Passing LogFont struct from VB to C#

LogFont structre in VB looks as:

Type LogFont ' 60 Bytes
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 32
End Type

Use CopyMemory API to convert struct in bytes

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Dim lf As LogFont
Dim bt(100) As Byte
CopyMemory bt(0), lf, LenB(lf)

'Finally call the C# function
objNet.SendLogFont(bt))

In C# you can convert bytes back to logFont as shown:

LogFont struct in C# looks as:

[StructLayout(LayoutKind.Sequential, Pack = 1)] //, CharSet = CharSet.Auto)]
internal struct LOGFONT
{
public const int LF_FACESIZE = 32;
public int lfHeight;
public int lfWidth;
public int lfEscapement;
public int lfOrientation;
public int lfWeight;
public byte lfItalic;
public byte lfUnderline;
public byte lfStrikeOut;
public byte lfCharSet;
public byte lfOutPrecision;
public byte lfClipPrecision;
public byte lfQuality;
public byte lfPitchAndFamily;
[MarshalAs(UnmanagedType.ByValTStr, SizeConst = LF_FACESIZE)]
public string lfFaceName;
}

Then write SendLogFont() function as

public void SendLogFont()
{
LOGFONT lf = new LOGFONT();
try
{
GCHandle gcHandle = GCHandle.Alloc(Buff, GCHandleType.Pinned);
// Marshals data from an unmanaged block of memory
// to a newly allocated managed object of the specified type.
Object Obj = Marshal.PtrToStructure(gcHandle.AddrOfPinnedObject(), typeof(LOGFONT));
lf = (LOGFONT)Obj;
// Free GChandle to avoid memory leaks
gcHandle.Free();
}
catch (Exception ex)
{
Debug.WriteLine(ex.Message);
}
}

Passing Int Array from Unmanged to Managed code

Unmanaged VB6.0 Code to C#

Note that you have to pass array without index.

Dim lParms(9) As Long
objNetAsm.GetInfo lParms

Managed C# Code:

In managed C# the array is accessed by refrence.
public long GetInfo (ref Int32[] plParms)
{
// Note that long in VB is Int32 in C#
}

UnmanagedVB6.0 to C++:

// Note you have to pass 0th element
cppObj.GetInfo lParms(0)

Unmanaged C++
// Using array pointer
GetInfo (long * plParms)
{

}

Some more good info on "Default Marshaling for Arrays"
http://msdn2.microsoft.com/en-us/library/z6cfh6e6(VS.80).aspx

P/Invoke (Windows API reference)

Greatest site having Windows API reference for C#, VB.NET & VB6. I used this several times to add Windows API reference in C# code (P/Invoke).

Calling Web Service from VB6.0

Code for invoking WebService from VB6.0

txtReq.Text has complete SOAP enevlope (including SOAP body)
txtWSSchema.Text 'SOAP action URI (look WS test page for URI)
-------------------------------------------


Private Sub cmdRequest_Click()
Dim o As New MSXML2.XMLHTTP


On Error GoTo err_handler

o.open "POST", "http://localhost/MYWebServices/myws.asmx", False

o.setRequestHeader "Content-Type", "text/xml; charset=utf-8"
o.setRequestHeader "Connection", "close"
o.setRequestHeader "SOAPAction", txtWSSchema.Text 'SOAP action URI (look WS test page for URI)

o.send txtReq.Text

txtResponseHeaders.Text = o.getAllResponseHeaders
txtResponse.Text = o.responseText

err_handler:
If Err.Number <> 0 Then MsgBox "Error " & Err.Number &amp;amp; ": " & Err.Description

End Sub

How to get COM+ Activation String?

Make sure to include refrence for "COM+ 1.0 Admin Type Library"

Public Function getDBHelperActivationString() As String
Dim catalog As COMAdmin.COMAdminCatalog
Dim applications As COMAdmin.COMAdminCatalogCollection
Dim application As COMAdmin.COMAdminCatalogObject

Set catalog = New COMAdmin.COMAdminCatalog
Set COMAdminCatalogCollection = catalog.GetCollection("Applications")
Call COMAdminCatalogCollection.Populate

Dim comApplication As COMAdmin.COMAdminCatalogObject

For Each comApplication In COMAdminCatalogCollection
If (strConstructorString <> "") Then
Exit For
End If

Dim applicationComponents As COMAdmin.ICatalogCollection
Set applicationComponents = COMAdminCatalogCollection.GetCollection("Components", comApplication.Key)
applicationComponents.Populate

Dim comComponent As COMAdmin.COMAdminCatalogObject
For Each comComponent In applicationComponents
If (comComponent.Name = "MRI_Svr_Db.DBHelper") Then
strConstructorString = comComponent.Value("ConstructorString")
Exit For
End If
Next
Next

getDBHelperActivationString = strConstructorString
End Function

Encrypt Decrypt in VB6

Following function performs encryption as well as decryption

Example – Uses Base64 functions from previous post

Encryption & decryption with base64 output

sCmd=”this is test”

queryString = (Base64Encoding(EncryptDecrypt(sCmd), "myWord", "13"))

queryString = (EncryptDecrypt(Base64Decoding(sCmd), "myWord", "13"))

Public Function EncryptDecrypt(ByVal szData As String, ByVal salt As String, ByVal pepper As String) As String
    ''' salt is a key value can be changed to alter the
    ''' encryption, but it must be the same for both
    ''' encryption and decryption.
    ''' pepper is optional, and may be any
    ''' value 0-64.
    ''' Likewise, it needs to be the same coming/going.

    Dim bytKey() As Byte
    Dim bytData() As Byte
    Dim lNum As Long
    Dim szKey As String
    Dim strOutput As String

    'use a default key if none given
    If Len(salt) = 0 Then salt = "123456"
    
    'make sure the key is as long as the text we want to encode
    For lNum = 1 To ((Len(szData) / Len(salt)) + 1)
        szKey = szKey & salt
    Next lNum
    
    ReDim bytKey(Len(szData)) As Byte
    ReDim bytData(Len(szData)) As Byte
    
    'copy the key into the key byte array
    'must do it this way to avoid unicode problems
    'make it no longer than the text we want to encode
    For lNum = 1 To Len(szData)
        bytKey(lNum) = Asc(Mid$(szKey, lNum, 1))
    Next lNum
    
    'copy the text we want to encode into the data byte array
    'must do it this way to avoid unicode problems
    For lNum = 1 To Len(szData)
        bytData(lNum) = Asc(Mid$(szData, lNum, 1))
    Next lNum
    
    strOutput = ""

    For lNum = 1 To UBound(bytData)
        If lNum Mod 2 Then
            bytData(lNum) = bytData(lNum) Xor (bytKey(lNum) + pepper)
            strOutput = strOutput & Chr(bytData(lNum))
        Else
            bytData(lNum) = bytData(lNum) Xor (bytKey(lNum) - pepper)
            strOutput = strOutput & Chr(bytData(lNum))
        End If
    Next lNum

    EncryptDecrypt = strOutput
End Function

Base64 Encoding & Decoding in vb6

Following two functions can be used for encoding string in base64. This is useful when you want to pass encrypted string etc on URL.

 Public Function Base64Encoding(StrToEncode As String) As String
    Static EncodeTable(0 To 63) As Byte
    
    Dim K As Long, OutStr() As Byte, StrIn() As Byte, Lng As Long
    
    If EncodeTable(0) = 0 Then
        For K = 0 To 25
            EncodeTable(K) = Asc("A") + K
        Next K
        
        For K = 0 To 25
            EncodeTable(K + 26) = Asc("a") + K
        Next K
        
        For K = 0 To 9
            EncodeTable(K + 52) = Asc("0") + K
        Next K
        
        EncodeTable(62) = Asc("+")
        EncodeTable(63) = Asc("/")
    End If
    
    If StrToEncode = "" Then Exit Function
    
    StrIn = StrConv(StrToEncode, vbFromUnicode)
    If (Len(StrToEncode) Mod 3) = 0 Then
        ReDim OutStr((Len(StrToEncode) \ 3) * 4 - 1)
    Else
        ReDim OutStr(((Len(StrToEncode) \ 3) + 1) * 4 - 1)
    End If
    
    For K = 0 To Len(StrToEncode) \ 3 - 1
        Lng = StrIn(K * 3 + 2) Or (StrIn(K * 3 + 1) * &H100&) Or (StrIn(K * 3) * &H10000)
        
        OutStr(K * 4 + 0) = EncodeTable((Lng And &HFC0000) \ &H40000)
        OutStr(K * 4 + 1) = EncodeTable((Lng And &H3F000) \ &H1000&)
        OutStr(K * 4 + 2) = EncodeTable((Lng And &HFC0&) \ &H40&)
        OutStr(K * 4 + 3) = EncodeTable(Lng And &H3F&)
    Next K
    
    If (Len(StrToEncode) Mod 3) = 1 Then
        Lng = StrIn(UBound(StrIn)) * &H10000
        
        OutStr(UBound(OutStr) - 3) = EncodeTable((Lng And &HFC0000) \ &H40000)
        OutStr(UBound(OutStr) - 2) = EncodeTable((Lng And &H3F000) \ &H1000&)
        OutStr(UBound(OutStr) - 1) = Asc("=")
        OutStr(UBound(OutStr) - 0) = Asc("=")
    ElseIf (Len(StrToEncode) Mod 3) = 2 Then
        Lng = (StrIn(UBound(StrIn)) * &H100&) Or (StrIn(UBound(StrIn) - 1) * &H10000)
        
        OutStr(UBound(OutStr) - 3) = EncodeTable((Lng And &HFC0000) \ &H40000)
        OutStr(UBound(OutStr) - 2) = EncodeTable((Lng And &H3F000) \ &H1000&)
        OutStr(UBound(OutStr) - 1) = EncodeTable((Lng And &HFC0&) \ &H40&)
        OutStr(UBound(OutStr) - 0) = Asc("=")
    End If
    
    Base64Encoding = StrConv(OutStr, vbUnicode)
End Function

Public Function Base64Decoding(StrToDecode As String, Optional CheckInvalidChars As Boolean = True) As String
    Static DecodeTable(0 To 255) As Byte
    
    Dim OutStr() As Byte, StrIn() As Byte
    Dim K As Long, Lng As Long
    
    If DecodeTable(0) = 0 Then
        For K = 0 To 255
            DecodeTable(K) = 255
        Next K
        
        For K = 0 To 25
            DecodeTable(K + 65) = K
        Next K
        
        For K = 26 To 51
            DecodeTable(K + 71) = K
        Next K
        
        For K = 52 To 61
            DecodeTable(K - 4) = K
        Next K
        
        DecodeTable(43) = 62
        DecodeTable(47) = 63
    End If
    
    If StrToDecode = "" Then Exit Function
    
    StrToDecode = Trim(StrToDecode)
    
    If CheckInvalidChars Then
        For K = 0 To 255
            If Not (Chr(K) Like "[A-Za-z0-9+/=]") Then
                StrToDecode = Replace(StrToDecode, Chr(K), "")
            End If
        Next K
    End If
    
    StrIn() = StrConv(StrToDecode, vbFromUnicode)
    ReDim OutStr(0 To ((Len(StrToDecode) \ 4) * 3 - 1))
    
    For K = 0 To Len(StrToDecode) \ 4 - 2
        Lng = DecodeTable(StrIn(K * 4 + 3))
        Lng = Lng Or (DecodeTable(StrIn(K * 4 + 2)) * &H40&)
        Lng = Lng Or (DecodeTable(StrIn(K * 4 + 1)) * &H1000&)
        Lng = Lng Or (DecodeTable(StrIn(K * 4 + 0)) * &H40000)
        
        OutStr(K * 3 + 0) = (Lng And &HFF0000) \ &H10000
        OutStr(K * 3 + 1) = (Lng And &HFF00&) \ &H100&
        OutStr(K * 3 + 2) = Lng And &HFF&
    Next K
    
    Lng = 0
    If DecodeTable(StrIn(K * 4 + 3)) <> 255 Then Lng = DecodeTable(StrIn(K * 4 + 3))
    If DecodeTable(StrIn(K * 4 + 2)) <> 255 Then Lng = Lng Or (DecodeTable(StrIn(K * 4 + 2)) * &H40&)
    If DecodeTable(StrIn(K * 4 + 1)) <> 255 Then Lng = Lng Or (DecodeTable(StrIn(K * 4 + 1)) * &H1000&)
    If DecodeTable(StrIn(K * 4 + 0)) <> 255 Then Lng = Lng Or (DecodeTable(StrIn(K * 4 + 0)) * &H40000)
    
    OutStr(K * 3 + 0) = (Lng And &HFF0000) \ &H10000
    OutStr(K * 3 + 1) = (Lng And &HFF00&) \ &H100&
    OutStr(K * 3 + 2) = Lng And &HFF&
    
    If StrIn(UBound(StrIn) - 1) = 61 Then
        Base64Decoding = Left(StrConv(OutStr, vbUnicode), UBound(OutStr) - 1)
    ElseIf StrIn(UBound(StrIn)) = 61 Then
        Base64Decoding = Left(StrConv(OutStr, vbUnicode), UBound(OutStr) - 0)
    Else
        Base64Decoding = StrConv(OutStr, vbUnicode)
    End If
End Function

Parsing URL request params in VB

Following function can be used to parse URL parameters & values from request string.

e.g.

ParseURLRequest(“EMPID=123&NAME=”iKnown&EX=UPDATE”, “NAME”)

returnsiKnown

 

Public Function ParseURLRequest(ByVal requestURL As String, ByVal parseParam As String) As String
  Dim ip As Integer, ip2 As Integer
  Dim modRequestURL As String, sParmVal As String

  sParmVal = ""
  modRequestURL = RTrim$("&" & requestURL) & "&"
  ip = InStr(modRequestURL, parseParam)
  If ip > 0 Then
    ip = ip + Len(parseParam)
    ip2 = InStr(ip, modRequestURL, "&")
    If ip2 = 0 Then
      ip2 = Len(parseParam) + 1
    End If
    If ip2 > ip Then
      sParmVal = Mid$(requestURL, ip, ip2 - ip - 1)
    End If
  End If
  ParseURLRequest = sParmVal
End Function

Convert Image to Byte

Public Function GetImage() As Byte()
Dim B() As Byte
Dim srcFile As String

' /* Change This To your File */
srcFile = "c:\unit73.jpeg"

Open srcFile For Binary Access Read As #1
ReDim B(LOF(1) - 1)
Get #1, , B
Close #1

GetImage = B

End Function

File compare Utility

VERSION 5.00
Begin VB.Form frmFileCmp
Caption = "File Diff"
ClientHeight = 7440
ClientLeft = 60
ClientTop = 360
ClientWidth = 12045
Icon = "frmFileCmp.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 7440
ScaleWidth = 12045
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdCopyToClip
Caption = "C&opy Result To Clipboard"
Height = 495
Left = 9360
TabIndex = 12
Top = 5400
Width = 2295
End
Begin VB.ListBox lstLog
Height = 2595
Left = 120
TabIndex = 11
Top = 4800
Width = 9135
End
Begin VB.CommandButton cmdCmpFiles
Caption = "&Compare Files"
Height = 495
Left = 9360
TabIndex = 8
Top = 4800
Width = 2295
End
Begin VB.Frame Frame2
Caption = "Destination File Settings"
Height = 4455
Left = 6120
TabIndex = 4
Top = 0
Width = 5895
Begin VB.FileListBox fList1
Height = 3405
Left = 2880
TabIndex = 10
Top = 840
Width = 2775
End
Begin VB.DriveListBox drvSelect1
Height = 315
Left = 120
TabIndex = 6
Top = 480
Width = 2535
End
Begin VB.DirListBox dirList1
Height = 3465
Left = 120
TabIndex = 5
Top = 840
Width = 2535
End
Begin VB.Label Label5
AutoSize = -1 'True
Caption = "Destination File(s)"
Height = 195
Left = 2880
TabIndex = 14
Top = 600
Width = 1245
End
Begin VB.Label Label4
AutoSize = -1 'True
Caption = "Drive / Path:"
Height = 195
Left = 120
TabIndex = 7
Top = 240
Width = 915
End
End
Begin VB.Frame Frame1
Caption = "Source File Settings"
Height = 4455
Left = 0
TabIndex = 0
Top = 0
Width = 6015
Begin VB.FileListBox fList
Height = 3405
Left = 2880
TabIndex = 9
Top = 960
Width = 2775
End
Begin VB.DirListBox dirList
Height = 3465
Left = 120
TabIndex = 2
Top = 840
Width = 2535
End
Begin VB.DriveListBox drvList
Height = 315
Left = 120
TabIndex = 1
Top = 480
Width = 2535
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "Source File(s)"
Height = 195
Left = 2880
TabIndex = 13
Top = 600
Width = 960
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "Drive / Path:"
Height = 195
Left = 120
TabIndex = 3
Top = 240
Width = 915
End
End
Begin VB.Label Label7
Caption = "Comparison Result:"
Height = 255
Left = 120
TabIndex = 15
Top = 4560
Width = 3135
End
End
Attribute VB_Name = "frmFileCmp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cmbPattern_Click()
Dim pos1 As Integer
Dim pos2 As Integer
Dim txt As String

txt = cmbPattern.Text
pos1 = InStrRev(txt, "(")
pos2 = InStrRev(txt, ")")
fList.Pattern = Mid$(txt, pos1 + 1, pos2 - pos1 - 1)

End Sub

Private Sub cmdCmpFiles_Click()
Me.MousePointer = vbHourglass
lstLog.Clear
Dim i As Integer, j As Integer
Dim bFound As Boolean
Dim aCmpReply As String
For i = 0 To fList.ListCount - 1
If (fList.List(i) = fList1.List(i)) Then
aCmpReply = FileCompare(dirList.Path & "\" & fList.List(i), dirList1.Path & "\" & fList1.List(i))
If (InStr(aCmpReply, "%")) Then
lstLog.AddItem "File " & fList.List(i) & " is " & aCmpReply & " equal"
Else
lstLog.AddItem ">>>>>>> File " & fList.List(i) & " has diffrent file size. <<<<<<"
End If
Else
bFound = False
'check file name in dest and compare
For j = 0 To fList1.ListCount - 1
If fList.List(i) = fList1.List(j) Then
aCmpReply = FileCompare(dirList.Path & "\" & fList.List(i), dirList1.Path & "\" & fList1.List(j))
If (InStr(aCmpReply, "%")) Then
lstLog.AddItem "File " & fList.List(i) & " is " & aCmpReply & " equal"
Else
lstLog.AddItem ">>>>>>> File " & fList.List(i) & " has diffrent file size. <<<<<<"
End If
bFound = True
End If
Next
If bFound = False Then
lstLog.AddItem "File Name not found for comparision - " & fList.List(i)
End If
End If
DoEvents
Next i

Me.MousePointer = vbDefault
End Sub

Private Sub cmdCopyToClip_Click()
Dim tmpMsg As String
Clipboard.Clear
For i = 0 To lstLog.ListCount - 1
tmpMsg = tmpMsg & vbCrLf & lstLog.List(i)
Next i
Clipboard.SetText tmpMsg
End Sub

Private Sub dirList_Change()
fList.Path = dirList.Path
End Sub

Private Sub fList_PatternChange()
fileList.Clear

Dim i As Integer
For i = 0 To fList.ListCount - 1
fileList.AddItem fList.List(i)
Next
End Sub

Private Sub drvSelect_Change()
'On Error GoTo DriveError
dirList.Path = drvList.Drive
Exit Sub

DriveError:
drvList.Drive = dirList.Path
Exit Sub

End Sub
'Private Sub cmdSelList_Click()
' Dim i As Integer
' If cmdSelList.Caption = "&Select All" Then
' cmdSelList.Caption = "&Deselect All"
' For i = 0 To fileList.ListCount - 1
' fileList.Selected(i) = True
' Next i
'
' Else
' cmdSelList.Caption = "&Select All"
' For i = 0 To fileList.ListCount - 1
' fileList.Selected(i) = False
' Next i
'
' End If
'
'End Sub

Public Function FileCompare(File1 As String, File2 As String) As String
Dim f1() As Byte ' our array For the first file
Dim f2() As Byte ' our array For the second file
Dim Alike As Long
Alike& = 0 'needed For the percent part
filelen1 = FileLen(File1$) 'file length of first file
FileLen2 = FileLen(File2$) 'file length of second file
If filelen1 <> FileLen2 Then FileCompare$ = "Different file size": Exit Function
'if file sizes are different, then they
' are not the same
ReDim f1(1 To filelen1) 'since we now have the file length, lets activate the arrays
ReDim f2(1 To FileLen2)
Open File1 For Binary Access Read As #1
Open File2 For Binary Access Read As #2
Get #1, 1, f1()
Get #2, 1, f2()
Close #2
Close #1
'this opens up the files, gets all the d
' ata and stores them in our arrays


For i = 1 To filelen1 Step 6
If f1(i) = f2(i) Then Alike = Alike + 1
'if they are the same, add 1 to alike co
' unter
If i + 1 > filelen1 Then GoTo skipout
'if we exceed the length of the file, th
' en leave the for,next statement IMMEDIAT
' ELY
If f1(i + 1) = f2(i + 1) Then Alike = Alike + 1
If i + 2 > filelen1 Then GoTo skipout
If f1(i + 2) = f2(i + 2) Then Alike = Alike + 1
If i + 3 > filelen1 Then GoTo skipout
If f1(i + 3) = f2(i + 3) Then Alike = Alike + 1
If i + 4 > filelen1 Then GoTo skipout
If f1(i + 4) = f2(i + 4) Then Alike = Alike + 1
If i + 5 > filelen1 Then GoTo skipout
If f1(i + 5) = f2(i + 5) Then Alike = Alike + 1


Next i
skipout:
Dim res As Double
res = Alike / filelen1 * 100
FileCompare$ = CStr(Format(res, "###.####")) & "%" 'FormatPercent(Alike / filelen1, 5))
'divide alike from filelength and format
' it into a percent
End Function



Private Sub dirList1_Change()
fList1.Path = dirList1.Path
End Sub

Private Sub fList1_PatternChange()
fileList.Clear

Dim i As Integer
For i = 0 To fList.ListCount - 1
fileList.AddItem fList.List(i)
Next
End Sub

Private Sub drvSelect1_Change()
'On Error GoTo DriveError
dirList.Path = drvList.Drive
Exit Sub

DriveError:
drvList.Drive = dirList.Path
Exit Sub

End Sub

Ms Word to HTML converter

VERSION 5.00
Begin VB.Form W2H
Caption = "IRES Word2HTML Converter"
ClientHeight = 6720
ClientLeft = 60
ClientTop = 360
ClientWidth = 11355
Icon = "W2H.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
ScaleHeight = 6720
ScaleWidth = 11355
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton Command1
Caption = "C&lear Log"
Height = 375
Left = 9120
TabIndex = 16
Top = 6120
Width = 2055
End
Begin VB.CommandButton cmdC2C
Caption = "&Copy Log to Clipboard"
Height = 375
Left = 6240
TabIndex = 15
Top = 6120
Width = 2295
End
Begin VB.ListBox lstLog
Height = 3570
Left = 6240
TabIndex = 13
Top = 2400
Width = 4935
End
Begin VB.CommandButton cmdC2H
Caption = "Convert to &HTML"
Height = 495
Left = 7440
TabIndex = 12
Top = 1440
Width = 2415
End
Begin VB.TextBox txtHTMLDest
Height = 375
Left = 6120
TabIndex = 10
Text = "C:\HTML"
Top = 720
Width = 5055
End
Begin VB.Frame Frame1
Height = 6495
Left = 120
TabIndex = 0
Top = 120
Width = 5895
Begin VB.ListBox fileList
Height = 5460
Left = 2760
Style = 1 'Checkbox
TabIndex = 5
Top = 840
Width = 2895
End
Begin VB.ComboBox cmbPattern
Height = 315
Left = 120
Style = 2 'Dropdown List
TabIndex = 4
Top = 6000
Width = 2535
End
Begin VB.DirListBox dirList
Height = 4815
Left = 120
TabIndex = 3
Top = 840
Width = 2535
End
Begin VB.DriveListBox drvList
Height = 315
Left = 120
TabIndex = 2
Top = 480
Width = 2535
End
Begin VB.CommandButton cmdSelList
Caption = "&Select All"
Height = 375
Left = 4320
TabIndex = 1
Top = 360
Width = 1335
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "Drive / Path:"
Height = 195
Left = 120
TabIndex = 8
Top = 240
Width = 915
End
Begin VB.Label Label2
Caption = "Select File(s) for Conversion:"
Height = 435
Left = 2760
TabIndex = 7
Top = 360
Width = 1410
WordWrap = -1 'True
End
Begin VB.Label Label3
AutoSize = -1 'True
Caption = "File Pattern:"
Height = 195
Left = 120
TabIndex = 6
Top = 5760
Width = 840
End
End
Begin VB.FileListBox fList
Height = 1260
Left = 3240
TabIndex = 9
Top = 4200
Width = 975
End
Begin VB.Label Label5
AutoSize = -1 'True
Caption = "Conversion Log:"
Height = 195
Left = 6240
TabIndex = 14
Top = 2160
Width = 1155
End
Begin VB.Label Label4
Caption = "HTML Destination:"
Height = 255
Left = 6120
TabIndex = 11
Top = 480
Width = 2295
End
End
Attribute VB_Name = "W2H"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub cmdC2C_Click()
Dim i2 As Integer
Clipboard.Clear
Dim aLog As String
For i2 = 0 To lstLog.ListCount - 1
aLog = aLog & lstLog.List(i2) & vbCrLf
Next
Clipboard.SetText aLog
End Sub

Private Sub cmdC2H_Click()
Me.Enabled = False
Dim aResult As String, afile As String, apath As String
Dim i2 As Integer
Dim aCurrentFileSelectedForConversion As String

For i2 = 0 To fileList.ListCount - 1
aCurrentFileSelectedForConversion = ""
If fileList.Selected(i2) = True Then
'Do While Len(aFile)

afile = fileList.List(i2)
apath = dirList.Path & "\"
If UCase(Right$(afile, 4)) = ".DOC" Then
aCurrentFileSelectedForConversion = afile
aResult = WordToHTML(apath & afile, txtHTMLDest.Text & "\" & Left(afile, Len(afile) - 4) & ".htm")
If aResult = "Success" Then
lstLog.AddItem aCurrentFileSelectedForConversion & " Successfully Converted"
Else
lstLog.AddItem aCurrentFileSelectedForConversion & " Failed to convert. Reason - " & aResult
End If
End If
End If
DoEvents
Next
Me.Enabled = True
MsgBox "Conversion Completed !!"
End Sub

Private Sub Command1_Click()
lstLog.Clear
End Sub

Private Sub Form_Load()
cmbPattern.AddItem "Word Files (*.DOC)."
cmbPattern.AddItem "All Files (*.*)."
cmbPattern.ListIndex = 0

'dirList.Path = drvList.Drive
On Error Resume Next
dirList.Path = "C:\"

Dim DirectoryFound As String

On Error GoTo 0
DirectoryFound = Dir(txtHTMLDest.Text, vbDirectory)
If (Len(DirectoryFound) = 0 Or Err = 76) Then
MkDir txtHTMLDest.Text
End If
End Sub
Private Sub cmbPattern_Click()
Dim pos1 As Integer
Dim pos2 As Integer
Dim txt As String

txt = cmbPattern.Text
pos1 = InStrRev(txt, "(")
pos2 = InStrRev(txt, ")")
fList.Pattern = Mid$(txt, pos1 + 1, pos2 - pos1 - 1)

End Sub
Private Sub fList_PatternChange()
fileList.Clear

Dim i As Integer
For i = 0 To fList.ListCount - 1
fileList.AddItem fList.List(i)
Next
End Sub



Private Sub drvSelect_Change()
'On Error GoTo DriveError
dirList.Path = drvList.Drive
Exit Sub

DriveError:
drvList.Drive = dirList.Path
Exit Sub

End Sub
Private Sub cmdSelList_Click()
Dim i As Integer
If cmdSelList.Caption = "&Select All" Then
cmdSelList.Caption = "&Deselect All"
For i = 0 To fileList.ListCount - 1
fileList.Selected(i) = True
Next i

Else
cmdSelList.Caption = "&Select All"
For i = 0 To fileList.ListCount - 1
fileList.Selected(i) = False
Next i

End If

End Sub
Private Sub drvList_Change()
'On Error GoTo DriveError
dirList.Path = drvList.Drive
Exit Sub

DriveError:
drvList.Drive = dirList.Path
Exit Sub
End Sub

Private Sub dirList_Change()
fileList.Clear
fList.Path = dirList.Path
Dim i As Integer
For i = 0 To fList.ListCount - 1
fileList.AddItem fList.List(i)
Next
cmdSelList.Caption = "&Select All"
End Sub

'Private Sub fList_Click()
' cmdConvertToWiki_Click
'End Sub
'-----------------------------------------------------------------------
Function WordToHTML(strWordDoc, strHTMLDoc)
On Error GoTo errH

Dim objWord
Set objWord = New Word.Application ' CreateObject("Word.Application")
objWord.Visible = False
objWord.Documents.Open (strWordDoc)

If Err.Number <> 0 Then
WordToHTML = Err.Description
Else
' Dim FileFormat
' Dim LockComments
' Dim Password
' Dim AddToRecentFiles
' Dim WritePassword
' Dim ReadOnlyRecommended
' Dim EmbedTrueTypeFonts
' Dim SaveNativePictureFormat
' Dim SaveFormsData
' Dim SaveAsAOCELetter
'
' FileFormat = wdFormatHTML
' LockComments = True
' Password = ""
' AddToRecentFiles = False
' WritePassword = ""
' ReadOnlyRecommended = False
' EmbedTrueTypeFonts = False
' SaveNativePictureFormat = True
' SaveFormsData = False
' SaveAsAOCELetter = False


' objWord.activedocument.SaveAs strHTMLDoc, FileFormat, LockComments, Password, AddToRecentFiles, WritePassword, ReadOnlyRecommended, EmbedTrueTypeFonts, SaveNativePictureFormat, SaveFormsData, SaveAsAOCELetter

objWord.ActiveDocument.SaveAs FileName:=strHTMLDoc, FileFormat:=10 _
, LockComments:=True, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=True, SaveFormsData:=False, SaveAsAOCELetter:= _
False

'check errors (this should be another routine)
If Err.Number <> 0 Then
WordToHTML = Err.Description
Else
WordToHTML = "Success"
End If
End If
objWord.ActiveDocument.Close
objWord.Quit
Set objWord = Nothing
Exit Function
errH:
objWord.ActiveDocument.Close
objWord.Quit
Set objWord = Nothing
WordToHTML = Err.Description
End Function

RegUnReg Utility

COPYRIGHT AJIT MUNGALE

Removed - available soon for download.

End Sub

File Encode/Decode in VB6.0

Option Explicit

Function FileEncodeAndDecode(Inputfile As String, OutputFile As String, Passwordkey As String)
Dim Temp As Single
Dim Char As String * 1
Dim XORmask As Single
Dim Temp1 As Integer
Dim x As Variant, y As Integer, z As Integer
Dim Counter As Integer

Open Inputfile For Binary As #1
Open OutputFile For Binary As #2
For x = 1 To Len(Passwordkey)
Temp = Asc(Mid$(Passwordkey, x, 1))
For y = 1 To Temp
Temp1 = Rnd
Next y
Randomize Temp1
Next x
Counter = 0
For z = 1 To FileLen(Inputfile)
XORmask = Int(Rnd * 256)
Get 1, , Char
Char = Chr$((Asc(Char) Xor XORmask))
Put 2, , Char

Counter = Counter + 1
If Counter > Len(Passwordkey) Then
Counter = 1
End If
For x = 1 To (Asc(Mid$(Passwordkey, Counter, 1)) * 2)
Temp = Rnd
Next x
Next z
End Function



Private Sub cmd1_Click()
Dim Inputfile As String
Dim OutputFile As String
Dim Passwordkey As String
Dim M_FileObject As Object
Set M_FileObject = CreateObject("Scripting.FileSystemObject")

Inputfile = InputBox("Enter A Filename To Encode/Decode", "Enter File Name")
If Inputfile <> "" Then
If M_FileObject.FileExists(Inputfile) <> True Then
MsgBox "File Does Not Exists"
Exit Sub
End If
OutputFile = InputBox("Enter the New Filename this will become")
If M_FileObject.FileExists(Inputfile) = True Then
MsgBox "File Already Exists"
Exit Sub
End If
If Inputfile <> "" Then
Passwordkey = InputBox("Enter the Password (Key)")
If Inputfile <> "" Then
Call FileEncodeAndDecode(Inputfile, OutputFile, Passwordkey)
MsgBox "File Written To" & OutputFile
End If
End If
End If
End Sub
Private Sub Form_Load()
cmd1.Caption = "Code/Decode"
End Sub

Passing arrays/strings between VB6 and C/C++

This MS KB article covers SAFEARRAY/BSTR/strings/arrays and how to pass them between VB6 and C/C++.

Get Read Only files (VB6.0)

VERSION 5.00
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "Form1"
ClientHeight = 6615
ClientLeft = 45
ClientTop = 330
ClientWidth = 10095
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6615
ScaleWidth = 10095
StartUpPosition = 3 'Windows Default
Begin VB.ListBox List1
Height = 5325
Left = 3300
OLEDragMode = 1 'Automatic
TabIndex = 4
Top = 90
Width = 6435
End
Begin VB.DirListBox Dir1
Height = 5715
Left = 180
TabIndex = 2
Top = 480
Width = 3015
End
Begin VB.DriveListBox Drive1
Height = 315
Left = 180
TabIndex = 1
Top = 120
Width = 2985
End
Begin VB.CommandButton Command1
Caption = "Find Read files"
Height = 525
Left = 3660
TabIndex = 0
Top = 5670
Width = 1245
End
Begin VB.FileListBox File1
Height = 2040
Left = 150
TabIndex = 3
Top = 2700
Visible = 0 'False
Width = 2445
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub Command1_Click()

SetClearArchiveBit "C:\WINNT\Profiles\amungale.000\Desktop\ImplMysClient33.txt"

End Sub

Sub SetClearArchiveBit(filespec)

Dim oFS, oFile
Set oFS = CreateObject("Scripting.FileSystemObject")

List1.Clear

For i = 0 To File1.ListCount - 1
Set oFile = oFS.GetFile(File1.Path & "\" & File1.List(i))
If oFile.Attributes And ReadOnly Then
'List1.AddItem File1.List(i)
Else
List1.AddItem File1.Path & "\" & File1.List(i)
End If
Next
End Sub


Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub


Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub

VB Threading

In apartment threading each thread belongs to its own apartment, and each apartment gets its own copy of global data and global objects in VB's implementation of apartment-model threading. Objects on the same thread can share variables declared as Public in a standard module. The danger is that you have little control over which objects will share a thread. As a general rule, you should avoid creating your own global variables in your multithreaded applications unless you know how VB will interpret them. Global variables can be useful, however, if you think of them in terms of apartments. For example, consider the App object, which VB creates in each apartment automatically. You can use the App.ThreadID property to obtain the Win32 thread ID that uniquely identifies each thread. The thread manager described in this article uses the thread ID to keep track of the objects it manages.

Note that the Instancing property of an object in an ActiveX component affects where VB instantiates the object. If the object's Instancing property is set to SingleUse (or GlobalSingleUse), VB creates a new process (with a new primary thread) each time you use New or CreateObject in the client to instantiate the object. VB also creates that object in a new process if an object in the server creates another object using CreateObject, and that object has an Instancing property of SingleUse. This option isn't available for ActiveX DLLs, however. This makes sense because an in-process component is created "in the same process" as its client. You can implement a form of "multithreading" without diving into threads too deeply by setting an object's Instancing property to SingleUse. This approach forces VB to create each object in its own process, which requires extra resources.

The Project Properties dialog determines which thread VB will create an object on when you set an object class's Instancing property to MultiUse or GlobalMultiUse. Visual Basic provides three options for assigning objects to threads for out-of-process components: thread per object, single thread of execution, and thread pool.
Single-threaded execution is the default when creating an ActiveX EXE component, and you use this for creating most of your components. Multithreaded components require that you choose one of the other options, however. You must specify the number of threads in the pool when you compile a component using the thread-pool option. This number often equals the number of processors on a multiprocessor system, but you might want to specify more than one thread on a single-processor system when you know that much of a thread's time will be in a blocked mode, waiting for another server.

VB creates an object on the next thread in a round-robin fashion when a client creates an object with New or CreateObject. If you use the New operator to create an object in a server, then the object is a dependent object and is created on the same thread. An object created within the server using CreateObject is treated as if the client created it, and VB creates it on the next thread. Note that each thread gets its own copy of global data and objects. You have no way of predicting which objects, aside from dependent objects, will share a thread and the global information. Life is simpler when you compile using the thread-per-object option. This option allows you to create each object on its own thread, rather than the next thread in the pool. Each object also has its own App object, its own copy of global data, and its own copy of other global objects. The downside of this approach is that you have no control over how many objects (threads) are created.

Always Top

SetWindowPos API determines position of your window:

Declare Function SetWindowPos Lib "user32" ( _
ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long

Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

public sub SetFormOnTop(myForm as object)
SetWindowPos myForm.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE
end sub

Set HomePage using VB

Private Declare Function RegCreateKey Lib _
"advapi32.dll" Alias "RegCreateKeyA" _
(ByVal HKey As Long, ByVal lpSubKey As _
String, phkResult As Long) As Long

Private Declare Function RegCloseKey Lib _
"advapi32.dll" (ByVal HKey As Long) As Long

Private Declare Function RegSetValueEx Lib _
"advapi32.dll" Alias "RegSetValueExA" _
(ByVal HKey As Long, ByVal _
lpValueName As String, ByVal _
Reserved As Long, ByVal dwType _
As Long, lpData As Any, ByVal _
cbData As Long) As Long

Private Const REG_SZ = 1
Private Const HKEY_CURRENT_USER = &H80000001

Private Sub SaveString(HKey As Long, Path As String, _
Name As String, Data As String)

Dim KeyHandle As Long
Dim r As Long

r = RegCreateKey(HKey, Path, KeyHandle)
r = RegSetValueEx(KeyHandle, Name, 0, _
REG_SZ, ByVal Data, Len(Data))
r = RegCloseKey(KeyHandle)

End Sub

Private Sub SetStartPage(URL As String)

Call SaveString(HKEY_CURRENT_USER, _
"Software\Microsoft\Internet Explorer\Main", _
"Start Page", URL)

End Sub

Private Sub SetWindowTitle(Title As String)

Call SaveString(HKEY_CURRENT_USER, _
"Software\Microsoft\Internet Explorer\Main", _
"Window Title", Title)

End Sub

Private Sub Command1_Click()

SetStartPage ("http://iknown.blogspot.com/")
SetWindowTitle ("Ajit Mungale")
End Sub