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

Question

以下示例代码是用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

Answer 1

不会转换，但是你在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 LongPrivate Sub Command1_Click()
    Dim lResult As Long
    lResult = AddFontResource("e:\myFont.ttf")
End Sub同样用RemoveFontResource也可以删除字体。

Answer 2

晕死，上述代码在XP下跑了一遍竟然没成功，下面的代码是我自己写的，就是简单的把一个字体文件复制到系统的fonts文件夹，XP下没问题。Private Declare Function GetWindowsDirectory Lib "KERNEL32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As LongPrivate 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 FunctionPrivate Function GetName(s As String) As String
    GetName = Right(s, Len(s) - InStr(1, s, "\"))
End FunctionPrivate Sub Command1_Click()
    Dim sFontPath As String
    sFontPath = GetWinPath + "\fonts\"
    FileCopy "d:\简细珊瑚.ttf", sFontPath + GetName("d:\简细珊瑚.ttf")
End Sub