谁能把微软提供的这段VF代码转化成VB代码？

[ygxcxy]

以下示例代码是用VF安装新字体,我想用VB实现相同功能，请各位大侠指教！
*-- Code begins here
CLEAR DLLS

PRIVATE iRetVal, iLastError
PRIVATE sFontDir, sSourceDir, sFontFileName, sFOTFile
PRIVATE sWinDir, iBufLen
iRetVal = 0

***** Code to customize with actual file names and locations.
*-- .TTF file path.
sSourceDir = "C:\TEMP\"

*-- .TTF file name.
sFontFileName = "TestFont.TTF"

*-- Font description (as it will appear in Control Panel).
sFontName = "My Test Font" + " (TrueType)"
******************** End of code to customize *****

DECLARE INTEGER CreateScalableFontResource IN win32api ;
LONG fdwHidden, ;
STRING lpszFontRes, ;
STRING lpszFontFile, ;
STRING lpszCurrentPath

DECLARE INTEGER AddFontResource IN win32api ;
STRING lpszFilename

DECLARE INTEGER RemoveFontResource IN win32api ;
STRING lpszFilename

DECLARE LONG GetLastError IN win32api

DECLARE INTEGER GetWindowsDirectory IN win32api STRING @lpszSysDir,;
INTEGER iBufLen

#DEFINE WM_FONTCHANGE 29 && 0x001D
#DEFINE HWND_BROADCAST 65535 && 0xffff

DECLARE LONG SendMessage IN win32api ;
LONG hWnd, INTEGER Msg, LONG wParam, INTEGER lParam

#DEFINE HKEY_LOCAL_MACHINE 2147483650 && (HKEY) 0x80000002
#DEFINE SECURITY_ACCESS_MASK 983103 && SAM value KEY_ALL_ACCESS

DECLARE RegCreateKeyEx IN ADVAPI32.DLL ;
INTEGER, STRING, INTEGER, STRING, INTEGER, INTEGER, ;
INTEGER, INTEGER @, INTEGER @

DECLARE RegSetValueEx IN ADVAPI32.DLL;
INTEGER, STRING, INTEGER, INTEGER, STRING, INTEGER

DECLARE RegCloseKey IN ADVAPI32.DLL INTEGER

*-- Fonts folder path.
*-- Use the GetWindowsDirectory API function to determine
*-- where the Fonts directory is located.
sWinDir = SPACE(50) && Allocate the buffer to hold the directory name.
iBufLen = 50 && Pass the size of the buffer.
iRetVal = GetWindowsDirectory(@sWinDir, iBufLen)

*-- iRetVal holds the length of the returned string.
*-- Since the string is null-terminated, we need to
*-- snip the null off.
sWinDir = SUBSTR(sWinDir, 1, iRetVal)
sFontDir = sWinDir + "\FONTS\"

*-- Get .FOT file name.
sFOTFile = sFontDir + LEFT(sFontFileName, ;
LEN(sFontFileName) - 4) + ".FOT"

*-- Copy to Fonts folder.
COPY FILE (sSourceDir + sFontFileName) TO ;
(sFontDir + sFontFileName)

*-- Create the font.
iRetVal = ;
CreateScalableFontResource(0, sFOTFile, sFontFileName, sFontDir)
IF iRetVal = 0 THEN
iLastError = GetLastError ()
IF iLastError = 80
MESSAGEBOX("Font file " + sFontDir + sFontFileName + ;
"already exists.")
ELSE
MESSAGEBOX("Error " + STR (iLastError))
ENDIF
RETURN
ENDIF

*-- Add the font to the system font table.
iRetVal = AddFontResource (sFOTFile)
IF iRetVal = 0 THEN
iLastError = GetLastError ()
IF iLastError = 87 THEN
MESSAGEBOX("Incorrect Parameter")
ELSE
MESSAGEBOX("Error " + STR (iLastError))
ENDIF
RETURN
ENDIF

*-- Make the font persistent across reboots.
STORE 0 TO iResult, iDisplay
iRetVal = RegCreateKeyEx(HKEY_LOCAL_MACHINE, ;
"SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts", 0, "REG_SZ", ;
0, SECURITY_ACCESS_MASK, 0, @iResult, ;
@iDisplay) && Returns .T. if successful

*-- Uncomment the following lines to display information
*!* *-- about the results of the function call.
*!* WAIT WINDOW STR(iResult) && Returns the key handle
*!* WAIT WINDOW STR(iDisplay) && Returns one of 2 values:
*!* && REG_CREATE_NEW_KEY = 1
*!* && REG_OPENED_EXISTING_KEY = 2

iRetVal = RegSetValueEx(iResult, sFontName, 0, 1, sFontFileName, 13)

*-- Close the key. Don't keep it open longer than necessary.
iRetVal = RegCloseKey(iResult)

*-- Notify all the other application a new font has been added.
iRetVal = SendMessage (HWND_BROADCAST, WM_FONTCHANGE, 0, 0)
IF iRetVal = 0 THEN
iLastError = GetLastError ()
MESSAGEBOX("Error " + STR (iLastError))
RETURN
ENDIF

ERASE (sFOTFile)
*-- Code ends here

[happy_sea]

不会转换，但是你在VB中安装某种字体用不着那么麻烦，用下面的代码就行了：

Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long

Private Sub Command1_Click()
Dim lResult As Long
lResult = AddFontResource("e:\myFont.ttf")
End Sub

同样用RemoveFontResource也可以删除字体。

[happy_sea]

晕死，上述代码在XP下跑了一遍竟然没成功，下面的代码是我自己写的，就是简单的把一个字体文件复制到系统的fonts文件夹，XP下没问题。

Private Declare Function GetWindowsDirectory Lib "KERNEL32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Private Function GetWinPath()
Dim strFolder As String
Dim lngResult As Long
strFolder = String(255, 0)
lngResult = GetWindowsDirectory(strFolder, 255)
If lngResult <> 0 Then
GetWinPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1)
Else
GetWinPath = ""
End If
End Function

Private Function GetName(s As String) As String
GetName = Right(s, Len(s) - InStr(1, s, "\"))
End Function

Private Sub Command1_Click()
Dim sFontPath As String
sFontPath = GetWinPath + "\fonts\"
FileCopy "d:\简细珊瑚.ttf", sFontPath + GetName("d:\简细珊瑚.ttf")
End Sub