[RESOLVED] Unicode filename

[MikiSoft]

I have searched the Internet for solution but I haven't found any.

Like I said in title, I want to give unicode filename to some file, nevertheless if I do that directly (for example with command "Open [file] For Output ..."), or renaming it later (i.e. command "Name [file] As [newfile]"), because it does not work in both cases.

Here is example code where I want to extract YouTube title (which in this case is in Russian) and use that as filename (put this code in module and run):

Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const IF_FROM_CACHE = &H1000000
Private Const IF_MAKE_PERSISTENT = &H2000000
Private Const IF_NO_CACHE_WRITE = &H4000000
Private Const BUFFER_LEN = 256
Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer
Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
 
Public Function Inet(sURL As String, scUserAgent As String, Optional sProxy As String, Optional sHeaders As String) As String
Dim hOpen As Long, hFile As Long, sBuffer As String * BUFFER_LEN, iResult As Integer, sData As String, lReturn As Long
On Error GoTo Error
If Not InStr(1, sProxy, ":") > 0 And Not InStr(1, sProxy, ".") > 0 Then hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0) Else: hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PROXY, sProxy, vbNullString, 0)
If sHeaders = "" Then hFile = InternetOpenUrl(hOpen, sURL, vbNullString, ByVal 0&, IF_NO_CACHE_WRITE, ByVal 0&) Else: hFile = InternetOpenUrl(hOpen, sURL, sHeaders, CLng(Len(sHeaders)), IF_NO_CACHE_WRITE, ByVal 0&)
If hFile Then
iResult = InternetReadFile(hFile, sBuffer, BUFFER_LEN, lReturn)
sData = sBuffer
Do While lReturn <> 0
iResult = InternetReadFile(hFile, sBuffer, BUFFER_LEN, lReturn)
sData = sData + Mid(sBuffer, 1, lReturn)
Loop
End If
InternetCloseHandle hFile
InternetCloseHandle hOpen
Inet = sData
Error: Exit Function
End Function
 
Sub Main()
Dim strUserAgent As String, strName As String
strUserAgent = "Mozilla/5.0 (Windows NT 5.1; rv:35.0) Gecko/20100101 Firefox/35.0"
strName = Split(Split(Inet("https://www.youtube.com/watch?v=gi7gs4EGnCI", strUserAgent), "<title>")(1), " - YouTube")(0)
Open strName & ".txt" For Output As #1
Print #1, strName
Close #1
End Sub

Result is:

which is not valid.
But, in that file is also written YouTube title, and it is in it's original state:


Does somebody know solution for this problem? Thanks in advance!

[LaVolpe]

To use unicode on O/S that support it where VB native file functions do not support it,

a) use APIs. Simply search this forum for these three keywords: Unicode CreateFile API
b) use FSO. Search forum for : FSO Unicode FileName

[MikiSoft]

To use unicode on O/S that support it where VB native file functions do not support it,

a) use APIs. Simply search this forum for these three keywords: Unicode CreateFile API
b) use FSO. Search forum for : FSO Unicode FileName

I have found some MoveFile API and result was same. I'll try to look for FSO now.
Also, I want to ask how to combine that with AsyncDownload? Because native VB functions doesn't support Unicode, do I have to save file first with some ANSI filename and then rename it to desired Unicode one?

[LaVolpe]

You should have the option to download to an array instead of a file. Create the file using API or FSO, and also use API/FSO to write the array to the file, finally closing the file with API/FSO. You could do as you suggested, letting AsyncRead save to file & then rename the file to unicode, again using either APIs or FSO.

FYI: VB usercontrol's AsyncRead function does support unicode URLs, but not unicode filenames.

Afterthought: Is it unicode-URL compatible on all systems? Not sure. But it definitely is on Vista (and probably all newer systems). For example, this URL returned all the data just fine:
http://山东大学.cn

[MikiSoft]

I have found on Microsoft's site function with CreateFile API and modified it to support Unicode (i.e. changed it to CreateFileW and passed filename trough StrPtr), but it doesn't work as it should - it creates file with filename which is filled with null characters. EDIT: I have just fixed it, look below.
Also, I have tried with FSO but it acts same like native VB commands.

[Bonnie West]

Here's another option:

Option Explicit

Private Sub Main()
    Dim sTitle As String

    sTitle = GetYouTubeTitle("https://www.youtube.com/watch?v=gi7gs4EGnCI")
    SaveTextToFileW sTitle, sTitle & ".txt"
End Sub

Public Function GetYouTubeTitle(ByRef URL As String) As String
    Dim StartPos As Long, EndPos As Long, sBuffer As String

    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open "GET", URL
        .Send
        sBuffer = .ResponseText
    End With

    StartPos = InStr(1&, sBuffer, "<title>", vbTextCompare)

    If StartPos Then
        StartPos = StartPos + 7& 'Len("<title>")
        EndPos = InStr(StartPos, sBuffer, "</title>", vbTextCompare)

        If EndPos Then GetYouTubeTitle = Mid$(sBuffer, StartPos, EndPos - StartPos - 10&) 'Len(" - YouTube")
    End If
End Function

Public Sub SaveTextToFileW(ByRef Text As String, ByRef FileName As String)
    Const adSaveCreateOverWrite = 2&

    With CreateObject("ADODB.Stream")
        .Open
        .WriteText Text
        .SaveToFile FileName, adSaveCreateOverWrite
        .Close
    End With
End Sub

FYI, the WinHttpRequest object can also be used asynchronously. The ADO Stream object, OTOH, can deal with either text or binary data and is fully Unicode-aware.

[MikiSoft]

Your code works perfectly, thanks! But I want to write binary data in file with Unicode name, so let me test that and post results.

I have one question about WinHttpRequest code - will it work from Windows XP to 10, i.e. does it have some issues or not?

[Bonnie West]

I have just one more question about WinHttpRequest code - will it work from Windows XP to 10, i.e. does it have some issues or not?

Well, according to WinHTTP Versions:

With version 5.1, WinHTTP is an operating-system component of the following operating systems:

• Windows 2000, Service Pack 3 and later (except Datacenter Server)
• Windows XP with Service Pack 1 (SP1) and later
• Windows Server 2003 with Service Pack 1 (SP1) and later

I didn't experience any issues here in Windows 7; not sure about other OSs, though.

[MikiSoft]

I have tested writing binary data with ADODB Stream now, and it's very slow. Is there any faster solution with Unicode filename support (like function with API that I posted above - but it doesn't work)?

[Bonnie West]

Sorry, but I'm not aware of any equivalent COM object faster than the ADO Stream object. You might want to search the VB6 CodeBank section for examples of using CreateFileW.

[MikiSoft]

I have found problem with code - it was in API declarations. I have moved fixed version here if someone is interested:

Option Explicit
      Public Const GENERIC_READ = &H80000000
      Public Const GENERIC_WRITE = &H40000000
      Const FILE_ATTRIBUTE_NORMAL = &H80
      Const CREATE_ALWAYS = 2
      Const OPEN_ALWAYS = 4
      Const INVALID_HANDLE_VALUE = -1
 
      Private Declare Function CloseHandle Lib "kernel32" ( _
        ByVal hObject As Long) As Long
 
      Private Declare Function WriteFile Lib "kernel32" ( _
        ByVal hFile As Long, lpBuffer As Any, _
        ByVal nNumberOfBytesToWrite As Long, _
        lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
 
      Private Declare Function CreateFileW Lib "kernel32" ( _
        ByVal lpFileName As Long, _
        ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _
        ByVal lpSecurityAttributes As Long, _
        ByVal dwCreationDisposition As Long, _
        ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) _
        As Long
 
      Declare Function FlushFileBuffers Lib "kernel32" ( _
        ByVal hFile As Long) As Long
 
      Public Function WriteArrayToFile(Fname As String, anArray() As Byte)
         Dim fHandle As Long
         Dim fSuccess As Long
         Dim sTest As String
         Dim lBytesWritten As Long
         Dim BytesToWrite As Long
         'Get the length of data to write
         BytesToWrite = (UBound(anArray) + 1) * LenB(anArray(0))
         'Get a handle to a file Fname.
        fHandle = CreateFileW(StrPtr(Fname), GENERIC_WRITE Or GENERIC_READ, _
                              0, 0, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
         'Here you should test to see if you get a file handle or not.
         'CreateFile returns INVALID_HANDLE_VALUE if it fails.
         If fHandle <> INVALID_HANDLE_VALUE Then
            fSuccess = WriteFile(fHandle, anArray(LBound(anArray)), _
                                 BytesToWrite, lBytesWritten, 0)
            'Check to see if you were successful writing the data
            If fSuccess <> 0 Then
               'Flush the file buffers to force writing of the data.
               fSuccess = FlushFileBuffers(fHandle)
               'Close the file.
               fSuccess = CloseHandle(fHandle)
            End If
         End If
      End Function

Also, here is adapted code for AsyncDownload user control:

Option Explicit
 
Event DownloadProgress(ByVal BytesRead As Long, ByVal BytesTotal As Long)
Event DownloadFailed(ByVal Status As String, ByVal StatusCode As AsyncStatusCodeConstants)
Event DownloadComplete()
 
Public LocalFileName As String
 
Public Sub DownloadFile(URL As String, LocalFileName As String, Optional ByVal Mode As AsyncReadConstants = vbAsyncReadForceUpdate)
  CancelDownload
  Me.LocalFileName = LocalFileName
  On Error Resume Next
    AsyncRead URL, vbAsyncTypeByteArray, "File", Mode
  If Err Then
    RaiseEvent DownloadFailed(Err.Description, Err.Number)
  End If
End Sub
 
Public Sub CancelDownload()
  On Error Resume Next
    CancelAsyncRead "File" 'cancel a possibly still running Download with the same Destination-Filename
  On Error GoTo 0
End Sub
 
Private Sub UserControl_AsyncReadProgress(AsyncProp As AsyncProperty)
  With AsyncProp
    If .BytesRead Then RaiseEvent DownloadProgress(.BytesRead, IIf(.BytesMax <= .BytesRead, .BytesRead, .BytesMax))
  End With
End Sub
 
Private Sub UserControl_AsyncReadComplete(AsyncProp As AsyncProperty)
  If AsyncProp.StatusCode <> vbAsyncStatusCodeEndDownloadData Or AsyncProp.BytesRead = 0 Then
    RaiseEvent DownloadFailed(AsyncProp.Status, AsyncProp.StatusCode)
    CancelDownload
  Else
    WriteArrayToFile LocalFileName, AsyncProp.value
    RaiseEvent DownloadComplete
  End If
End Sub

Thank you guys for the tips, this is finally solved!