将StrPtr指针再次转换为实际字符串

Question

使用StrPtr（）我可以获得一个指向内存中字符串的指针，但我想将其反转并从指针中获取字符串。

如何做到这一点？

谢谢！

由于我遇到了建议解决方案的问题，我现在在这里发布我的整个代码：

Private Declare Function WTSQueryUserToken Lib "Wtsapi32.dll" (ByVal SessionID As Long, ByRef phToken As Long) As Long

Private Const WTS_CURRENT_SERVER_HANDLE = 0&

Private Enum WTS_CONNECTSTATE_CLASS
WTSActive
WTSConnected
WTSConnectQuery
WTSShadow
WTSDisconnected
WTSIdle
WTSListen
WTSReset
WTSDown
WTSInit
End Enum

Private Type WTS_SESSION_INFO
    SessionID As Long
    pWinStationName As Long
    state As WTS_CONNECTSTATE_CLASS
End Type

Private Declare Function WTSEnumerateSessions _
Lib "Wtsapi32.dll" Alias "WTSEnumerateSessionsA" ( _
ByVal hServer As Long, ByVal Reserved As Long, _
ByVal Version As Long, ByRef ppSessionInfo As Long, _
ByRef pCount As Long _
) As Long

Private Declare Sub WTSFreeMemory Lib "Wtsapi32.dll" ( _
ByVal pMemory As Long)

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
Destination As Any, Source As Any, ByVal length As Long)

Private Declare Function lstrlenA Lib "kernel32" ( _
ByVal lpString As String) As Long

Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" ( _
ByVal lpString1 As String, ByVal lpString2 As Long) As Long

Public Function StrPtrToString(ByVal u As Long) As String

    Dim s As String
    s = StrConv(SysAllocString(u), vbFromUnicode)

    StrPtrToString = s

End Function

Private Sub pUpdate(ByVal uPath As String)

    Dim arrWTSSessions() As WTS_SESSION_INFO
    arrWTSSessions = GetWTSSessions

    WriteLog "We have " & UBound(arrWTSSessions) & " sessions."

    Dim i&
    For i = LBound(arrWTSSessions) To UBound(arrWTSSessions)

'            // Extract each session info and check if it is the
'            // "Active Session" of the current logged-on user.
            Dim tSessionInfo As WTS_SESSION_INFO
            tSessionInfo = arrWTSSessions(i)

            WriteLog "Session " & i & " state: " & tSessionInfo.state & ", id: " & tSessionInfo.SessionID & ", name: " & StrPtrToString(tSessionInfo.pWinStationName)

    Next i

End Sub

Private Function GetWTSSessions() As WTS_SESSION_INFO()

    Dim RetVal As Long
    Dim lpBuffer As Long
    Dim lCount As Long
    Dim p As Long
    Dim arrSessionInfo() As WTS_SESSION_INFO

    RetVal = WTSEnumerateSessions(WTS_CURRENT_SERVER_HANDLE, _
    0&, _
    1, _
    lpBuffer, _
    lCount)

    If RetVal Then
        ' WTSEnumerateProcesses was successful.

        p = lpBuffer
        ReDim arrSessionInfo(lCount - 1) '0)  '0 to  (lCount – 1))

        CopyMemory arrSessionInfo(0), ByVal p, lCount * LenB(arrSessionInfo(0))
        ' Free the memory buffer.
        WTSFreeMemory lpBuffer

    Else
        ' Error occurred calling WTSEnumerateProcesses.
        ' Check Err.LastDllError for error code.
        MsgBox "An error occurred calling WTSEnumerateProcesses. " & _
        "Check the Platform SDK error codes in the MSDN Documentation " & _
        "for more information.", vbCritical, "ERROR " & Err.LastDllError
    End If

    GetWTSSessions = arrSessionInfo

End Function

Public Function StartAppInSessionAsAdmin(ByVal SessionID As String, ByVal WinstationNameStrPtr As Long, ByVal AppName As String) As Integer

    If Not FileExists(AppName) Then
        WriteLog "#FFOOOOOOOO! appname does not exist: " & AppName
    End If

    WriteLog "sta: " & StrPtrToString(WinstationNameStrPtr)

    WriteLog "appname: " & AppName

    WriteLog "pstartappinsessions step 1"

    Dim hToken&
    Dim hLinkedToken&
   ' Dim bRet As Boolean
    Dim pi  As PROCESS_INFORMATION
    Dim si As STARTUPINFO
    Dim lErr&
    Dim iRet&
    Dim lpEB&

    Dim TLT As TOKEN_LINKED_TOKEN
    Dim TLTSize&
    Dim retSize&

    WriteLog "pstartappinsessions step 2"

    si.lpDesktop = WinstationNameStrPtr 'StrPtr("Winsta0\default") ' WinstationName  '”Winsta0\default”
    si.cb = Len(si) 'Marshal.SizeOf(si)

    WriteLog "pstartappinsessions step 3"



    WriteLog "pstartappinsessions step 4"

    TLTSize = Len(TLT.LinkedToken) '.SizeOf(TLT.LinkedToken)

    WriteLog "pstartappinsessions step 5"

    'get SessionID token
    Dim bRet As Boolean
    bRet = WTSQueryUserToken(SessionID, hToken)

    WriteLog "wtsqueryusertoken: " & bRet

    'we need to get the TokenLinked Token
    bRet = GetTokenInformation(hToken, TOKEN_INFORMATION_CLASS.TokenLinkedToken, hLinkedToken, TLTSize, retSize)

    WriteLog "gettokeninformation: " & bRet

    'Use CreateEnvironment Block with the original token to create an environment for the new program with the USER Environment
    bRet = CreateEnvironmentBlock(lpEB, hToken, False)

    WriteLog "Createenvblock: " & bRet

    If bRet Then
        'NB. Must append a space before the command-line else it
        ' will be chopped off up to the end of the first space in the string
        'Call CreateProcessAsUser to create the process using the user's modified Token

        iRet = CreateProcessAsUser(hLinkedToken, "", " " & AppName, 0&, 0&, 0&, NORMAL_PRIORITY_CLASS, 0&, 0&, si, pi)


        'Give user a feedback
        If iRet <> 0 Then
            WriteLog ":-) createprocessasuser succeeded!"
            'GiveFeedback(SessionID, "Message from StartAppInSessionAsAdmin", "CreateProcessAsUser succeeded", 2)
        Else
            WriteLog ":-( failed createprocessasuser! error: " & Err.LastDllError
            'err = Marshal.GetLastWin32Error
            'GiveFeedback(SessionID, "Message from StartAppInSessionAsAdmin", "CreateProcessAsUser failed with error " & err.ToString, 5)
        End If
    End If

    WriteLog "pstartappinsessions}"

End Function

Private Sub WriteLog(ByVal uText As String)

    WriteText Now & vbTab & uText, "c:\users\myuser\desktop\log.txt", False

End Sub
Public Function WriteText(ByVal uString As String, ByVal uPath As String, Optional ByVal uDeleteFileBeforeWriting As Boolean = False, Optional ByRef uError As String) As Boolean
On Error GoTo Errhandler

    If uDeleteFileBeforeWriting Then
        If Not DeleteFile(uPath, uError) Then
            Exit Function
        End If
    End If

    If VBA.Len(uString) = 0 Then
        uError = uError & " + no string"
        Exit Function
    End If

    Debug.Assert VBA.Len(uPath) > 0

    Dim fso As Object 'Scripting.FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim strm As Object ' Scripting.TextStream
    Set strm = fso.OpenTextFile(uPath, 8, True, -1)

    strm.WriteLine uString
    strm.Close

    Set strm = Nothing
    Set fso = Nothing

    uError = "no error"

    WriteText = True

Exit Function
Errhandler:
uError = Err.Description & ": " & Err.Number
On Error GoTo -1
End Function

Answer 1

试试这个。我改为s = SysAllocStringByteLen(u, lstrlen(u))

Private Declare Function SysAllocStringByteLen Lib "oleaut32.dll" (ByVal m_pBase As Long, ByVal l As Long) As String
Private Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" (ByVal lpString As Long) As Long

。

Public Function StrPtrToString(ByVal u As Long) As String

    Dim s As String

    s = SysAllocStringByteLen(u, lstrlen(u))

    StrPtrToString = s

End Function

Answer 2

编辑：实际上，它是LPTSTR，所以这是正确的代码：

Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" ( _
ByVal lpString1 As String, ByVal lpString2 As Long) As Long

Public Function PointerToStringA(ByVal lpStringA As Long) As String
   Dim nLen As Long
   Dim sTemp As String

   If lpStringA Then
      nLen = lstrlenA(ByVal lpStringA)
      If nLen Then
         sTemp = String(nLen, vbNullChar)
         lstrcpy sTemp, ByVal lpStringA
         PointerToStringA = sTemp
      End If
   End If
End Function

Answer 3

运行VB6程序时不会给我零星错误的唯一版本是：

Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
   (lpDest As Any, lpSource As Any, ByVal nCount As Long)

Function pGetStringFromPointerA(ByVal lPtr As Long) As String
    Dim abBuffer() As Byte
    Dim lLength As Long

    pGetStringFromPointerA = ""
    If (lPtr) Then
        lLength = lstrlenA(lPtr)
        If (lLength) Then
            ReDim abBuffer(lLength * 2 + 1)
            Call CopyMemory(abBuffer(0), ByVal lPtr, lLength + 1)
            pGetStringFromPointerA = StrConv(abBuffer, vbUnicode)
        End If
    End If
End Function

其他版本似乎一开始就可以使用，但是会导致程序不同部分出现随机错误。