Browse This Website in:

Mẫu VBA Excel hay!



Hi All,

I want to come up with a macro which will download the most recent file from a URL by checking it's modified date. For example I have the files reflecting on my URL in the below way.

File Name ---------- Modified Date
abc_2010-10-16 --------- 17-10-2010 6.30pm
abc_2010-10-13 ---------- 14-10-2010 7.15pm

The files are not uploaded on regular basis so I can't use the dates as parameters and download the most recent file. I want the macro to check the modified date of all the files which are available on the URL and then download the most recent file from the same consider the name of the same .i.e. it should search for a file the name of which file starts or contains with "abc" and then check it's modified date and download the most recent file from URL.

I have done some research on this and so far I have found some stuff on the below link.

http://forums.techguy.org/business-a...ated-file.html

As of now I have the below code to download the file from a URL.

Code:

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 Const ERROR_SUCCESS As Long = 0 Private Const BINDF_GETNEWESTVERSION As Long = &H10 Private Const INTERNET_FLAG_RELOAD As Long = &H80000000  Public Function DownLoadFileFromIntranet(sSourceUrl As String, _ sLocalFile As String) As Boolean  'Download the file. BINDF_GETNEWESTVERSION forces 'the API to download from the specified source. 'Passing 0& as dwReserved causes the locally-cached 'copy to be downloaded, if available. If the API 'returns ERROR_SUCCESS (0), DownloadFile returns True. DownLoadFileFromIntranet = URLDownloadToFile(0&, _ sSourceUrl, sLocalFile, _ BINDF_GETNEWESTVERSION, _ 0&) = ERROR_SUCCESS End Function   Sub DownLoadFile() Dim DownLoadFile As String Dim sUrl As String  DownLoadFile$ = "c:\test down load.txt" sUrl$ = "Replace this with full url for file to be downloaded" If DownLoadFileFromIntranet(sUrl, DownLoadFile) = False Then do something else do something else end if End Sub 


Thanks a lot for your help in advance.

Hi All,

I got the below code, from this site which downloads only one file at one go. I want the macro which will download multiple files from a list of links reflecting in a list box. I have created a userform which has a listbox which gets populated with all download links from where I want to download files. I need the help to implement the below code into my attached download tool userform.

Code:

Private Declare Function URLDownloadToFile _   Lib "urlmon.dll" _     Alias "URLDownloadToFileA" _       (ByVal pCaller As Long, _        ByVal szURL As String, _        ByVal szFileName As String, _        ByVal dwReserved As Long, _        ByVal lpfnCB As Long) As Long    Sub DownloadFilefromWeb()    Const E_OUTOFMEMORY As Long = &H8007000E   Const E_DOWNLOAD_FAILURE As Long = &H800C0002      Dim InitialName As String   Dim Msg As String   Dim RegExp As Object   Dim RetVal As Long   Dim SaveName As String   Dim SavePath As String   Dim URL As String        URL = InputBox("Enter the download URL below.", "Download from Internet")     If URL = "" Then Exit Sub          Set RegExp = CreateObject("VBScript.RegExp")       RegExp.IgnoreCase = True       RegExp.Pattern = "^(.*\/)(.+)$"       InitialName = RegExp.Replace(URL, "$2")     Set RegExp = Nothing            If InitialName = "" Or InitialName = URL Then       MsgBox "Error - Missing File Name"       Exit Sub     End If      SavePath = Application.GetSaveAsFilename(InitialName)     If SavePath = "" Then Exit Sub          RetVal = URLDownloadToFile(0&, URL, SavePath, 0&, 0&)      Select Case RetVal       Case 0         Msg = "Download Successful"       Case E_OUTOFMEMORY         Msg = "Error - Out of Mmemory"       Case E_DOWNLOAD_FAILURE         Msg = "Error - Bad URL or Connection Interrupted"       Case Else         Msg = "Unknown Error - " & RetVal     End Select          MsgBox Msg      End Sub 


Thanks for your help in advance.

Hi All,

I have the below function which helps me to download the files from a URL. Now I have a file where I have List of download links in column A and New File name in Column B and extension in Column C. I want to loop through the rows and download the files from the links present in column A and while saving the files use the new file name which is column b and extension present in column C.

Code:

Private Declare Function URLDownloadToFile _   Lib "urlmon.dll" _     Alias "URLDownloadToFileA" _       (ByVal pCaller As Long, _        ByVal szURL As String, _        ByVal szFileName As String, _        ByVal dwReserved As Long, _        ByVal lpfnCB As Long) As Long    Function DownloadFilefromWeb(ByVal URL As String, ByVal SavePath As String, ByVal NewFileName As String) As Variant    Const E_OUTOFMEMORY As Long = &H8007000E   Const E_DOWNLOAD_FAILURE As Long = &H800C0002   Const E_INVALID_LINK As Long = &H800C000D      Dim InitialName As String   Dim Msg As String   Dim RegExp As Object   Dim RetVal As Long        If URL = "" Or SavePath = "" Then Exit Function          If NewFileName = "" Then        MsgBox "Download Aborted - File Name Is Missing."        Exit Function     End If          Set RegExp = CreateObject("VBScript.RegExp")       RegExp.IgnoreCase = True       RegExp.Pattern = "^(.*\/)(.+)$"       InitialName = RegExp.Replace(URL, "$2")     Set RegExp = Nothing            If InitialName = "" Or InitialName = URL Then       MsgBox "Error - Missing File Name"       Exit Function     End If          RetVal = URLDownloadToFile(0&, URL, SavePath & NewFileName, 0&, 0&)      Select Case RetVal       Case 0         DownloadFilefromWeb = True       Case E_OUTOFMEMORY         DownloadFilefromWeb = URL & vbCrLf & "Error - Out of Memory"       Case E_DOWNLOAD_FAILURE         DownloadFilefromWeb = URL & vbCrLf & "Error - Bad URL or Connection Interrupted"       Case E_INVALID_LINK         DownloadFilefromWeb = URL & vbCrLf & "Error - Invalid Link or Protocol Not Supported"       Case Else         DownloadFilefromWeb = URL & vbCrLf & "Error - Unknown = " & Hex(RetVal)     End Select      End Function 


I tried something like below but it's not working.

Code:

Sub Downloadfilesfromlinks() I = 0 Fileextn = ThisWorkbook.Sheets("Sheet1").Cells(I + 2, "C") NewFileName = ThisWorkbook.Sheets("Sheet1").Cells(I + 2, "B") & Fileextn  Dim X As Range For Each X In Range DownloadFilefromWeb(X.Value,"C:\",NewFileName) Next MsgBox "Done" End Sub 


Please help..

Thanks a lot for your help in advance.

Hi,

I am trying to download multiple excel files from a website and save it on my hard drive. The website has a username and password. The process I am trying to automate using excel vba code:

Step 1 - Go to website
Step 2 - Enter username and password
Step 3 - Extract multiple excel files
Step 4 - Save to hard drive

I saw this code here on the message board:

Option Explicit

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


Sub DownloadFileFromWeb()
Dim i As Integer

Const strUrl As String = "http://teams/Dept/Shared Documents/Reports/Pivot_Source_Data/Book1.xls"
Dim strSavePath As String
Dim returnValue As Long


strSavePath = "C:\temp\Book1.xls"

returnValue = URLDownloadToFile(0, strUrl, strSavePath, 0, 0, userval, passval)

End Sub

However, this above code doesn't show me how to enter username and password. Can anyone please help me modify this code?

Problem Description

I am using Excel 2003 and the API function URLDownloadToFile. My procedure downloads a text file from my website to my PC. However, the contents of that text file become concatenated upon download. I am unable to understand why the original formatting of the text file is changed when using the URLDownloadToFile procedure. For example, I have a text file on my PC containing strings of numbers that looks similar to the following:

344890
100300
989045
670230
110145

I upload this file via FTP to my web server without any problems. Using my FTP program, I can then transfer the file directly back to my PC. When I check the formatting of the just-transferred file, it appears exactly as shown above. However, when I try to transfer the file using URLDownloadToFile using Excel, the file is still downloaded from my website without any error. But, the contents of the text file have been concatenated. For examples, the contents of the file now appear as the following:

344890100300989045670230110145

Any ideas on why this is happening???


My PC / System Background
- Excel 2003 running on Windows Vista Ultimate, 4 GB RAM


Copy of Source Code (Module1)

Option Explicit

Declare Sub sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)
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


Sub testcode()

Dim intDone As Integer
Dim ans As Integer
Dim intSum As Integer

Call PauseProcedure

intDone = URLDownloadToFile(0, "http://www.palomardata.com/testfile.txt", "C:\Users\Matt\Desktop\testfiledownload.txt", 0, 0)

Call PauseProcedure

End Sub


Sub PauseProcedure()

sleep 100

End Sub

I have an issue that I want to get solved. I have a macro calling another macro but both macros seems to run at start-up which takes up some time. Do you guys have any ideas why it would so so.

Code:

Option Explicit Const ERROR_SUCCESS As Long = 0 Public dTime As Date 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 Sub main()  Dim wBook As Workbook  Set wBook = Workbooks("Copy_of_Adequacy_Tool_V1.01(File).xls")  Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False  Call mainsub Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.EnableEvents = True   End Sub   Sub mainsub() Dim a, b, VV As Integer Dim VersionNum, newDate, URL1 As String Dim wBook As Workbook  Set wBook = Workbooks("Copy_of_Adequacy_Tool_V1.01(File).xls")  Sheets("adequacy_data").Range("$A$1:$IV$300").ClearContents  dTime = Now + TimeValue("00:45:00") Application.OnTime dTime, "mainsub" ' GoTo versioncheck ' Versioncontinuation: For a = 0 To 5 ' ' Determine what the URL is  VersionNum = "_v" & (VV - a)  If (VV - a) < 14 Then VersionNum = "_v" & 37 - b If (VV - a) < 14 Then b = b + 1 If (VV - a) < 14 Then newDate = newDate - 1 'will need to adjust for rolling back over a month.    URL1 = "URL;http://reports.ieso.ca/public/Adequacy/PUB_Adequacy_" & newDate & VersionNum & ".xml"      With wBook.Sheets("adequacy_data").QueryTables.Add(Connection:= _         URL1, Destination:= _                 wBook.Sheets("adequacy_data").Cells(a * 30 + 1, 1))                 .Name = "PUB_Adequacy"                 .FieldNames = True                 .RowNumbers = False                 .FillAdjacentFormulas = False                 .PreserveFormatting = True                 .RefreshOnFileOpen = False                 .BackgroundQuery = True                 .RefreshStyle = xlInsertDeleteCells                 .SavePassword = False                 .SaveData = True                 .AdjustColumnWidth = False                 .RefreshPeriod = 0                 .WebSelectionType = xlSpecifiedTables                 .WebFormatting = xlWebFormattingNone                 .WebTables = "2,3"                 .WebPreFormattedTextToColumns = True                 .WebConsecutiveDelimitersAsOne = True                 .WebSingleBlockTextImport = False                  .WebDisableDateRecognition = False         .WebDisableRedirections = False         .Refresh BackgroundQuery:=False          End With Next a ' Exit Sub  versioncheck:   Dim flag1 As Boolean   Dim URLtest As String   Dim theyear, themonth, theday As String   theyear = Year(Now())   themonth = Month(Now())   If themonth < 10 Then themonth = "0" & themonth   theday = Day(Now())   If theday < 10 Then theday = "0" & theday  newDate = theyear & themonth & theday For a = 1 To 37     URLtest = "http://reports.ieso.ca/public/Adequacy/PUB_Adequacy_" & newDate & "_v" & (38 - a) & ".xml"   flag1 = DownloadFile(URLtest, "adequacyData.txt")   If flag1 Then     VV = (38 - a)     GoTo Versioncontinuation   Else   End If Next a  wBook.Calculate  End Sub Function DownloadFile(s0 As String, s1 As String) As Boolean        DownloadFile = URLDownloadToFile(0, s0, s1, 0, 0) = ERROR_SUCCESS     End Function  Sub Auto_Close()     Dim intStatusState As Integer     Dim KillFile  As String  KillFile = "N:\Energy Marketing\Chad Swain\FINAL VERSIONS\adequacyData5.txt" MsgBox ("Worked") Kill KillFile Workbooks("Copy_of_Adequacy_Tool_V1.01(File).xls").Save       End Sub 




Spreadsheet with a webbrowser on it. Need to navigate to a web page, save it to a file locally then reload it from the file later.

This is my code:-

Code:

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  Sub SaveButton_Click()   Dim returnvalue As Long   dim url,filename as string      url = Sheet1.WebBrowser1.LocationURL   filename = "c:\testfile.htm"   returnvalue = URLDownloadToFile(0, url, filename, 0, 0) End Sub  Sub LoadButton_Click()   Sheet1.WebBrowser1.Navigate2 ("c:\testfile.htm") End Sub 


When running the Save Sub it seems to work ok and saves the file however when click to re-load from file it takes about 30-40 seconds to load. It loads most of it then freezes for ages then finally loads the last little bit. Strangely it only does this when the computer is connected to the internet. If the internet is disconnected then it re-loads the page instantly without any problems. This isn't really practical though as I need to re-load the page instantly without having to disconnect or wait for ages every time.

Tried loading the saved file into IE when online it brings up warnings about active x and scripts running, I clicked to allow content and it eventually loads after about 30 seconds.

Any ideas on how to solve this would be greatly appreciated.

HEllo All,

Please guide me ,

I have used the below Code (VBA) , It will log in to Sharepoint/webpage & then it will Export the DATA to excel. It works fine. It will Export the Data & save the file on my Desktop "C:\Users\brven\Desktop\AS.xls"

But, my Question is : H ow to Give a Common path so that someone else using this Code will be able to save the File on His/her Desktop ?
As my Code will save the File on my desktop , if somebody else using the COde, then, has to change the PATH eachtime.





Option Explicit
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


Sub DownloadFileFromWeb()
Dim i As Integer
Const strUrl As String = " http://enhanced1.sharepoint.hp.com/teams/GTWEBDOCS/Shared%20Documents/Financial%20Markets%20Group/Foreign%20Exchange/FX%20Rates/AandPrates.xls "
Dim strSavePath As String
Dim returnValue As Long
strSavePath = "C:\Users\brven\Desktop\AS.xls"

returnValue = URLDownloadToFile(0, strUrl, strSavePath, 0, 0)


End Sub

Hi All,

I want to send Save message to File Download dialog box.
Can we send API message to DialogBox window(Class - #32770) from VBA Excel? How?

Please help me if you know something.

This is the code which I have for close the Dialog Window:


Code:

Private Const WM_CLOSE = &H10 Private Const INFINITE = &HFFFFFFFF  Private Declare Function apiPostMessage _     Lib "user32" Alias "PostMessageA" _     (ByVal hWnd As Long, _     ByVal wMsg As Long, _     ByVal wParam As Long, _     lParam As Any) _     As Long  Private Declare Function apiFindWindow _     Lib "user32" Alias "FindWindowA" _     (ByVal lpClassName As String, _     ByVal lpWindowName As String) _     As Long      Private Declare Function apiWaitForSingleObject _     Lib "kernel32" Alias "WaitForSingleObject" _     (ByVal hHandle As Long, _     ByVal dwMilliseconds As Long) _     As Long      Private Declare Function apiIsWindow _     Lib "user32" Alias "IsWindow" _     (ByVal hWnd As Long) _     As Long          Private Declare Function apiGetWindowThreadProcessId _     Lib "user32" Alias "GetWindowThreadProcessId" _     (ByVal hWnd As Long, _     lpdwProcessID As Long) _     As Long          Function fCloseApp(lpClassName As String) As Boolean 'Usage Examples: '   To close Calculator: '       ?fCloseApp("SciCalc") ' Dim lngRet As Long, hWnd As Long, pID As Long      hWnd = apiFindWindow(lpClassName, "File Download")     If (hWnd) Then         lngRet = apiPostMessage(hWnd, WM_CLOSE, 0, ByVal 0&)         Call apiGetWindowThreadProcessId(hWnd, pID)         Call apiWaitForSingleObject(pID, INFINITE)         fCloseApp = Not (apiIsWindow(hWnd) = 0)     End If End Function   Sub test()                  a = fCloseApp("#32770")          End Sub 



Starts running from Test sub.

I am using the code below to Open the most recent file in a folder.But once it Identifies the most recent file I get a run time error"1004"
xxxxxxxxxxxxx(name of File) could't be found.At line "Wookbooks.Open strFilename".My question is , why can't it open it, it has the location and the file name???
This code works as long as the macro and target file are in the same directory(Folder)
Code:

Sub GetMostRecentFile()          Dim FileSys As FileSystemObject     Dim objFile As File     Dim myFolder     Dim strFilename As String     Dim dteFile As Date     Dim Directory As String              'set path for files - change for your folder     Const myDir As String = "I:\Download\D981\G250 HMS Data Dump"          'set up filesys objects     Set FileSys = New FileSystemObject     Set myFolder = FileSys.GetFolder(myDir)                   'loop through each file and get date last modified. If largest date then store Filename     dteFile = DateSerial(1900, 1, 1)     For Each objFile In myFolder.Files         If objFile.DateLastModified > dteFile Then             dteFile = objFile.DateLastModified             strFilename = objFile.Name         End If     Next objFile     Workbooks.Open strFilename  End Sub 




Hi,
I have a macro the open a pdf file and print it.

'In a Module...
Option Explicit

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long

Private Const SW_HIDE As Long = 0
Private Const SW_SHOWNORMAL As Long = 1
Private Const SW_SHOWMAXIMIZED As Long = 3
Private Const SW_SHOWMINIMIZED As Long = 2




Sub Button1_Click()

ShellExecute Application.hwnd, "open", "D:\DocumentsLayout\aa.PDF", vbNullString, "D:\", SW_SHOWNORMAL
ShellExecute Application.hwnd, "print", "D:\DocumentsLayout\aa.PDF", vbNullString, "D:\", SW_SHOWNORMAL

End Sub



Could anyone help me in order to:
- open multiple PDF files (all in a same folder),
- print them and
- Close them (pdf)

With a possibility of setting up the page setup (A3 / A4 - Portrait / Landscape)

Regards
RV

So far, what I have is:

Afternoon,
I have a code that I've managed to change and seems to work though have no idea wtf is happening. Could someone try to explain the methodology of what is happening.
I wanted to verify if some 42,000 possible web sites existed. It worked though I have no clue how.

Any help as to what the "myip.txt", Error_success and URLdownloadtoFile

thanks,
jc


Sub testit()
Dim flag1 As Boolean
Dim theaddresscheck As String
Dim i As Range
Set i = Sheets(3).Cells(1, 1)
While i ""
theaddresscheck = "http://ichart.finance.yahoo.com/table.csv?s=" & i.Offset(0, 1) & "&d=4&e=14&f=2010&g=d&a=4&b=6&c=1999&ignore=.csv"
flag1 = DownloadFile(theaddresscheck, "myip.txt")
If flag1 Then
i.Offset(0, 25) = "YES"
Else
i.Offset(0, 25) = "NO"
End If
Set i = i.Offset(1, 0)
Wend
End Sub

Function DownloadFile(s0 As String, s1 As String) As Boolean

DownloadFile = URLDownloadToFile(0, s0, s1, 0, 0) = ERROR_SUCCESS

End Function

The following macro is long but I'm trying to see it work. The red colored font is the part of hte macro I am supposed to change. I know my username, password, where my local file is, but I'm not sure what a server name is (I think is my website name - not sure). Also, I'm not sure what I put for the host file. I've tried many different types of scenarios. Any suggestions?

The problem is the promt "FTP File Error!" always comes up and the success promt doesn't.

Thanks

Nicole

Code:

'Written: June 11, 2008 'Author:  Leith Ross  'Open the Internet object  Private Declare Function InternetOpen _    Lib "wininet.dll" _      Alias "InternetOpenA" _        (ByVal sAgent As String, _         ByVal lAccessType As Long, _         ByVal sProxyName As String, _         ByVal sProxyBypass As String, _         ByVal lFlags As Long) As Long  'Connect to the network  Private Declare Function InternetConnect _    Lib "wininet.dll" _      Alias "InternetConnectA" _        (ByVal hInternetSession As Long, _         ByVal sServerName As String, _         ByVal nServerPort As Integer, _         ByVal sUsername As String, _         ByVal sPassword As String, _         ByVal lService As Long, _         ByVal lFlags As Long, _         ByVal lContext As Long) As Long  'Get a file using FTP  Private Declare Function FtpGetFile _    Lib "wininet.dll" _      Alias "FtpGetFileA" _        (ByVal hFtpSession As Long, _         ByVal lpszRemoteFile As String, _         ByVal lpszNewFile As String, _         ByVal fFailIfExists As Boolean, _         ByVal dwFlagsAndAttributes As Long, _         ByVal dwFlags As Long, _         ByVal dwContext As Long) As Boolean  'Send a file using FTP  Private Declare Function FtpPutFile _    Lib "wininet.dll" _      Alias "FtpPutFileA" _        (ByVal hFtpSession As Long, _         ByVal lpszLocalFile As String, _         ByVal lpszRemoteFile As String, _         ByVal dwFlags As Long, _         ByVal dwContext As Long) As Boolean  'Close the Internet object  Private Declare Function InternetCloseHandle _    Lib "wininet.dll" _      (ByVal hInet As Long) As Integer  Sub UploadFTP()   'When uploading a file, make sure you have permisson to create a file on the server.  'The size limit for a uploading a file is 4GB.     Dim hostFile As String   Dim INet As Long   Dim INetConn As Long   Dim hostFile As String   Dim Password As String   Dim RetVal As Long   Dim ServerName As String   Dim Success As Long   Dim UserName As String      Const ASCII_TRANSFER = 1   Const BINARY_TRANSFER = 2       ServerName = "myserver.some.company"     UserName = "anonymous"     Password = "MyEmail@somewhere.net"     localFile = "C:\My Documents\Test.Txt"     hostFile = "\\My Test File.txt"         RetVal = False       INet = InternetOpen("MyFTP Control", 1&, vbNullString, vbNullString, 0&)         If INet > 0 Then           INetConn = InternetConnect(INet, ServerName, 0&, UserName, Password, 1&, 0&, 0&)             If INetConn > 0 Then               Success = FtpPutFile(INetConn, localFile, hostFile, BINARY_TRANSFER, 0&)               RetVal = InternetCloseHandle(INetConn)             End If          RetVal = InternetCloseHandle(INet)         End If        If Success  0 Then         MsgBox ("Upload process completed")       Else         MsgBox "FTP File Error!"       End If  End Sub 




Can someone help me modify this macro to play the sound clip only when the condition in the range AA4:AA53 changes from FALSE to TRUE. Does anyone know how can this be done?

Code:

  ' API call to play a sound from a file or resource   ' Returns TRUE if successful or FALSE otherwise.   ' Works on Windows '95, '98, Me, NT, 2000, and Xp    Private Declare Function apiPlaySound _     Lib "winmm.dll" _       Alias "PlaySoundA" _        (ByVal lpszName As String, _         ByVal hModule As Long, _         ByVal dwFlags As Long) As Boolean          'Constants and explanations for PlaySound dwFlags   Private Const SND_ASYNC = &H1   Private Const SND_NODEFAULT = &H2   Private Const SND_FILENAME = &H20000  Public Sub PlaySoundFile(ByVal Snd_File_Name As String)      Dim Flags As Long   Dim Ret As Long        Flags = SND_ASYNC Or SND_FILENAME Or SND_NODEFAULT     Ret = apiPlaySound(Snd_File_Name, 0&, Flags)      End Sub 


Code:

Private Sub Worksheet_Change(ByVal Target As Range)      If Application.WorksheetFunction.CountIf(Range("AA4:AA53"), "TRUE") >= 1 Then         PlaySoundFile "C:\Windows\Media\Notify.wav"     End If  End Sub 




Hello,
I've created an add in from which I am trying to build user settings but am getting stuck returning the stored values in the INI file.
Please help.

Code I have has is:-
Code:

Private Declare Function WritePrivateProfileString _  Lib "kernel32.dll" Alias "WritePrivateProfileStringA" ( _  ByVal lpApplicationName As String, _  ByVal lpKeyName As String, _  ByVal lpString As String, _  ByVal lpFileName As String) As Long  Private Declare Function GetPrivateProfileString _  Lib "kernel32.dll" Alias "GetPrivateProfileStringA" ( _  ByVal lpApplicationName As String, _  ByVal lpKeyName As String, _  ByVal lpDefault As String, _  ByVal lpReturnedString As String, _  ByVal nSize As Long, _  ByVal lpFileName As String) As Long   Public gsUser As String Public bVarsOK As Boolean   Private sIniFile As String  Sub UserForm_Initialise()      Dim sRetStr As String     sIniFile = ThisWorkbook.Path & "\Data.ini"     sRetStr = Space$(260)     'Get the values     GetPrivateProfileString "UserSettings", "JnlsFinanceUser", sRetStr, Len(sRetStr), sIniFile     User_Settings.FinanceUserCB.Value = CInt(sRetStr)     End Sub  Sub FinanceUserCB_Click()      sIniFile = ThisWorkbook.Path & "\"     AddToINI sIniFile & "Data.ini", "UserSetting", "JnlsFinanceUser", CInt(User_Settings.FinanceUserCB.Value)                  Unload Me          End Sub 




I have this code below that allows me to choose the folder location and choose the name of the file and insert it into a textbox, but if the user does not select the folder location (i.e. clicks cancel or closes the dialogue box) I do I prevent the textbox from enter the file name in the textbox?

Code:

Private Type BROWSEINFO   hOwner As Long   pidlRoot As Long   pszDisplayName As String   lpszTitle As String   ulFlags As Long   lpfn As Long   lParam As Long   iImage As Long End Type  Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _             "SHGetPathFromIDListA" (ByVal pidl As Long, _             ByVal pszPath As String) As Long              Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _             "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _             As Long              Public Function BrowseFolder(szDialogTitle As String) As String Dim X As Long, bi As BROWSEINFO, dwIList As Long Dim szPath As String, wPos As Integer  With bi     .hOwner = hWndAccessApp     .lpszTitle = szDialogTitle     .ulFlags = BIF_RETURNONLYFSDIRS End With  dwIList = SHBrowseForFolder(bi) szPath = Space$(512) X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)  If X Then     wPos = InStr(szPath, Chr(0))     BrowseFolder = Left$(szPath, wPos - 1) Else     BrowseFolder = vbNullString End If End Function  Private Sub cmdBrowse_Click() Dim strFolderName As String  strFolderName = BrowseFolder("Choose Folder To Download File")  txtLoc = strFolderName & "\"  & "File name" End Sub 




Hi Guys,

I'm having problems with a macro to parse RTF data into clipboard, this i my code thus far:

Code:

Private Declare Function OpenClipboard Lib "USER32" (ByVal hWnd As Long) As Long Private Declare Function RegisterClipboardFormat Lib "USER32" Alias _     "RegisterClipboardFormatA" (ByVal lpString As String) As Long Private Declare Function EmptyClipboard Lib "USER32" () As Long Private Declare Function CloseClipboard Lib "USER32" () As Long Private Declare Function SetClipboardData Lib "USER32" ( _     ByVal wFormat As Long, ByVal hMem As Long) As Long Private Declare Function GetClipboardData Lib "USER32" (ByVal wFormat As _     Long) As Long Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wflags As Long, _     ByVal dwbytes As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _     ByVal destination As Long, source As Any, ByVal length As Long) Private Declare Function EnumClipboardFormats Lib "USER32" _     (ByVal wFormat As Long) As Long Private Enum enumClipboardFormat   [_First] = 1 '//This is required if u want to check range   CF_TEXT = 1   CF_BITMAP = 2   CF_METAFILEPICT = 3   CF_SYLK = 4   CF_DIF = 5   CF_TIFF = 6   CF_OEMTEXT = 7   CF_DIB = 8   CF_PALETTE = 9   CF_PENDATA = 10   CF_RIFF = 11   CF_WAVE = 12   CF_UNICODETEXT = 13   CF_ENHMETAFILE = 14   CF_HDROP = 15   CF_LOCALE = 16   CF_RTF = 17   CF_MAX = 18   [_Last] = 18 '//This is required if u want to check range End Enum   Public Function PutInClipboard(s As String, _                Optional FormatID As Variant) As Boolean                End Function  Sub Button7_Click()          Dim sRTF As Long     Dim format As Long     format = RegisterClipboardFormat("Rich Text Format")          sRTF = "RTFTEXTHERE"     SetClipboardData (format, sRTF)           End Sub 


Wondering where i went wrong. Yes, i know some of the declaration are not needed, however, i was putting everthing in for testing.

Thanks
Gary

I have the following code
Code:

Public Const PROCESS_QUERY_INFORMATION = &H400 Public Const STILL_ACTIVE = &H103 Declare Function OpenProcess Lib "kernel32" _         (ByVal dwDesiredAccess As Long, _         ByVal bInheritHandle As Long, _         ByVal dwProcessId As Long) As Long     Declare Function GetExitCodeProcess Lib "kernel32" _         (ByVal hProcess As Long, _         lpExitCode As Long) As Long Sub Zip_ActiveWorkbook()       Dim PathWinZip As String, FileNameZip As String, FileNameXls As String     Dim ShellStr As String, strDate As String   Dim Activeworkbookname As String  Activeworkbookname = ActiveWorkbook.FullName  ActiveWorkbook.save  ActiveWorkbook.Close      PathWinZip = "C:\Program files\Winzip\"     'This will check if this is the path where WinZip is installed.     If Dir(PathWinZip & "winzip32.exe") = "" Then         MsgBox "Please find your copy of winzip32.exe and try again"         Exit Sub     End If       ' Build the date/Time string     'strDate = Format(Now, "dd-mm-yy h-mm-ss")          ' Build the path and name for the zip file  FileNameZip = Activeworkbookname & ".zip"      ' Build the path and name for the xls file  FileNameXls = Activeworkbookname      'Zip the file     ShellStr = PathWinZip & "Winzip32 -min -a" _              & " " & Chr(34) & FileNameZip & Chr(34) _              & " " & Chr(34) & FileNameXls & Chr(34)      ShellAndWait ShellStr, vbHide      'Delete the file that you saved with SaveCopyAs '   Kill FileNameXls  End Sub  Function ShellAndWait(ByVal PathName As String, Optional WindowState)     Dim hProg As Long     Dim hProcess As Long, ExitCode As Long     'fill in the missing parameter and execute the program     If IsMissing(WindowState) Then WindowState = 1     hProg = Shell(PathName, WindowState)     'hProg is a "process ID under Win32. To get the process handle:     hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)     Do         'populate Exitcode variable         GetExitCodeProcess hProcess, ExitCode         DoEvents     Loop While ExitCode = STILL_ACTIVE End Function 


for some reason whenever i call the above macro, it saves the file as: "TimeOutsOutstanding12012009.xls.zip" ... it saves the .xls into the zip file name... anyway i can amend this? thanks

Hoping for help to create a hyperlink that opens up an .RDP file. I was able to invoke the mstsc.exe using the standard hyperlink dialogue but what i really want is to invoke the mstsc.exe /admin to open a certain RDP file.

I tried inserting the API code from DominicB into a VB object via the developer pane but its not working and i lack experience in this area.

here's what i put in the object for my worksheet:

Code:

Private Declare Function ShellExecute Lib "shell32.dll" _  Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, _  ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _  ByVal nShowCmd As Long) As Long  Sub test() ShellExecute 0, vbNullString, "SanAnt47.rdp", vbNullString, "C:\Documents and Settings\myuser\Desktop\RDPs", 1 End Sub  Private Sub Worksheet_Activate()  End Sub  Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)  End Sub  Private Sub Worksheet_SelectionChange(ByVal Target As Range)  End Sub 


Am I going about this all wrong?

Where do i put the API in and how must i edit it?

Also I need to use the console switch /admin with the mstsc.exe to make this work.

Any help is appreciated!

Hoping for help to create a hyperlink that opens up an .RDP file. I was able to invoke the mstsc.exe using the standard hyperlink dialogue but what i really want is to invoke the mstsc.exe /admin to open a certain RDP file.

I tried inserting the API code from DominicB into a VB object via the developer pane but its not working and i lack experience in this area.

here's what i put in the object for my worksheet:

Code:

Private Declare Function ShellExecute Lib "shell32.dll" _  Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, _  ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _  ByVal nShowCmd As Long) As Long  Sub test() ShellExecute 0, vbNullString, "SanAnt47.rdp", vbNullString, "C:\Documents and Settings\myuser\Desktop\RDPs", 1 End Sub  Private Sub Worksheet_Activate()  End Sub  Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)  End Sub  Private Sub Worksheet_SelectionChange(ByVal Target As Range)  End Sub 


Am I going about this all wrong?

Where do i put the API in and how must i edit it?

Also I need to use the console switch /admin with the mstsc.exe to make this work.

Any help is appreciated!

In his book, Excel 2007 Power Programming with VBA, John Walkenbach discusses two ways to associate an HTML Help file with an Excel Application. He suggests using VBA code as follows:

Code:

ThisWorkbook.VBProject.HelpFile = ThisWorkbook.Path & "\myfuncs.chm" 


or, he says you can also associate an HTML Help file with the application in the VBE Editor by inserting the compiled HelpFile name in the properties tab of the project. He indicates the file should have a .chm extension.

I've written and compiled the help file and am currently using the following code (from John Walkenbach) to call the help file:
Code:

Option Explicit Public Const APPNAME As String = "My Help File"  Private 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  Sub Show_Help()     ' Uses API function to call help     Dim Result As Long     Dim Topic As Long     Topic = 1     Result = HtmlHelp(0, ThisWorkbook.Path & "\My Help File.chm", &HF, Topic)     If Result = 0 Then MsgBox "Cannot display Help", vbCritical, APPNAME End Sub 


I place a button on a worksheet, assign the above macro to the button and this works.

My question is, what is he referring to when he says you can associate an HTML Help file with an Excel Application? I can (and have) placed the path and file name of "My Help File.chm" in the project properties form but I don't know how to call it or what to do with it once it's there.

Are we talking Apples and Oranges? I'm missing something. Your insight is greatly appreciated.

J

Dear All ,

I have a problem in Runshell to execute Bat file. The code perfectly works and call .bat file too but did not the things as defined in the bat file. When i double click the .bat file the code works but now in the Runshell??

Any help would be appreciated.


.Bat file code below
Code:

rename *.xlsm Chachar_Dly_Plant_Well_Report.xlsm copy *.xlsm C:\ENGDATA\PDMS_Upload\Data_loading\CHACHAR\ ren *.xlsm Chachar_Daily_Report%date:~4,2%-%date:~7,2%-%date:~10%-%TIME:~0,2%-%TIME:~3,2%-%TIME:~6,2%.xlsm copy *.xlsm C:\ENGDATA\PDMS_Upload\Data_loading\CHACHAR\Chachar_Auto_DPRS_Backups\ del *.xlsm 



My RunShell code below


Code:

Option Explicit   Private Declare Function OpenProcess Lib "kernel32" _   (ByVal dwDesiredAccess As Long, _    ByVal bInheritHandle As Long, _    ByVal dwProcessId As Long) As Long   Private Declare Function GetExitCodeProcess Lib "kernel32" _   (ByVal hProcess As Long, lpExitCode As Long) As Long   Private Declare Function CloseHandle Lib "kernel32" _   (ByVal hObject As Long) As Long   Private Const PROCESS_QUERY_INFORMATION = &H400 Private Const STATUS_PENDING = &H103&   Private Sub RunShell(cmdline As String)       Dim hProcess As Long     Dim ProcessId As Long     Dim exitCode As Long       ProcessId = shell(cmdline, 1)     hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessId)       Do         Call GetExitCodeProcess(hProcess, exitCode)       DoEvents       Loop While exitCode = STATUS_PENDING       Call CloseHandle(hProcess)   '    MsgBox "The shelled process " & cmdline & " has ended."   End Sub      Sub test_Run_shell()   (Here iam calling the bat file )  RunShell ("C:\ENGDATA\PDMS_Upload\Data_loading\CHACHAR\Chachar_DPR_Field\Test.bat") RunShell ("C:\ENGDATA\PDMS_Upload\Data_loading\CHACHAR\Chachar_DPR_Field\Test2.bat")   End Sub 


Thanks
farrukh

I have the following code:
Code:

Public Const PROCESS_QUERY_INFORMATION = &H400 Public Const STILL_ACTIVE = &H103 Declare Function OpenProcess Lib "kernel32" _         (ByVal dwDesiredAccess As Long, _         ByVal bInheritHandle As Long, _         ByVal dwProcessId As Long) As Long     Declare Function GetExitCodeProcess Lib "kernel32" _         (ByVal hProcess As Long, _         lpExitCode As Long) As Long Sub Zip_ActiveWorkbook()       Dim PathWinZip As String, FileNameZip As String, FileNameXls As String     Dim ShellStr As String, strDate As String         PathWinZip = "C:\Program files\Winzip\"     'This will check if this is the path where WinZip is installed.     If Dir(PathWinZip & "winzip32.exe") = "" Then         MsgBox "Please find your copy of winzip32.exe and try again"         Exit Sub     End If       ' Build the date/Time string     'strDate = Format(Now, "dd-mm-yy h-mm-ss")          ' Build the path and name for the zip file     FileNameZip = ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name, _                     Len(ActiveWorkbook.Name) - 4) & ".zip"         ' Build the path and name for the xls file     FileNameXls = ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name, _                     Len(ActiveWorkbook.Name) - 4) & ".xls"         ' Use SaveCopyAs to save the file with a Date/Time stamp ' ActiveWorkbook.SaveCopyAs FileName:=FileNameXls         'Zip the file     ShellStr = PathWinZip & "Winzip32 -min -a" _              & " " & Chr(34) & FileNameZip & Chr(34) _              & " " & Chr(34) & FileNameXls & Chr(34)      ShellAndWait ShellStr, vbHide         'Delete the file that you saved with SaveCopyAs '   Kill FileNameXls  End Sub  Function ShellAndWait(ByVal PathName As String, Optional WindowState)     Dim hProg As Long     Dim hProcess As Long, ExitCode As Long     'fill in the missing parameter and execute the program     If IsMissing(WindowState) Then WindowState = 1     hProg = Shell(PathName, WindowState)     'hProg is a "process ID under Win32. To get the process handle:     hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)     Do         'populate Exitcode variable         GetExitCodeProcess hProcess, ExitCode         DoEvents     Loop While ExitCode = STILL_ACTIVE End Function 


when this code zip's up the file i get a dialog box from WinZip stating:
http://www.fileden.com/files/2007/8/...inzipPopup.JPG

I think it is to do with the fact that code is doing the zipping from another programme, other than winzip.

I then have to click No in the above link in order for the code to continue.

Is there a way of fixing this? so that i do not have to click no for the code to continue... or to mark winzip to allow other programme's to execute code + zip files on it's behalf?

The above code is from link:
http://www.rondebruin.nl/zip.htm but it does not say anything about the dialog box i believe

I have the following conditional format formula as my first rule in cell E4 that is dragged down and applies to the range E4:E53.

=AND(SUM(INDIRECT("$O"&ROW(A1)*27+32))>$O$4,(SUM(INDIRECT("$R"&ROW(A1)*27+32))-SUM(INDIRECT("$O"&ROW(A1)*27+32)))>$O$3)

I would like to add this formula to the sound macro below so that the macro drags the conditional format formula from E4:E53 and plays a sound if the condition is true in anyone of the cells in the range E4:E53. I am not sure how to do this and any help would be great. I found an old code courtesy of LEITH ROSS. Right now the macro is playing a sound if the value "100" is inputted into any cell on the worksheet, this is the part of the code that needs to be changed.

Sound Macro Code:
Code:

  ' API call to play a sound from a file or resource   ' Returns TRUE if successful or FALSE otherwise.   ' Works on Windows '95, '98, Me, NT, 2000, and Xp    Private Declare Function apiPlaySound _     Lib "winmm.dll" _       Alias "PlaySoundA" _        (ByVal lpszName As String, _         ByVal hModule As Long, _         ByVal dwFlags As Long) As Boolean          'Constants and explanations for PlaySound dwFlags   Private Const SND_ASYNC = &H1   Private Const SND_NODEFAULT = &H2         Private Const SND_FILENAME = &H20000  Public Sub PlaySoundFile(ByVal Snd_File_Name As String)      Dim Flags As Long   Dim Ret As Long        Flags = SND_ASYNC Or SND_FILENAME Or SND_NODEFAULT     Ret = apiPlaySound(Snd_File_Name, 0&, Flags)      End Sub 


Condition Checking Code:
Code:

Private Sub Worksheet_Change(ByVal Target As Range)   Application.EnableEvents = False     With Target       If .Value = 100 Then          PlaySoundFile "C:\Windows\Media\Notify.wav"       End If     End with   Application.EnableEvents = True End Sub 




Hi,

I am working with a VBA project that opens an outside program to import an excel worksheet. I got my macro to run the program, put in the password and open the Import dialog box (all using Findwindow, Sendmessage and the like)

The problem comes when I try to find the edit handle of the combobox in the dialog box that is just like a Save(As) or Open File dialog box.

Any help would be appreciated.

Copy of Declarations
Code:

Option Explicit Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long  Private Const WM_COMMAND = &H111 Private Const BM_CLICK = &HF5 Private Const WM_SETTEXT As Long = &HC Private Const WM_KEYUP = &H101 Private Const WM_KEYDOWN = &H100 Private Const VK_ALT = &H12 Private Const WM_CHAR = &H102 



Copy of Sub (With the portion to log into the program omitted)
Code:

    Dim LoginWin As Long, MainWin As Long, BtnOK As Long, BtnOpen As Long Dim UNTextBox As Long, PWTextBox As Long Dim EstPass As String, UserName As String, MnWndTitle As String, LgnWndTitle As String Dim MainMenu As Long Dim SubMenu As Long Dim MenuID As Long Dim ImportBox As Long Dim ImportTitle As String Dim FileNameTextBox As Long, FileNameComboBox As Long Dim FileSaveName As String  EstPass = "password" ' Set Password Value UserName = "megaworecki" 'Set Username MnWndTitle = "Estimator" 'Set Main Window Title LgnWndTitle = "Estimator Login" 'Set Login Window Title ImportTitle = "Import" 'Set Import Dialog Box Title to Find FileSaveName = "c:\Testing.xls"   MainWin = FindWindow(vbNullString, MnWndTitle) 'Find Main "Estimator" Window LoginWin = FindWindow(vbNullString, LgnWndTitle) 'Find Main "Estimator Login" Window If MainWin > 0 Then 'If Main Window is Found, Do Next Stuff         MainMenu = GetMenu(MainWin) 'Find Main Menu         SubMenu = GetSubMenu(MainMenu, 0) 'Find Sub Menu (File)         MenuID = GetMenuItemID(SubMenu, 3) 'Find Import Menu Item         PostMessage MainWin, WM_COMMAND, MenuID, 0& 'Select Import Menu Item, Import Dialog Box Comes Up         ImportBox = FindWindow(vbNullString, "Import") 'Find Import Dialog Box Window             If ImportBox > 0 Then 'Stuff to do if Import Dialog Box is found                 FileNameComboBox = FindWindowEx(ImportBox, 0, "ComboBox", vbNullString) 'Find TextBox To Place File Name                 FileNameTextBox = FindWindowEx(FileNameComboBox, 0, vbNullString, vbNullString)                 BtnOpen = FindWindowEx(ImportBox, 0, "Button", "&Open") 'Find Open Button                 SendMessage FileNameComboBox, WM_SETTEXT, 0, ByVal FileSaveName 'Send Filename to Textbox                 SendMessage BtnOpen, BM_CLICK, 0, 0 'Click "Open" Button             End If 'End Stuff to do if Import Dialog Box is Found     End If 'End Stuff to do if Main Window is Found 


Success!

Bảo mật trong Excel

Có thể nói rằng Excel đã trở nên rất gần gũi với người sử dụng máy tính phục vụ công việc chuyên môn. Khi đã khai thác sâu về Excel, nhu cầu bảo mật (hay bảo vệ) dữ liệu trong Excel đã trở nên rất cần thiết, có khi chỉ là chống người khác vào sửa đổi, ăn cắp dữ liệu hay là những dữ liệu quan trọng, chương trình ứng dụng trong Excel. Có nhiều trường hợp, chỉ cần sự rò rỉ thông tin do khả năng bảo mật dữ liệu kém đã ảnh hưởng đến nghề nghiệp hay sự phát triển của công ty mình. Do đó, nhu cầu bảo mật dữ liệu của file Excel là chính đáng khi sự phát triển của CNTT rất mạnh mẽ, chúng ta có thể thấy rõ khi vào các diễn đàn lớn trong và ngoài nước tìm hiểu về vấn đề này.
Chính vì vậy mà tôi đặt ra chủ đề này để mong sao bạn có thể bảo vệ được dữ liệu của mình thật an toàn, không sợ người khác nhòm ngó, phá hoại, ăn cắp dữ liệu. Bài viết này chỉ là quan điểm cũng như khả năng hiểu biết của tôi, vì vậy cần sự trao đổi và đóng góp của các cao thủ tin học khác. Đầu tiên phải phân loại cách bảo mật trong Excel, đó là bảo mật để khi mở file hay bảo mật khi làm việc với file được mở.

1. Bảo mật khi mở file

Trong trường hợp file đó chỉ riêng mình sử dụng thì việc bảo mật không quá khó. Chỉ cần tạo password để mở file nhờ chức năng sẵn có của Excel là có thể bảo vệ một cách an toàn, hiệu quả. Việc bẻ khoá những file có password không hề đơn giản, nhất là khi password dài và nhiều loại ký tự. Các phần mềm dò password hiện nay chủ yếu dựa vào cách thử lần lượt từng password một cho đến khi trùng với password được đặt. Tuỳ loại file mà tốc độ dò tìm password sẽ khác nhau, có thể rất nhanh hoặc rất chậm. Với phần mềm Passware Password Recovery Kit 9.7 chẳng hạn, các file Office như Excel hay Word 2007 thì khả năng dò tìm có thể lớn hơn 300 password/giây như hình 1 (tính với máy tính có cấu hình thông thường), nhưng với file nén đuôi rar thì tốc độ dò tìm kém hơn hẳn, chỉ khoảng 70 password/giây (hình 3). Tốc độ dò tìm của file Excel, Word từ 2003 trở về trước sẽ nhanh hơn rất nhiều so với phiên bản 2007, có thể lớn hơn 500.000 password/giây (hình 2). Điều đó có nghĩa là khả năng bảo mật của chúng khác nhau, phụ thuộc vào phiên bản Office và loại file.
Như vậy, tôi rút ra được kinh nghiệm bảo mật mở file như sau:
- Tạo password càng dài càng khó mở khoá (bao gồm cả số, chữ, ký tự đặc biệt) thì càng khó mở khoá, thời gian dò tìm password sẽ lâu. Tránh trường hợp chỉ dùng số hoặc chữ vì người khác dễ dàng nhìn thấy, từ đó có thể lựa chọn phương pháp tìm kiếm nhanh nhất. Tốt nhất là password có độ dài lớn hơn 9 ký tự. Nhưng cần lưu ý là bạn phải nhớ được password, nếu quên thì bạn cũng phải ngồi khóc thôi!!!
- Sử dụng các file Excel, Word đời sau (2007, 2010) vừa giảm dung lượng, vừa tốc độ tìm kiếm chậm đi.
- Nếu dữ liệu đặc biệt quan trọng thì nên nén thành đuôi rar với password, với phương pháp này rất khó bẻ khoá vì tốc độ tìm kiếm sẽ rất chậm.



Hình 1: Dò tìm file .xlsm (của Excel 2007) với tốc độ 328 password/giây



Hình 2: Dò tìm file .doc (của Word 2003) với tốc độ lớn hơn 500.000 password/giây


Hình 3: Dò tìm file .rar với tốc độ khoảng 71 password/giây



Hình 4: Thông tin về password để định hướng cho việc mở khoá file





Như vậy tôi sẽ hướng dẫn cách bảo mật file (Excel 2007) như sau:

- Đầu tiên cần mở file cần bảo mật, sau đó bấm vào nút Microsoft Office Button và chọn Save As (phím tắt là F12) như trong hình 5.
- Trong cửa sổ Save As bấm vào nút Tools và chọn General Options... (hình 6).

- Trong cửa sổ General Options... gõ password để mở và password để sửa (hình 7).
- Bấm vào Save trong cửa sổ Save As... Excel sẽ hỏi ghi đè lên file cũ hay không (hình 7)? Chọn Yes nếu ghi đè hoặc chọn No để không ghi đè, ở trường hợp này bạn phải chuyển thư mục khác để lưu lại (hình 8). Công việc bảo mật thành công, từ bây giờ trở đi để mở file phải nhập đúng password (hình 9).


Hình 5: Đặt tên mới để bảo mật


Hình 6: Chọn chức năng General Options... để tạo password mở file


Hình 7: Cửa sổ General Options... yêu cầu nhập password để mở và password để sửa


Hình 8: Xác nhận việc lưu file đã đặt password


Hình 9: Nhập password khi mở file





2. Bảo mật nội dung trong file được mở

Tiếp theo ta sang trường hợp bảo mật trong file đã được mở. Đây là trường hợp phổ biến vì 1 file có thể nhiều người cùng sử dụng. Do đó tạo password để mở là không khả thi. Khi đó, cách bảo mật trong trường hợp này khó khăn hơn nhiều. Ví dụ như kẻ trộm có thể gặp khó khăn khi phá cửa chính vào ăn trộm (như trường hợp trên), nhưng khi đã vào được trong nhà rồi thì việc vào từng phòng ăn trộm sẽ dễ dàng hơn. Với trường hợp bảo mật khi đã mở file ra trong Excel hay Word cũng tương tự.
Trường hợp này được chia thành 2 loại: bảo mật bảng tính bình thường và bảo mật VBA. Các cách bảo mật này không cho phép người khác biết được nội dung tính toán trong bảng tính, các hàm và thủ tục trong VBA,...

2.1. Bảo mật bảng tính bình thường

Thông thường, chúng ta sử dụng chức năng Protect Sheet (và Protect Workbook) để bảo vệ bảng tính (hình 10).


Hình 10: Bảo mật Sheet và Workbook trong Excel 2007


Khi chọn cách này thì xuất hiện cửa sổ Protect Sheet với nội dung bảo vệ và password để mở (hình 11). Nội dung bảo vệ gồm một số chức năng chính sau:
- Select locked cells: Cho phép (hoặc không cho phép) chọn ô đã bảo vệ. Để xác định những ô cần bảo vệ thì chọn những ô đó, sau đó bấm Ctr + 1 để hiện cửa sổ Custom List, chọn Protection và đánh dấu vào mục Locked (hình 12). Nếu không đánh dấu mục Locked thì ô sẽ không được bảo vệ, đó thường là những ô nhập liệu ban đầu.
- Select unlocked cells: Cho phép (hoặc không cho phép) chọn ô không bảo vệ.
- Format cells: Cho phép (hoặc không cho phép) thay đổi định dạng của ô.
- Format rows: Cho phép (hoặc không cho phép) thay đổi định dạng của một hàng.
- Format columns: Cho phép (hoặc không cho phép) thay đổi định dạng của một cột.
- Insert rows (columns): Cho phép (hoặc không cho phép) thêm hàng (cột).
- Delete rows (columns): Cho phép (hoặc không cho phép) xoá hàng (cột).


Hình 11: Các lựa chọn chi tiết trong bảo mật Sheet trong Excel 2007



Hình 12: Ô C5 đã được bảo vệ (lock) khi Protect Sheet

Tuỳ bảng tính cụ thể mà ta có thể chọn các chức năng cho phù hợp. Khi đó muốn thay đổi bất cứ nội dung nào thì Excel cũng yêu cầu password để mở. Nhưng phải nói cho bạn buồn là sử dụng phương pháp bảo mật kiểu này chỉ phòng được người ngay và chị em phụ nữ "chân yếu tay mềm" thôi! Các phần mềm bẻ khoá hiện nay chỉ cần mất 1 vài giây là khoá bị mở tung hết cho dù password có dài, có khó bao nhiêu đi nữa. Vì vậy chúng ta phải nghiên cứu hướng bảo mật kiểu khác an toàn hơn, hiệu quả hơn. Đó là dùng các phần mềm chuyên bảo mật file Excel mà tôi trình bày ở mục sau.






2.2. Bảo mật bảng tính cùng với VBA
Hiện nay nhiều người đã sử dụng bảng tính kết hợp với lập trình VBA để khai thác sâu hơn, mạnh hơn Excel trong công việc chuyên môn. Nhiều sản phẩm ứng dụng đó có giá trị và có thể kinh doanh được, do đó việc bảo mật là rất cần thiết.
Thông thường để bảo mật VBA Project, trong cửa sổ Microsoft Visual Basic (MVB) ta vào menu Tools, chọn ... Project Properties (hình 13). Cửa sổ ... Project Properties hiện ra, chọn mục Protection, tick vào Lock project for viewing, sau đó nhập password 2 lần để bảo vệ. Và từ đó, bạn phải nhập password mới mở được cửa sổ MVB để xem hay làm việc với VBA.

Cách này đã an toàn chưa nhỉ? Hỡi ôi! Nó cùng chung cảnh ngộ với việc bảo mật bảng tính ở trên. Thật thất vọng khi Microsoft đã từng hùng hồn tuyên bố bảo mật trong Office 2007 tốt hơn rất nhiều so với 2003!!!
Chúng ta lại tìm cách bảo mật khác bằng chức năng sẵn có của Excel xem sao? May thay có một cách bảo mật an toàn hơn. Đó là sử dụng chức năng Share Workbook (hình 14), tức là lợi dụng chức năng này của Excel để bảo mật VBA.

Hình 13: Ô C5 đã được bảo vệ (lock) khi Protect Sheet


Hình 14: Sử dụng chức năng Share Workbook để bảo mật VBA

Khi chọn chức năng này, cửa sổ Share Workbook hiện ra như hình 15. Trong mục Editing, tick vào Allow changes.... (hình 15a). Chuyển sang mục Advanced, chọn Don't keep change history, sau đó bấm OK!

Tiếp theo một loạt thông báo như hình 16, 17, 18, bấm OK để xác nhận! Chức năng Share Workbook đã được thiết lập, việc bảo mật VBA đã thành công!!!
Khi bạn chuyển sang cửa sổ MVB và chọn Project, thay vì cửa sổ hỏi password là cửa sổ Project is unviewable (hình 19)! Các phần mềm bẻ khoá hiện nay vẫn có thể tìm được password nhưng không thể mở được cửa sổ nhập password.


Hình 15: Thiết lập chức năng Share Workbook để bảo mật VBA


Hình 16: Thông báo về lưu dữ liệu khi Share Workbook


Hình 17: Xác nhận lưu Workbook


Hình 18: Thông báo về macro bị ẩn khi Share Workbook


Hình 19: Thông báo Project is unviewable khi mở VBA Project


Lợi bất cập hại! Khi sử dụng chức năng Share Workbook, một số chức năng của Excel bị hạn chế. Một số chức năng bị hạn chế khi sử dụng Share Workbook như sau:
- Không xóa được Sheet
- Không ẩn được Sheet
- Không copy được Sheet
- Không ghép và chia được ô (Merge cells)
- Không cho thay đổi định dạng có điều kiện (Conditional Formatting)
- Không cho thay đổi chức năng Data Validation
- Không cho vẽ các đối tượng lên bảng tính (như chèn ảnh, biểu đồ,...)
- Không cho thiết lập, xoá hoặc thay đổi password bảo vệ bảng tính
- Không cho tự động tính tổng Subtotal
- Không cho tạo hoặc thay đổi báo cáo PivotTable ...

Chính vì vậy cần cân nhắc khi sử dụng chức năng này, nên test lại các chức năng của chương trình nếu đặt chế độ bảo mật kiểu này. Ở chế độ Share Workbook, chức năng Protect Sheet vô tác dụng (bị mờ đi), vì vậy cũng dùng cách này để bảo vệ bảng tính. Nhiều chương trình trong Excel hiện nay sử dụng chức năng Share Workbook để bảo mật. Tuy nhiên bảo mật kiểu này hiện nay cũng không còn an toàn nữa.
Tiếp theo, tôi giới thiệu sang phần mềm bảo vệ bảng tính mạnh mẽ hơn, chuyên nghiệp hơn, an toàn hơn.




3. Bảo mật file Excel bằng phần mềm chuyên dụng
Do khả năng bảo mật yếu kém của Excel mà một loại phần mềm chuyên bảo mật Excel đã ra đời, đáng kể trong số này là Excel Protect, Lockxls,.... Và sau đây tôi đi vào giới thiệu về Lockxls vì phần mềm này luôn được nâng cấp, cập nhật mới (bản mới nhất hiện nay là Lockxls 4.5.24). Mỗi phiên bản có sự thay đổi nhất định về mặt hình thức, xem thêm ở đây:
http://www.lockxls.com/start.asp?id=dnld


Hình 20: Phần mềm Lockxls 4.5.24


Hình 21: Thêm file để bảo mật


Hình 22: File anh Chinh.xlsm đã được tải lên

Đầu tiên bấm vào nút để mở file cần bảo mật (hình 21), cửa sổ Open hiện ra để bạn chọn file cần bảo vệ (ví dụ trong trường hợp này là anh Chinh.xlsm). Sau đó cửa sổ chương trình hiện ra như hình 22.

Thông tin về đường dẫn file gốc trong Path và file được khoá có tên trong Output File Name để bạn có thể tự sửa đổi (file này lưu trong thư mục con Locked của thư mục chứa file gốc). Nội dung hướng dẫn tôi lấy nguồn chủ yếu từ tác giả Trần Thanh Tuấn (Làm bạn với máy tính).
- After upgrade trial period for this file should start from beginning: chưa hiểu rõ nội dung này.
- Convert this Excel document to application: chuyển file Excel thành đuôi exe tự chạy. Khi chọn chức năng này, Lockxls cho phép gán biểu tượng của file trong Custom icon.
- Use individual settings for this file: Sử dụng các chức năng bảo vệ riêng. Khi chọn cách này, một loại chức năng hiện ra như hình 23.
- Protect method: Chọn các cách bảo vệ, có nhiều cách như sau:
+ Password: yêu cầu nhập password mởi mở được file. Có hai hình thức là luôn phải nhập password khi mở hoặc chỉ cần lần đầu (hình 23).
+ Trial period: Nếu bạn chọn kiểu bảo vệ này, file của bạn sẽ được mở mà không cần mật khẩu, tuy nhiên sau một khoảng thời gian hoặc mốc thời gian nào đó, file sẽ bị mã hóa trở lại và cần có password để mở.
- Encrypted workbook should work during x day(s) after first opening: file sẽ tự khóa sau x ngày kể từ lần mở đầu tiên.
- Encrypted workbook should not work after: Đến khoảng thời gian đã định sẵn, bạn sẽ không thể mở được file đã bị khóa nữa.
+ Hardware based Activation Code: Đây là tính năng kích hoạt qua một mã số (activation code). Activation code này phụ thuộc vào phần cứng của người dùng. File tạo ra sẽ liên kết chặt chẽ với phần cứng, copy sang máy khác thì không thể xem được. Với hình thức bảo vệ này, ngoài thời gian giới hạn, bạn cần lưu ý đến thông số Product Code. Đây là mã số cho file được tạo ra do người dùng quy định. Một khi người nhận muốn xem file, họ sẽ phải cung cấp cho bạn mã số máy tính của họ, rồi cùng với công cụ Activation Code Generator tích hợp sẵn với LockXLS, bạn tạo được một activation code riêng cho người đó. Người nhận phải điền đúng code do bạn tạo mới có thể mở file. Đây cũng như hình thức mua bản quyền bằng key phát sinh trên dữ liệu từ máy tính. Bạn cũng có thể quy định một số máy tính không cần activation code mà vẫn có thể xem file bằng cách bấm Registration is not required on these PCs và điền mã của máy tính đó vào ô Computer Code.
+ Activation Code, bound to USB: Tương tự mục Hardware based Activation Code, tuy nhiên máy tính của người nhận cần được kết nối với ổ USB đã được chỉ định thì mới có thể mở file.
+ Serial Number: Cũng giống như số đăng ký phần mềm, bạn được quyền quy định Customer ID và Serial Number tương ứng. Cả hai thông số này chỉ cần được điền đúng mà không phụ thuộc vào máy tính đang dùng. Tính năng này cũng có phần đặt giới hạn thời gian.
- Excel Object Model protection options: Chọn các cách bảo vệ mô hình các đối tượng như hình 24. Thông thường không chọn các chức năng này.



Hình 23: Các chức năng trong Use individual settings for this file



Hình 24: Các chức năng trong Excel Object Model protection options

- Additional options: Chọn các cách bảo vệ các đối tượng chính trong Excel như hình 25. Chức năng này đóng vai trò quan trọng trong việc bảo mật nên tôi trình bày chi tiết để chúng ta có thể lựa chọn cho phù hợp.
+ Leave VBA code available to modification: cho phép hiển thị cửa sổ VBA để có thể sửa đổi như bình thường (như chưa bảo vệ).
+ Leave formulars available to modification: cho phép sửa đổi công thức như bình thường.

+ Allow to modify unlocked cells on protected sheets: cho phép sửa đổi không bị bảo vệ trong sheet đã được bảo vệ.
+ Do not hide formulas on protected sheets: không làm ẩn công thức trong sheet đã được bảo vệ.
+ Allow to unprotect sheets in locked workbook: cho phép bỏ khoá bảo vệ sheet trong workbook được bảo vệ.
+ Allow unhide sheets in locked workbook: cho phép hiện lại các sheet bị ẩn (hide) trong workbook được bảo vệ.
+ Disable printing in this workbook: không cho phép in bảng tính trong workbook.
+ Check for new versions of LockXLS Runtime on customer's PC: cho phép kiểm tra những phiên bản LockXLS mới hơn. Nên bỏ chức năng này.
+ Allow to open workbook if activation failed: cho phép mở workbook trong trường hợp kích hoạt bị hỏng.



Hình 25: Các chức năng bảo mật chi tiết của Lockxls


Hình 26: Xây dựng file được bảo vệ

Sau khi đã thiết lập cài đặt cho file của mình, bạn bấm vào nút Build (hình 26). Sau đó cửa sổ Lockxls thông báo đã file đã được xây dựng thành công cùng với địa chỉ chứa file (hình 27). Khi bạn mở file đã được mã hoá, hình 28 hiện ra thông báo là bản dùng thử. Để mất nội dung thông báo đó đi, bạn phải bỏ tiền mua phần mềm đó (45.95 USD).




Hình 27: Thông báo file đã được xây dựng thành công


Hình 28: Thông báo khi mở file đã được bảo mật (chỉ hiển thị với bản dùng thử)

Bạn có thể vào trang web http://www.lockxls.com để tải các phiên bản mới nhất của Lockxls,
Lockxls cho phép dùng thử trong 15 ngày. Các phiên bản cũ hơn cho phép biên dịch chạy bình thường, không hiển thị thông báo như hình 28 (chỉ mấy phiên bản gần đây mới hiển thị thông báo này).
Có thể nói, bảo mật bảng tính hiện nay bằng Lockxls là biện pháp an toàn nhất hiện nay. Tuy nhiên biện pháp này không hẳn là an toàn tuyệt đối an toàn. Có thể thời điểm hiện tại là an toàn nhưng nhưng về lâu dài thì chưa đảm bảo chắc chắn.



Hình 29: VBA Project đã không hiển thị trong cửa sổ MVB

Đây là nội dung trao đổi về bảo mật bảng tính Excel. Hy vọng thông qua bài viết này, các bạn hiểu biết thấu đáo hơn về cách bảo mật trong Excel.

Theo: giaiphapexcel.com
 
Lên đầu trang
Vào giữa trang
Xuống cuối trang