How can I get the path of the current user that is as same as %UserProfile% result in Windows 7?
Or, quite simply:
MsgBox Environ$("USERPROFILE")
You can use the Environ() method in VBA to expand environmental variables, just pass the argument as a string and drop the % markers.
I use this function:
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
' Return the user's profile path.
Private Function ProfilePath() As String
Dim win_dir As String
Dim user_name As String
Dim ret_len As Long
' Get the windows directory.
win_dir = Space$(256)
ret_len = GetWindowsDirectory(win_dir, Len(win_dir))
win_dir = Left$(win_dir, ret_len)
' Get the user's name.
user_name = Space$(256)
GetUserName user_name, ret_len
user_name = Left$(user_name, ret_len)
If (Asc(Right$(user_name, 1)) = 0) Then
user_name = Left$(user_name, Len(user_name) - 1)
End If
ProfilePath = win_dir & "\" & user_name
End Function
Related
I'm writing a very simple macro that needs to make an HTTP GET request to a server and the response is not important (it initiates a process on the server). The HTTP GET does NOT require authentication.
I'm using the following code to do this "successfully" (the server logs indicated the request made it to the server, but the server is running HTTP 406):
Function callAPI(Url As String)
With ActiveSheet.QueryTables.Add(Connection:="URL;" & Url, Destination:=Range("D15"))
.PostText = ""
.RefreshStyle = xlOverwriteCells
.SaveData = True
.Refresh
End With
End Function
But I get back the following response from the server:
Unable to open http://someurl.com Cannot locate the Internet server or proxy server.
I can see the server is return an HTTP 406 which, after some research is occurring because the GET request is not sending the correct Content-Type header.
So my question is - how do tell ActiveSheet.QueryTables.Add to set the header, or how do I modify my NGINX config to support this specific GET CALL
Here is a piece of code that supports both OSX and Windows. I would credit the authors of this because I certainly didnt write this from scratch but I have lost track of where it all came from:
#If Win32 Then
Function getHTTP(URL As String, sQuery As String) As String
Dim strResult As String
Dim objHTTP As Object
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
objHTTP.Open "GET", URL & "?" & sQuery, False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.send("")
strResult = objHTTP.responseText
getHTTP = strResult
End Function
#Else
Option Explicit
' execShell() function courtesy of Robert Knight via StackOverflow
' http://stackoverflow.com/questions/6136798/vba-shell-function-in-office-2011-for-mac
Private Declare Function popen Lib "libc.dylib" (ByVal command As String, ByVal mode As String) As Long
Private Declare Function pclose Lib "libc.dylib" (ByVal file As Long) As Long
Private Declare Function fread Lib "libc.dylib" (ByVal outStr As String, ByVal size As Long, ByVal items As Long, ByVal stream As Long) As Long
Private Declare Function feof Lib "libc.dylib" (ByVal file As Long) As Long
Function execShell(command As String, Optional ByRef exitCode As Long) As String
Dim file As Long
file = popen(command, "r")
If file = 0 Then
Exit Function
End If
While feof(file) = 0
Dim chunk As String
Dim read As Long
chunk = Space(50)
read = fread(chunk, 1, Len(chunk) - 1, file)
If read > 0 Then
chunk = Left$(chunk, read)
execShell = execShell & chunk
End If
Wend
exitCode = pclose(file)
End Function
Function getHTTP(sUrl As String, sQuery As String) As String
Dim sCmd As String
Dim sResult As String
Dim lExitCode As Long
sCmd = "curl --get -d """ & sQuery & """" & " " & sUrl
sResult = execShell(sCmd, lExitCode)
' ToDo check lExitCode
getHTTP = sResult
End Function
#End If
This wasn't working for me on Mac Excel 15.4 either. I found a helpful version on VBA-Tools Github Here:
https://github.com/VBA-tools/VBA-Web/issues/248
Here's the version that worked for me:
Private Declare PtrSafe Function web_popen Lib "libc.dylib" Alias "popen" (ByVal command As String, ByVal mode As String) As LongPtr
Private Declare PtrSafe Function web_pclose Lib "libc.dylib" Alias "pclose" (ByVal file As LongPtr) As Long
Private Declare PtrSafe Function web_fread Lib "libc.dylib" Alias "fread" (ByVal outStr As String, ByVal size As LongPtr, ByVal items As LongPtr, ByVal stream As LongPtr) As Long
Private Declare PtrSafe Function web_feof Lib "libc.dylib" Alias "feof" (ByVal file As LongPtr) As LongPtr
Public Function executeInShell(web_Command As String) As String
Dim web_File As LongPtr
Dim web_Chunk As String
Dim web_Read As Long
On Error GoTo web_Cleanup
web_File = web_popen(web_Command, "r")
If web_File = 0 Then
Exit Function
End If
Do While web_feof(web_File) = 0
web_Chunk = VBA.Space$(50)
web_Read = web_fread(web_Chunk, 1, Len(web_Chunk) - 1, web_File)
If web_Read > 0 Then
web_Chunk = VBA.Left$(web_Chunk, web_Read)
executeInShell = executeInShell & web_Chunk
End If
Loop
web_Cleanup:
web_pclose (web_File)
End Function
Function getHTTP(sUrl As String, sQuery As String) As String
Dim sCmd As String
Dim sResult As String
Dim lExitCode As Long
sCmd = "curl --get -d """ & sQuery & """" & " " & sUrl
sResult = executeInShell(sCmd)
getHTTP = sResult
End Function
I have a .ini file setup from which I read connection strings. I have a modeule to read the strings:
Option Explicit
Private Declare Function GetPrivateProfileString Lib "kernel32" _
Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any _
, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long _
, ByVal lpFileName As String) As Long
Public Const iniPath = "\DBSettings.INI"
Public Sub Main()
Dim dbPath As String
Dim dbPath As String
dbPath = GetSetting("DataBase", "DBPath")
dbPath= GetSetting("DataBase", "DBPath")
Form1.Show
End Sub
Private Function GetSetting(ByVal pHeading As String, ByVal pKey As String) As String
Const cparmLen = 100
Dim sReturn As String * cparmLen
Dim sDefault As String * cparmLen
Dim aLength As Long
aLength = GetPrivateProfileString(pHeading, pKey _
, sDefault, sReturn, cparmLen, App.Path & iniPath)
GetSetting = Mid(sReturn, 1, aLength)
End Function
Now, I am trying to display the strings on click of a button:
Option Explicit
Public Sub Command1_Click()
MsgBox (dbPath)
MsgBox (dbPath)
End Sub
However, it seems the form cannot see the variables in the module. How may I fix this?
Any help would be appreciated.
dbPath is declared in a sub so scoping rules state that the variable only exists within that sub.
To make a variable visible everywhere declare it in a module with the public access modifier:
public dbPath as string
And remove the dim in main()
DBPath is a Procedure Scope variable, as it is declared inside a Procedure (Sub Main()).
It will not be visible from other modules, or even the module itself.
And also, you cannot declare a Public variable inside a Procedure (Sub or Function).
For further info regarding variable scope:
http://msdn.microsoft.com/en-us/library/1t0wsc67.aspx
I have a .CHM Help file for my VB6 App. I need to change the location, at run time from the help file location specified in the project properties. I DO NOT want to use some form of HTML help. I just need to know how to change the location that the program looks to find the .CHM help file.
Anybody run into this issue?
I want to store the help file on the Server with the data files, not on individual machines running the application.
Set the HelpFile attribute of the App object as below:
App.HelpFile = g_Path_to_Your_CHM & "\YourHelpFile.chm"
Please note there are some security problems with CHM on a Server!
In addition to rags answer above you may want to call the help file like this:
Public Sub ShowContents(ByVal intHelpFile As Integer)
HtmlHelp hwnd, HFile(intHelpFile), HH_DISPLAY_TOC, 0
End Sub
It's called by :
Public Function HFile(ByVal i_HFile As Integer) As String
'----- Set the string variable to include the application path of helpfile
Select Case i_HFile
Case 1
HFile = App.Path & "\help\CHM-example.chm"
Case 2
'----- Place other Help file paths in successive case statements
HFile = App.Path & "\help\CHM-other-language.chm"
End Select
End Function
All this is added by a module:
'******************************************************************************
'----- Modul - definition for HTMLHelp - (c) Ulrich Kulle, www.help-info.de
'----- 2002-08-26 Version 1.0 first release
'----- 2005-07-17 Version 1.1 updated for Pop-Up help
'******************************************************************************
'----- Portions of this code courtesy of David Liske.
'----- Thanks to David Liske, Don Lammers, Matthew Brown and Thomas Schulz
'------------------------------------------------------------------------------
Type HH_IDPAIR
dwControlId As Long
dwTopicId As Long
End Type
'This array should contain the number of controls that have
'context-sensitive help, plus one more for a zero-terminating
'pair.
Public ids(2) As HH_IDPAIR
Declare Function GetDlgCtrlID Lib "user32" _
(ByVal hwnd As Long) As Long
Public Declare Function HtmlHelp Lib "hhctrl.ocx" Alias "HtmlHelpA" _
(ByVal hwndCaller As Long, ByVal pszFile As String, _
ByVal uCommand As Long, ByVal dwData As Long) As Long
Declare Function HTMLHelpTopic Lib "hhctrl.ocx" Alias "HtmlHelpA" _
(ByVal hwndCaller As Long, ByVal pszFile As String, _
ByVal uCommand As Long, ByVal dwData As String) As Long
Private Declare Function HtmlHelpSearch Lib "hhctrl.ocx" Alias "HtmlHelpA" _
(ByVal hwndCaller As Long, ByVal pszFile As String, _
ByVal uCommand As Long, dwData As HH_FTS_QUERY) As Long
Public Const HH_DISPLAY_TOPIC = &H0 ' select last opened tab, [display a specified topic]
Public Const HH_DISPLAY_TOC = &H1 ' select contents tab, [display a specified topic]
Public Const HH_DISPLAY_INDEX = &H2 ' select index tab and searches for a keyword
Public Const HH_DISPLAY_SEARCH = &H3 ' select search tab and perform a search
Private Const HH_SET_WIN_TYPE = &H4
Private Const HH_GET_WIN_TYPE = &H5
Private Const HH_GET_WIN_HANDLE = &H6
Private Const HH_DISPLAY_TEXT_POPUP = &HE ' Display string resource ID or
Public Const HH_HELP_CONTEXT = &HF ' display mapped numeric value in dwData
Private Const HH_TP_HELP_CONTEXTMENU = &H10 ' Text pop-up help, similar to WinHelp's HELP_CONTEXTMENU.
Private Const HH_TP_HELP_WM_HELP = &H11 ' text pop-up help, similar to WinHelp's HELP_WM_HELP.
Public Type HH_FTS_QUERY ' UDT for accessing the Search tab
cbStruct As Long ' Sizeof structure in bytes.
fUniCodeStrings As Long ' TRUE if all strings are unicode.
pszSearchQuery As String ' String containing the search query.
iProximity As Long ' Word proximity.
fStemmedSearch As Long ' TRUE for StemmedSearch only.
fTitleOnly As Long ' TRUE for Title search only.
fExecute As Long ' TRUE to initiate the search.
pszWindow As String ' Window to display in
End Type
Public Function HFile(ByVal i_HFile As Integer) As String
'----- Set the string variable to include the application path of helpfile
Select Case i_HFile
Case 1
HFile = App.Path & "\help\CHM-example.chm"
Case 2
'----- Place other Help file paths in successive case statements
HFile = App.Path & "\help\CHM-other-language.chm"
End Select
End Function
Public Sub ShowContents(ByVal intHelpFile As Integer)
HtmlHelp hwnd, HFile(intHelpFile), HH_DISPLAY_TOC, 0
End Sub
Public Sub ShowIndex(ByVal intHelpFile As Integer)
HtmlHelp hwnd, HFile(intHelpFile), HH_DISPLAY_INDEX, 0
End Sub
Public Sub ShowTopic(ByVal intHelpFile As Integer, strTopic As String)
HTMLHelpTopic hwnd, HFile(intHelpFile), HH_DISPLAY_TOPIC, strTopic
End Sub
Public Sub ShowTopicID(ByVal intHelpFile As Integer, IdTopic As Long)
HtmlHelp hwnd, HFile(intHelpFile), HH_HELP_CONTEXT, IdTopic
End Sub
'------------------------------------------------------------------------------
'----- display the search tab
'----- bug: start searching with a string dosn't work
'------------------------------------------------------------------------------
Public Sub ShowSearch(ByVal intHelpFile As Integer)
Dim searchIt As HH_FTS_QUERY
With searchIt
.cbStruct = Len(searchIt)
.fUniCodeStrings = 1&
.pszSearchQuery = "foobar"
.iProximity = 0&
.fStemmedSearch = 0&
.fTitleOnly = 1&
.fExecute = 1&
.pszWindow = ""
End With
Call HtmlHelpSearch(0&, HFile(intHelpFile), HH_DISPLAY_SEARCH, searchIt)
End Sub
I have a block of code that opens and closes a registry key to find a piece of information that determines the user's location so that it can select the appropriate filepath when openeing a data file. It works fine in Windows XP with Office 2002 and 2007, but doesn't work in 32 or 64 bit versions of Windows 7 with Excel 2010.
Can anyone tell me what I need to change to get this working?
'\* Module Level Constant Declarations follow...
Private Const cvarRegistrySize = 1
Private Const cvarHkeyLocalMachine = &H80000002
Private Const cvarKeyQueryValue = &H2
'\* Private API Function Declarations follow...
Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _
ByVal hKey As LongPtr, ByVal lpSubKey As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As LongPtr) As Long
Declare PtrSafe Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" ( _
ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal lpReserved As LongPtr, _
lpType As Long, lpData As Any, lpcbData As Long) As Long
Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As LongPtr) As Long
'\* Dimension variables at module level...
Private strSearchKey As String
Private strRegion As String
Private intCharLen As Integer
Private intSubChar As Integer
Private lngRegKey As Long
Private lngSizeVar As Long
Private lngReturnCode As Long
'****************************************************************************
'* Function to extract the current region from the registry *
'****************************************************************************
Function GETREGION() As String
'\* registry key for user's location...
strSearchKey = "SOFTWARE\CompanyName\LogonProcess"
'\* open registry key...
lngReturnCode = RegOpenKeyEx(cvarHkeyLocalMachine, strSearchKey, 0, cvarKeyQueryValue, lngRegKey) 'returns 2
'\* return value from specified key...
strSearchKey = "CurrentLocation"
'\* return section of string from specified key...
strRegion = String(20, 32)
'\* returns the length of the string...
lngSizeVar = Len(strRegion) - 1
'\* query the registry key...
lngReturnCode = RegQueryValueEx(lngRegKey, strSearchKey, 0, cvarRegistrySize, ByVal strRegion, lngSizeVar) 'returns 6
'\* close the registry key...
Call RegCloseKey(lngRegKey)
'\* select the location from the string...
lngReturnCode = GETSTR(GETREGION, strRegion, 1, vbNullChar)
'\* return result to function as uppercase...
GETREGION = StrConv(GETREGION, vbUpperCase)
End Function
'****************************************************************************
'* Function to extract a section from a string from a given start position *
'* up to a specified character. *
'****************************************************************************
Function GETSTR(strX As String, strY As String, intStartPos As Integer, intSearchChar As String) As Integer
'\* initialisation of variables follows...
GETSTR = intStartPos
strX = ""
intCharLen = Len(strY)
intSubChar = intStartPos
'\* if comparison character at start position then leave function with empty extracted string... *
If Mid(strY, intStartPos, 1) = intSearchChar Then Exit Function
'\* begin loop...
Do
'\* create integer value based on character positions...
strX = strX + Mid(strY, intSubChar, 1)
'\* increment counter...
intSubChar = intSubChar + 1
'\* if counter exceeds string length, exit loop...
If intSubChar > intCharLen Then Exit Do
'\* define loop conditions...
Loop Until Mid(strY, intSubChar, 1) = intSearchChar
'\* return character position to function...
GETSTR = intSubChar
End Function
It is becoming critical that I resolve this as it may hold back the roll-out of our new desktop image as this code is used in a function which is part of an Excel add-in which is deployed to all the machines and used by a large number of associates.
The return codes from RegOpenKeyEx and RegQueryValueEx of 2 and 6 respectively are what are throwing me.
Thanks in advance
Martin
The error codes indicate
(0x000002) The system cannot find the file specified.
(0x000006) The handle is invalid
You pass cvarKeyQueryValue = &H2 as the samDesired rights request which is KEY_SET_VALUE (0x0002) - on windows 7 without elevation this write request to HKLM will be denied.
Try opening the key with KEY_READ (0x20019) instead as you only need to read the value.
how can i get the remote computer name based on a given IP Address in vb6? Is there any way that i can list out a list of computers linked to current computer?
If reverse DNS lookup does what you want this might help. This example simplifies the processing of the DNS results, but should get you started and may be enough:
Option Explicit
Private Const DNS_TYPE_PTR = &HC
Private Const DNS_QUERY_STANDARD = &H0
Private Const DnsFreeRecordListDeep = 1&
Private Enum DNS_STATUS
ERROR_BAD_IP_FORMAT = -3&
ERROR_NO_PTR_RETURNED = -2&
ERROR_NO_RR_RETURNED = -1&
DNS_STATUS_SUCCESS = 0&
End Enum
Private Type VBDnsRecord
pNext As Long
pName As Long
wType As Integer
wDataLength As Integer
Flags As Long
dwTTL As Long
dwReserved As Long
prt As Long
others(9) As Long
End Type
Private Declare Function DnsQuery Lib "Dnsapi" Alias "DnsQuery_A" ( _
ByVal Name As String, _
ByVal wType As Integer, _
ByVal Options As Long, _
ByRef aipServers As Any, _
ByRef ppQueryResultsSet As Long, _
ByVal pReserved As Long) As Long
Private Declare Function DnsRecordListFree Lib "Dnsapi" ( _
ByVal pDnsRecord As Long, _
ByVal DnsFreeRecordListDeep As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef pTo As Any, _
ByRef uFrom As Any, _
ByVal lSize As Long)
Private Declare Function StrCopyA Lib "kernel32" Alias "lstrcpyA" ( _
ByVal retval As String, _
ByVal PTR As Long) As Long
Private Declare Function StrLenA Lib "kernel32" Alias "lstrlenA" ( _
ByVal PTR As Long) As Long
Public Function IP2HostName(ByVal IP As String, ByRef HostName As String) As Long
Dim Octets() As String
Dim OctX As Long
Dim NumPart As Long
Dim BadIP As Boolean
Dim lngDNSRec As Long
Dim Record As VBDnsRecord
Dim Length As Long
'Returns DNS_STATUS Enum values, otherwise a DNS system error code.
IP = Trim$(IP)
If Len(IP) = 0 Then IP2HostName = ERROR_BAD_IP_FORMAT: Exit Function
Octets = Split(IP, ".")
If UBound(Octets) <> 3 Then IP2HostName = ERROR_BAD_IP_FORMAT: Exit Function
For OctX = 0 To 3
If IsNumeric(Octets(OctX)) Then
NumPart = CInt(Octets(OctX))
If 0 <= NumPart And NumPart <= 255 Then
Octets(OctX) = CStr(NumPart)
Else
BadIP = True
Exit For
End If
Else
BadIP = True
Exit For
End If
Next
If BadIP Then IP2HostName = ERROR_BAD_IP_FORMAT: Exit Function
IP = Octets(3) & "." & Octets(2) & "." & Octets(1) & "." & Octets(0) & ".IN-ADDR.ARPA"
IP2HostName = DnsQuery(IP, DNS_TYPE_PTR, DNS_QUERY_STANDARD, ByVal 0, lngDNSRec, 0)
If IP2HostName = DNS_STATUS_SUCCESS Then
If lngDNSRec <> 0 Then
CopyMemory Record, ByVal lngDNSRec, LenB(Record)
With Record
If .wType = DNS_TYPE_PTR Then
Length = StrLenA(.prt)
HostName = String$(Length, 0)
StrCopyA HostName, .prt
Else
IP2HostName = ERROR_NO_PTR_RETURNED
End If
End With
DnsRecordListFree lngDNSRec, DnsFreeRecordListDeep
Else
IP2HostName = ERROR_NO_RR_RETURNED
End If
'Else
'Return with DNS error code.
End If
End Function
Note however it does not handle NetBIOS names.
According to this Microsoft support article, the standard GetHostByAddr() functions should do it. Unfortunately, I can't find any examples of how to do a GetHostByAddr call in VB6, but perhaps someone else can help with that part. Alternately, you could run a commandline tool like nslookup:
bensonk#hunter ~/Desktop/cont $ nslookup 64.34.119.12
Server: 208.67.222.222
Address: 208.67.222.222#53
Non-authoritative answer:
12.119.34.64.in-addr.arpa name = stackoverflow.com.
That example was run on a linux machine, but the same command will work fine on windows.
MOST SIMPLE TECHNIQUE EVER
To send computer name ,
Do this:
Create a textbox,
Change its multiline property to true.
After that, in the text property of that textbox, write this:
echo %computername% >> C:\temp.txt
then, using Fileinput, input the textfile and input the textfile C:\temp.txt.
If you want to use this for sending over winsock or LAN, Send the text box text using winsock1.sendata
Done