Private m_szPath As String
Private Function UChartoChar(ByVal strVal As String) As String
Dim strRes As String
'hyperlabel(unicode pur) vers utf 8
strRes = StrConv(strVal, vbFromUnicode)
UChartoChar = strRes
End Function
Private Function ChartoUChar(ByVal strVal As String) As String
Dim strRes As String
'utf8 vers hyperlabel(unicode pur)
strRes = StrConv(strVal, vbUnicode)
ChartoUChar = strRes
End Function
Private Function PrintLine(ByRef FileSource As Scripting.TextStream, ByVal nRow As Integer) As Integer
Dim nColumn As Integer
Dim nRes As Integer
Dim strName As String
Dim strVal As String
nColumn = 1
While Cells(1, nColumn).Value <> ""
strVal = ChartoUChar(Cells(nRow, nColumn).Value)
If nColumn > 1 Then FileSource.Write ChartoUChar(";")
FileSource.Write strVal
'strName = ChartoUChar(Cells(1, nColumn).Value)
'strVal = ChartoUChar(Cells(nRow, nColumn).Value)
'nRes = HLBDLL_SetObjectValue(nDocID, strName, strVal)
nColumn = nColumn + 1
Wend
FileSource.Write ChartoUChar(Chr(13))
FileSource.Write ChartoUChar(Chr(10))
PrintLine = nRes
End Function
Private Sub ButtonCancel_Click()
Hide
End Sub
Private Function IsRowEmpty(ByVal nRow As Integer) As Integer
Dim nRes As Integer
Dim nColumn As Integer
Dim strVal As String
nRes = 0
nColumn = 1
While Cells(1, nColumn).Value <> "" And nRes <> 1
If Cells(nRow, nColumn).Value <> "" Then
nRes = 1
End If
nColumn = nColumn + 1
Wend
IsRowEmpty = nRes
End Function
Private Sub ButtonPrint_Click()
Dim nRes As Integer
Dim nRowID As Integer
Dim fso As Scripting.FileSystemObject 'il faut ajouter dans les réferences Microsoft scripting runtime
Dim FileSource As Scripting.TextStream
Dim bContinu As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
Set FileSource = fso.CreateTextFile(m_szPath)
nRes = PrintLine(FileSource, 1)
nRowID = 2
bContinu = IsRowEmpty(nRowID)
While bContinu
nRes = PrintLine(FileSource, nRowID)
nRowID = nRowID + 1
bContinu = IsRowEmpty(nRowID)
Wend
FileSource.Close
Set fso = Nothing
Set FileSource = Nothing
MsgBox ("Les données ont été envoyées")
End Sub
Private Sub Quitter_Click()
Hide
End Sub
Private Sub TextBoxCurrentDir_Change()
m_szPath = TextBoxCurrentDir.Value
SaveSetting "DataToScreen", "Setting", "Directory", TextBoxCurrentDir.Value
End Sub
Private Sub UserForm_Initialize()
Dim bRes As Boolean
Dim strCurSheet As String
Dim strPrinter As String
Dim nRow As Integer
Dim nRes As Integer
Dim nIndice, i As Integer
Dim strPrinters As String * 1024
Dim nPrinter As String
strCurSheet = ActiveSheet.Name
m_szPath = GetSetting("DataToScreen", "Setting", "Directory", "c:\")
If m_szPath = "" Then m_szPath = "c:\"
TextBoxCurrentDir.Value = m_szPath
Exit Sub
CheckError:
Exit Sub
End Sub
Uploading ....