تبديل كد vb6 به دلفي

[Restlesa]

سلام بر دوستان عزيز
از وي بي كاران محترم كسي آشنايتي با دلفي داره ؟؟؟
لطفا كد زير رو برام به دلفي كامپايل كنه با تشكر فراوان :بوس::بوس::بوس:


Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey&) As Long
Private Declare Sub SHChangeNotify Lib "shell32.dll" (ByVal wEventId As Long, ByVal uFlags As Long, ByRef dwItem1 As Any, ByRef dwItem2 As Any)
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long

Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey&, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey&, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey&, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey&, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long

Private Const SHCNF_IDLIST As Long = &H0
Private Const WM_WININICHANGE As Long = &H1A
Private Const SHCNE_ATTRIBUTES As Long = &H800&
Private Const HWND_BROADCAST As Long = &HFFFF&
Private Const SHCNE_ASSOCCHANGED As Long = &H8000000
Private Const WM_SETTINGCHANGE As Long = WM_WININICHANGE

Const REG_SZ = 1
Const hKey& = &H80000000 'HKEY_CLASSES_ROOT

Sub Main()
On Error Resume Next
Set MainForm = New MDIForm1
MainForm.Show
If Command <> "" Then
MainForm.ActiveForm.rtfText1.LoadFile Command
MainForm.ActiveForm.Caption = GetOnlyFileName$(Command)
Else
ConnectExtsToMe "medoc", App.Path & "\MyIcon.ico"
ConnectExtsToMe "txt", App.Path & "\icon2.ico"
ConnectExtsToMe "rtf", App.Path & "\icon3.ico"
End If
End Sub

Sub ConnectExtsToMe(Ext$, FileIconPath$, Optional ForcesRefresh As Boolean = False)
On Error Resume Next
Dim ext_dat$, SysRefresh As Boolean

Ext$ = Trim(Ext$)
ext_dat$ = Ext$ & "file"
Ext$ = IIf(Left(Ext$, 1) <> ".", "." & Ext$, Ext$)

SaveString Ext$, "", ext_dat$
SaveString ext_dat$, "", "IPG Notepad"
SysRefresh = LCase(GetString(ext_dat$ & "\DefaultIcon", "")) <> LCase(FileIconPath$)
SaveString ext_dat$ & "\DefaultIcon", "", FileIconPath$
SaveString ext_dat$ & "\shell\open", "", "Open this files with " & App.ProductName
SaveString ext_dat$ & "\shell\open\command", "", """" & App.Path & "\" & App.EXEName & ".exe""" & " %1"

If SysRefresh = True Or ForcesRefresh = True Then
Call SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0&, ByVal 0&)
Call SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, 0, 0)
End If
End Sub

Sub SaveString(ByVal strPath As String, ByVal strValue As String, ByVal strdata As String)
On Error Resume Next
Dim Keyhand As Long, r As Long, lResult

r = RegCreateKey(hKey, strPath, Keyhand)
lResult = RegSetValueEx(Keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
r = RegCloseKey(Keyhand)
End Sub

Function GetString(ByVal strPath As String, ByVal strValue As String)
On Error Resume Next
Dim Keyhand As Long, datatype As Long, lResult As Long
Dim strBuf As String, lDataBufSize As Long, intZeroPos As Integer

r = RegOpenKey(hKey, strPath, Keyhand)
lResult = RegQueryValueEx(Keyhand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)

If lValueType = REG_SZ Then
strBuf = String(lDataBufSize, " ")
lResult = RegQueryValueEx(Keyhand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)
If lResult = ERROR_SUCCESS Then
intZeroPos = InStr(strBuf, Chr$(0))
GetString = Left$(strBuf, intZeroPos - 1)
End If
End If
End Function

Public Function GetOnlyFileName$(FilePth$)
On Error Resume Next
FilePth$ = Trim(FilePth$)
GetOnlyFileName$ = Mid$(FilePth$, InStrRev(FilePth$, "\") + 1)
GetOnlyFileName$ = Left(GetOnlyFileName$, InStrRev(GetOnlyFileName$, ".") - 1)
End Function