使用Excel的VBA下载文件

今天发现了个用EXCEL下载文件的实例,看起来很不错,收藏一下。

附件如下:xls

这是代码:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Sub
downloads()
    
Dim
i
As
Integer
    
Dim
Path
As
String
    
Dim
str
As
String
    
Application.ScreenUpdating =
False
    
Application.EnableEvents =
False
    
On
Error
Resume
Next
    
MkDir ThisWorkbook.Path &
"Downloads"

       

'图片文件的存放目录
    
Path = ThisWorkbook.Path & "Downloads"
    
For
i = 2
To
Sheet1.Range(
"a65534"
).
End
(xlUp).Row
    
'A列中存放着图片的文件路径 <a href="http://www.xxx.net/photo/xxxx.gif">http://www.xxx.net/photo/xxxx.gif</a>
    
str = Sheet1.Range(
"a"
&amp; i)
    
Set
ie = CreateObject(
"Msxml2.XMLHTTP"
)
        
ie.Open
"GET"
, str,
False
        
ie.Send
        
'str = ie.ResponseText
        
'等待网页处理完成再运行下面的代码
        
Do
Until
ie.ReadyState = 4
            
DoEvents
        
Loop
       
With
CreateObject(
"ADODB.Stream"
)
            
.Type = 1
            
.Open
            
.write ie.Responsebody
            
'B列存放着新的文件名
            
.savetofile Path &amp; Sheet1.Range(
"b"
&amp; i) &amp; Right(str, 4), 2
            
.Close
        
End
With
    
Next
    
Application.ScreenUpdating =
True
    
Application.EnableEvents =
True
End
Sub

去除word文档保护及去掉打开密码

[去掉文档保护]

方法一(简单有效):启动word文档,新建一个空白文档,执行“插入文件”命令,打开“插入文件”对话框,定位到需要解除保护的文档所在的文件夹,选中该文档,单击“插入”按钮,将加密保护的文档插入到新文档中,文档保护会被自动撤销。

方法二:打开文档后,将其另存为XML文件,然后用UltaEdit这个编辑软件打开刚刚存储的XLM文件,查找

<w:documentProtection……w:unprtectPassword="******"/>

,这个“******”是可变的。只需要找到这段文字,,然后删掉这一段,保存退出,即可解除文档的密码保护。:)

如果您有一定的电脑基础,您可以试一下以下方法:
1、首先用Word 2003打开已设置有密码的“保护文档”(原始DOC文件),此文档可由Word 2000/XP(2002)/2003创建(保护文档创建方法见上文);
2、在菜单中选择“文件→另存为Web页”,保存为HTML文件后关闭Word;
3、用“记事本”或其他字处理软件打开上步中保存的HTML文件;
4、查找“UnprotectPassword”,“和”之间的为你设置的密码加密后的十六进制格式。
5、记录密码字符,例如本例中“3E36C48A”,关闭“记事本”;
6、使用十六进制文件编辑器(例如WinHex或者UltraEdit)以十六进制(Hex)格式打开原始DOC文件;
7、反序查找记录的十六进制密码字符,例如本例中查找“8A C4 36 3E”;
8、将查找到的4个双字节均用“0”覆盖,保存文件,关闭十六进制文件编辑器;(相信即使破解经验极少的人对步骤6~8操作起来也是易如反掌)
9、使用Word打开原始DOC文件,在菜单中选择“工具→解除文档保护”,密码为空。
至此,设置有密码的“保护文档”完全被破解,与没有经过保护的文档毫无区别

方法三:将受保护能查看不能修改的文档,另存为,再弹出的保存窗口中选择“保存类型”为“word97-2002″格式,保存后。再关掉word,重新打开,刚刚保存的文件,选择“工具”中“解除文档保护”即可编辑、修改这个文件了。
以上的三种方法都能够实现我们能看不能编辑的文档的保护密码的解除,大家可以用自己最为方便和习惯的使用方法。

[去掉打开密码]

OFFICE文档都具有密码保护功能,如果我们给一个WORD文档进行加密后忘记密码或者在网络上下载的WORD文档带有密码怎么办呢?

其实是可以解密的,需要使用Office Password Remover这个软件,此软件可以去掉DOC文件的密码,但是它需要破解密码的电脑必须能够上网才可以。

WORD文档解密软件汉化版下载地址:OfficePasswordRemover.rar 呵呵~如果你有一些个人隐私写在了WORD文档里千万不要用WORD自身的加密保护方式了

更改PPT所有页面字体与页面颜色的技巧

在评估期间,无心插柳地探索到一个新技术,就是关于PPT课件统一更改字体颜色和页面背景颜色的问题。
我想大家都遇到过类似情况,就是有时想把PPT打印出来备课用,可以在纸上写写画画对课件做标注之类的,但若是你的PPT原本是深色背景,如我有时喜欢用深蓝背景、白色字体,这样打印时很费墨的,因为打印出来整张纸背景都是深灰色或黑色!这时你肯定想同时更改所有页面的背景颜色和字体颜色(大款及不想为基金省钱的除外)。几页还好说,一页一页改就是了,但我的PPT往往一章都在一起,多达100多页,怎么办?
人民的智慧是无穷的!本人自己发现加上网络资料,总结了三种方法(备注:以下方法在Powerpoint2000中使用,对于更高版本,操作情况类似):
1.    最简单最好用的方法(五星推荐)!打开你要打印的PPT课件,点击视图——黑白,OK!你发现什么了?你的所有PPT都变成了黑白灰色,包括图片,所有页面背景是正常白色,所有字体是黑色(包括链接),原来你用的设计模板的颜色样式这时完全不起作用了!放心去打印吧!而且你还会发现一点,就是当你关闭文件时,并无提示让你重新保存;而当你再一次打开这个PPT,你会惊喜地发现,PPT并无改变,页面背景、字体颜色等还是你原来的色彩,也即“点击视图——黑白”这样的操作完全不改变你的原文件,改变的只是视图!另外,如果你不希望打印原来模板的背景图形,可以在任一页面无内容的空白处点击右键,选择背景,选择忽略母版的背景图形,再选择全部应用即可,但这时就会改变你的原文件,不过没关系,打印完后,再改回来就是了。
我写此文前搜索了大量相关网页,似乎还没看到有此方法。专利!!!
2.    方法2。打开你要打印的PPT课件,在任一页面无内容的空白处点击右键,选择幻灯片配色方案,你可以点击选用标准配色方案中有黑白灰三色的方案;也可自定义配色方案颜色,把所有背景色变为白色、字体变为黑色等。但如此做有一不完善之处,即那些你在做PPT时设置了特定填充色和特定字体颜色的文本框(不是你的PPT模板默认的颜色)会改成其设定颜色的反色,也即这些文本框需要你手动修改,好在一般这样的文本框不多。
3.    方法3。不仔细说了,用宏语言!相信大多数人不熟悉,也不想找这个麻烦。有兴趣的可搜索网上相关信息。
最后说说有关打印PPT的知识,还是和节省资源有关。想必你不希望一张A4纸只打印一张PPT,但你若用Powerpoint自带的打印工具在一张纸上打印多张PPT,会发现每个PPT页面都很小,这时你别使用Powerpoint自带的打印工具设置,而应该用打印机属性来设置在一张纸上打印多张PPT;或者使用软件fineprint,这个软件就是为一张纸上打印多张编写的,使用极其灵活,支持多种文件格式。

如何实现在Excel表格中删除汉字而不破坏其他内容?

方法一:
先将数据复制到WORD中,
在WORD中,编辑/替换
“查找内容”输入:[一-龤]      (带中括号)
“替换为”输入:/
勾选“使用通配符”
点“全部替换”

然后再将数据复制回EXCEL。

附:
龤:ALT+64922
WORD中是:ALT+40868

方法二:
=REPLACE(A1,MATCH(” “,MIDB(A1,ROW($1:$100),1),),LENB(A1)-LEN(A1),”/”)

方法三:
若你汉字均在前面,在b1输入公式:=right(a1,len(a1)*2-lenb(a1)),下面不用讲了吧

EXCEL密码去除(工作表、工作薄密码保护破解)

各位朋友不知有沒有碰到过这样的情况,当要打开一个EXCEL工作表时,突然发现密碼忘记了,唯一可做的也许是搞个破解软件来破一下,但针对打开后的工作表保护,一般就很难有效了,复制虽是一种方法,但不少数据(特別是公式较多者),可能就要乱套了,如何才能破解这一类密码呢?不久前在网上发现此精华,与大家共享一下!
利用宏运行方式破解,真的很有效,运行中可能电脑会有两分钟无反应,千萬不要以为死机了哦,等等吧!
步骤方法如下:1、打开文件2、工具—宏—-录制新宏—输入名字如:aa3、停止录制(这样得到一个空宏)4、工具—宏—-宏,选aa,点编辑按钮5、删除窗口中的所有字符(只有几个),替换为下面的内容:(复制吧)6、关闭编辑窗口7、工具—宏—–宏,选AllInternalPasswords,运行,确定两次,等2分钟,再确定.OK,没有密码了!
!宏内容如下:

Public Sub AllInternalPasswords()
' Breaks worksheet and workbook structure passwords. Bob McCormick
' probably originator of base code algorithm modified for coverage
' of workbook structure / windows passwords and for multiple passwords
'
' Norman Harker and JE McGimpsey 27-Dec-2002 (Version 1.1)
' Modified 2003-Apr-04 by JEM: All msgs to constants, and
' eliminate one Exit Sub (Version 1.1.1)
' Reveals hashed passwords NOT original passwords
Const DBLSPACE As String = vbNewLine & vbNewLine
Const AUTHORS As String = DBLSPACE & vbNewLine & _
"Adapted from Bob McCormick base code by" & _
"Norman Harker and JE McGimpsey"
Const HEADER As String = "AllInternalPasswords User Message"
Const VERSION As String = DBLSPACE & "Version 1.1.1 2003-Apr-04"
Const REPBACK As String = DBLSPACE & "Please report failure " & _
"to the microsoft.public.excel.programming newsgroup."
Const ALLCLEAR As String = DBLSPACE & "The workbook should " & _
"now be free of all password protection, so make sure you:" & _
DBLSPACE & "SAVE IT NOW!" & DBLSPACE & "and also" & _
DBLSPACE & "BACKUP!, BACKUP!!, BACKUP!!!" & _
DBLSPACE & "Also, remember that the password was " & _
"put there for a reason. Don't stuff up crucial formulas " & _
"or data." & DBLSPACE & "Access and use of some data " & _
"may be an offense. If in doubt, don't."
Const MSGNOPWORDS1 As String = "There were no passwords on " & _
"sheets, or workbook structure or windows." & AUTHORS & VERSION
Const MSGNOPWORDS2 As String = "There was no protection to " & _
"workbook structure or windows." & DBLSPACE & _
"Proceeding to unprotect sheets." & AUTHORS & VERSION
Const MSGTAKETIME As String = "After pressing OK button this " & _
"will take some time." & DBLSPACE & "Amount of time " & _
"depends on how many different passwords, the " & _
"passwords, and your computer's specification." & DBLSPACE & _
"Just be patient! Make me a coffee!" & AUTHORS & VERSION
Const MSGPWORDFOUND1 As String = "You had a Worksheet " & _
"Structure or Windows Password set." & DBLSPACE & _
"The password found was: " & DBLSPACE & "$$" & DBLSPACE & _
"Note it down for potential future use in other workbooks by " & _
"the same person who set this password." & DBLSPACE & _
"Now to check and clear other passwords." & AUTHORS & VERSION
Const MSGPWORDFOUND2 As String = "You had a Worksheet " & _
"password set." & DBLSPACE & "The password found was: " & _
DBLSPACE & "$$" & DBLSPACE & "Note it down for potential " & _
"future use in other workbooks by same person who " & _
"set this password." & DBLSPACE & "Now to check and clear " & _
"other passwords." & AUTHORS & VERSION
Const MSGONLYONE As String = "Only structure / windows " & _
"protected with the password that was just found." & _
ALLCLEAR & AUTHORS & VERSION & REPBACK
Dim w1 As Worksheet, w2 As Worksheet
Dim i As Integer, j As Integer, k As Integer, l As Integer
Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer
Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer
Dim PWord1 As String
Dim ShTag As Boolean, WinTag As Boolean

Application.ScreenUpdating = False
With ActiveWorkbook
WinTag = .ProtectStructure Or .ProtectWindows
End With
ShTag = False
For Each w1 In Worksheets
ShTag = ShTag Or w1.ProtectContents
Next w1
If Not ShTag And Not WinTag Then
MsgBox MSGNOPWORDS1, vbInformation, HEADER
Exit Sub
End If
MsgBox MSGTAKETIME, vbInformation, HEADER
If Not WinTag Then
MsgBox MSGNOPWORDS2, vbInformation, HEADER
Else
On Error Resume Next
Do 'dummy do loop
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
With ActiveWorkbook
.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If .ProtectStructure = False And _
.ProtectWindows = False Then
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
MsgBox Application.Substitute(MSGPWORDFOUND1, _
"$$", PWord1), vbInformation, HEADER
Exit Do 'Bypass all for...nexts
End If
End With
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
Loop Until True
On Error GoTo 0
End If
If WinTag And Not ShTag Then
MsgBox MSGONLYONE, vbInformation, HEADER
Exit Sub
End If
On Error Resume Next
For Each w1 In Worksheets
'Attempt clearance with PWord1
w1.Unprotect PWord1
Next w1
On Error GoTo 0
ShTag = False
For Each w1 In Worksheets
'Checks for all clear ShTag triggered to 1 if not.
ShTag = ShTag Or w1.ProtectContents
Next w1
If ShTag Then
For Each w1 In Worksheets
With w1
If .ProtectContents Then
On Error Resume Next
Do 'Dummy do loop
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If Not .ProtectContents Then
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
MsgBox Application.Substitute(MSGPWORDFOUND2, _
"$$", PWord1), vbInformation, HEADER
'leverage finding Pword by trying on other sheets
For Each w2 In Worksheets
w2.Unprotect PWord1
Next w2
Exit Do 'Bypass all for...nexts
End If
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
Loop Until True
On Error GoTo 0
End If
End With
Next w1
End If
MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER
End Sub

好了,经测试有效,祝各位成功!

word如何自动分割成多个文档

Sub 每N页分割为一个新文档__保存到同目录下()
'特别鸣谢"雨雪霏霏、守柔版主。
    Dim MyPath As String, PageCount As Integer
    Dim StartRange As Long, EndRange As Long, MyRange As Range
    Dim Fn As String, MyDoc As Document, i As Integer
    On Error Resume Next
    Application.ScreenUpdating = False
    MyPath = ActiveDocument.Path    '取得文档路径
    PageCount = Selection.Information(wdNumberOfPagesInDocument)    '取得文档总页数
    N = InputBox("按每几页拆分?默认为3:", "请输入数值", 3)
    Selection.HomeKey unit:=wdStory    '将光标移至文档起点
    For i = 1 To PageCount / N + (PageCount Mod N)    '设置循环次数,如3则表示每3页做一次循环
        StartRange = Selection.Start    '取得该页的第一个字符位置
        Selection.EndKey unit:=wdLine    '将光标移动到该页首行的最后位置
        Fn = i & ActiveDocument.Name    '-1的目的是防止该页首行含有段落标记,导致出错.
        If i * N >= PageCount Then    '如果循环到达最后一页
            EndRange = ActiveDocument.Content.End    '将文档最后位置赋值于EndRange
        Else
           For J = 1 To N
            Selection.GoToNext (wdGoToPage)
            Next J
            EndRange = Selection.Start
        End If
        Set MyRange = ActiveDocument.Range(StartRange, EndRange)  '将N页中的内容进行复制
        MyRange.Copy
        Set MyDoc = Documents.Add    '新建一空白文档
        With MyDoc
             .Content.Paste    '在新文档中粘贴
             .Content.Paragraphs.Last.Range.Delete '删除新文档末尾多出来的一个段落标记
             .SaveAs FileName:=MyPath & "/" & Fn
             '保存新文档到原文档所在目录。如果删除"MyPath & "/" & ",。则保存到"我的文档"中。
             .Close    '关闭新文档
        End With
    Next
    Application.ScreenUpdating = True
End Sub

EXCEL中日期变为文本格式

方法一:假设数据在A列,B1输入公式=text(a1,”yyyy-m-d”)双击填充柄

其中:”yyyy-m-d”  可改为自己想要的格式
方法二:选择要转换的日期列—>数据—>分列—>下一步—>下一步—>选择文本,点击完成。这样日期格式的数据就转换成了文本类型了