How to write .ini Format from a Flexgrid in VB6 - vb6

What i want :
to a make a button that exports the selected data in this FelxGrid into .ini file format take (heights) as section and the others as values and keys , it dosen't have to be ini format it can also be something close to it
What i tried so far
Private Sub commandbutton_1()
Dim configfile As String
Dim myArray() As String 'i tried using arry but it didn't work
configfile = "C:\" & "\CONFIGMEEE!.INI"
PutINISetting "", "", SettingsGrid.Clip, configfile
MsgBox "Exported.", vbInformation, "Settings"
SettingsGrid.SaveGrid configfile, flexFileTabText
What happened then
the data we exported but not formatted at all as ini and written so :
Important to know
The flexgrid iam using is a vsflexgrid not an msflexgrid
And i am also using this as a MOUDLE
'API Function to write information to the INI File
Private Declare Function WritePrivateProfileString Lib "kernel32" _
Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, _
ByVal lpString As Any, _
ByVal lpFileName As String) As Long
'Get the INI Setting from the File
Public Function GetINISetting(ByVal sHeading As String, _
ByVal sKey As String, _
sINIFileName) As String
Const cparmLen = 50
Dim sReturn As String * cparmLen
Dim sDefault As String * cparmLen
Dim lLength As Long
lLength = GetPrivateProfileString(sHeading, _
sKey, _
sDefault, _
sReturn, _
cparmLen, _
sINIFileName)
GetINISetting = Mid(sReturn, 1, lLength)
End Function
'Save INI Setting in the File
Public Function PutINISetting(ByVal sHeading As String, _
ByVal sKey As String, _
ByVal sSetting As String, _
sINIFileName) As Boolean
Const cparmLen = 50
Dim sReturn As String * cparmLen
Dim sDefault As String * cparmLen
Dim aLength As Long
aLength = WritePrivateProfileString(sHeading, _
sKey, _
sSetting, _
sINIFileName)
PutINISetting = True
End Function

Related

base64 string to byte to image

I have a base64 string which was generated from an image using another application. Now on my application I want to convert the base64 string to byte and display it on a PictureBox.
I already found a sample application which takes a byte input and sets a PictureBox image. Unfortunately the sample application gets the byte array from an image and just translates it back. Here's the function it uses.
Public Function PictureFromByteStream(b() As Byte) As IPicture
Dim LowerBound As Long
Dim ByteCount As Long
Dim hMem As Long
Dim lpMem As Long
Dim IID_IPicture(15)
Dim istm As stdole.IUnknown
On Error GoTo Err_Init
If UBound(b, 1) < 0 Then
Exit Function
End If
LowerBound = LBound(b)
ByteCount = (UBound(b) - LowerBound) + 1
hMem = GlobalAlloc(&H2, ByteCount)
If hMem <> 0 Then
lpMem = GlobalLock(hMem)
If lpMem <> 0 Then
MoveMemory ByVal lpMem, b(LowerBound), ByteCount
Call GlobalUnlock(hMem)
If CreateStreamOnHGlobal(hMem, 1, istm) = 0 Then
If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture(0)) = 0 Then
Call OleLoadPicture(ByVal ObjPtr(istm), ByteCount, 0, IID_IPicture(0), PictureFromByteStream)
End If
End If
End If
End If
Exit Function
Err_Init:
If Err.Number = 9 Then
'Uninitialized array
MsgBox "You must pass a non-empty byte array to this function!"
Else
MsgBox Err.Number & " - " & Err.Description
End If
End Function
Here's the function I found to convert a base64 string to a byte, it seems to be converting it but when I pass the byte data to the above function, no image appears.
Private Function DecodeBase64(ByVal strData As String) As Byte()
Dim objXML As MSXML2.DOMDocument
Dim objNode As MSXML2.IXMLDOMElement
' help from MSXML
Set objXML = New MSXML2.DOMDocument
Set objNode = objXML.createElement("b64")
objNode.dataType = "bin.base64"
objNode.Text = strData
DecodeBase64 = objNode.nodeTypedValue
' thanks, bye
Set objNode = Nothing
Set objXML = Nothing
End Function
And here's my code calling the functions.
Dim b() As Byte
b = DecodeBase64(Text1.Text)
Dim pic As StdPicture
Set pic = PictureFromByteStream(b)
Set Picture1.Picture = pic
Try this:
Option Explicit
Private Const CRYPT_STRING_BASE64 As Long = &H1&
Private Const STRING_IPICTURE_GUID As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Private Declare Function CryptStringToBinaryW Lib "Crypt32.dll" ( _
ByVal pszString As Long, _
ByVal cchString As Long, _
ByVal dwFlags As Long, _
ByVal pbBinary As Long, _
ByRef pcbBinary As Long, _
ByVal pdwSkip As Long, _
ByVal pdwFlags As Long) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" ( _
ByRef hGlobal As Any, _
ByVal fDeleteOnResume As Long, _
ByRef ppstr As Any) As Long
Private Declare Function OleLoadPicture Lib "olepro32.dll" ( _
ByVal lpStream As IUnknown, _
ByVal lSize As Long, _
ByVal fRunMode As Long, _
ByRef riid As GUID, _
ByRef lplpObj As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" ( _
ByVal lpsz As Long, _
ByRef pclsid As GUID) As Long
Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Public Function DecodeBase64(ByVal strData As String) As Byte()
Dim Buffer() As Byte
Dim dwBinaryBytes As Long
dwBinaryBytes = LenB(strData)
ReDim Buffer(dwBinaryBytes - 1) As Byte
If CryptStringToBinaryW(StrPtr(strData), LenB(strData), CRYPT_STRING_BASE64, _
VarPtr(Buffer(0)), dwBinaryBytes, 0, 0) Then
ReDim Preserve Buffer(dwBinaryBytes - 1) As Byte
DecodeBase64 = Buffer
End If
Erase Buffer
End Function
Public Function PictureFromByteStream(ByRef b() As Byte) As IPicture
On Error GoTo errorHandler
Dim istrm As IUnknown
Dim tGuid As GUID
If Not CreateStreamOnHGlobal(b(LBound(b)), False, istrm) Then
CLSIDFromString StrPtr(STRING_IPICTURE_GUID), tGuid
OleLoadPicture istrm, UBound(b) - LBound(b) + 1, False, tGuid, PictureFromByteStream
End If
Set istrm = Nothing
Exit Function
errorHandler:
Debug.Print "Error in converting to IPicture."
End Function

VB6 - How to store URL contents in string and save as file(ex .txt)

Option Explicit
Public Sub save_url_contents_as_text()
Dim MyUrl As String
Dim MyFile As Object 'store the text file here
Dim tempstring As String
MyUrl = "www.AnythingIWantToPutHere"
'I want your help here. Something Like a function
tempstring = geturltext(MyUrl)
'I want to save the URL text contents here
MyFile = tempstring
End Sub
Taken directly from here. Change the URL and the filename as desired. This call writes the contents of the URL to a disk file.
This example shows how to use the URLDownloadToFile API function to download a file from a URL into a file in Visual Basic 6.
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Sub Form_Load()
' Download the file.
URLDownloadToFile 0, _
"http://www.vb-helper.com/vbhelper_425_64.gif", _
"C:\vbhelper_425_64.gif", 0, 0
End Sub

With Excel vba, save web image to disk

I am trying to save an image from a webpage using excel vba.
I'm managed to get the string (although not the one I want), and need to save it to disk.
The HTML code for the source is:
<img id="SkuPageMainImg" data-sku="491215" alt="Papir ubleket kraft 60g 40cm 5kg/rull" class="skuImageSTD" src="/content/images/product/491215_1_xnm.jpg?v=4TWLBni1V4k8GV8B_0P-GA" data-zoomimage="//www.staples.no/content/images/product/491215_1_xnl.jpg" data-resizeimage="{"0to1024":"/content/images/product/491215_1_xnm.jpg?v=4TWLBni1V4k8GV8B_0P-GA","1025to1450":"//www.staples.no/content/images/product/491215_1"}" data-screensize="">
My code is: IMG = .document.getElementById("SkuPageMainImg").src
This code captures the url after the src= :
/content/images/product/491215_1_xnm.jpg?v=4TWLBni1V4k8GV8B_0P-GA"
This will do, but what i would preffer to catch is the url after data-zoomimage= :
"//www.staples.no/content/images/product/491215_1_xnl.jpg"
Either way, what I am looking to accomplish is having Excel VBA save the image to a file on my disk - typically c:\folder\image_name.jpg
Anybody know the code to do this?
Import the URLDownloadToFile function and use it directly. The following is an entire module code sheet, including the declarations section at the top. The routine expects a list of the full img src URLs in column A starting at row 2. e.g.: http://www.staples.no/content/images/product/491215_1_xnm.jpg
        
Option Explicit
#If VBA7 And Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As LongPtr, _
ByVal lpfnCB As LongPtr _
) As Long
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#Else
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long _
) As Long
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#End If
Public Const ERROR_SUCCESS As Long = 0
Public Const BINDF_GETNEWESTVERSION As Long = &H10
Public Const INTERNET_FLAG_RELOAD As Long = &H80000000
Sub dlStaplesImages()
Dim rw As Long, lr As Long, ret As Long, sIMGDIR As String, sWAN As String, sLAN As String
sIMGDIR = "c:\folder"
If Dir(sIMGDIR, vbDirectory) = "" Then MkDir sIMGDIR
With ActiveSheet '<-set this worksheet reference properly!
lr = .Cells(Rows.Count, 1).End(xlUp).Row
For rw = 2 To lr
sWAN = .Cells(rw, 1).Value2
sLAN = sIMGDIR & Chr(92) & Trim(Right(Replace(sWAN, Chr(47), Space(999)), 999))
Debug.Print sWAN
Debug.Print sLAN
If CBool(Len(Dir(sLAN))) Then
Call DeleteUrlCacheEntry(sLAN)
Kill sLAN
End If
ret = URLDownloadToFile(0&, sWAN, sLAN, BINDF_GETNEWESTVERSION, 0&)
.Cells(rw, 2) = ret
Next rw
End With
End Sub
A value of 0 is column B indicates success (e.g. ERROR_SUCCESS).
        

Read Connection String From .INI File

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

Automatically download a list of images and name them

I have a xls/csv list of images:
Name image url
test.jpg http://test.com/232dd.jpg
test2.jpg http://test.com/2390j.jpg
I have about 200 of these...is there a way to download the list and name them as identified in the xls file?
Here is my Excel VBA:
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Sub download_pics()
Dim rng As Range
Dim cell As Variant
Set rng = Range("A1:B10")
For Each cell In rng
' Download the file.
URLDownloadToFile 0, cell(rng, 2).Value, "C:\" & cell(rng, 1).Value, 0, 0
Next
End Sub
Running into type mismatch error with URLDownloadToFile
OK The type mismatch has to do with your iteration. You need to specify how you're iterating over rng with the For each cell in rng statement, like:
For each cell in rng.Rows
Otherwise, it treats that statement as For each cell in rng.Cells and that raises the mismatch error.
I made some modifications to the code (based on Sid's answer here), so it checks to ensure the file downloaded successfully, but mostly what you found was correct, you just need to implement it a little differently.
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Sub download_pics()
Dim rng As Range
Dim myRow As Range
Dim imgName As String
Dim fileLocation As String
Dim Ret As Long 'return value from the URLDownloadToFile function
Set rng = Range("A1:B10")
For Each myRow In rng.Rows
With myRow
imgName = .Columns(2).Value
fileLocation = "C:\" & .Columns(1).Value
With .Columns(1).Offset(, 2)
If URLDownloadToFile(0, imgName, fileLocation, 0, 0) = 0 Then
.Value = "downloaded successfully"
Else:
.Value = "download failed!"
End If
End With
End With
Next
End Sub

Resources