微信好友批量提取

企鹅先森 · 发表于 2020-11-9 15:59

断了的眩发表于 2020-11-9 11:24
python的前提是能打开网页的微信

我的微信号不行

企鹅先森 · 发表于 2020-11-9 16:01

wangqh8203 发表于 2020-11-9 15:58
百度wetool这个工具

这个要企业微信

kldxlb · 发表于 2020-11-10 09:54

Sub main()
Dim result
Dim sContent As String
Dim oDataObject
Set oDataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
MsgBox "点击确定后10秒内完成以下操作" & vbCrLf & "1、双击选中好友微信号" & vbCrLf & "2、鼠标中键点击好友列表"
Dim t
t = Timer
Do While Timer - t < 10
DoEvents
Loop
r = 1
ReDim result(1 To 1)
Do
ReDim Preserve result(1 To r)
latdContent = sContent
Application.SendKeys "^C"
With oDataObject
.GetFromClipboard
sContent = .GetText
End With
result(r) = sContent
r = r + 1
If r = 1000 Then Exit Do ' 防止异常导致死循环而不能退出
Application.SendKeys "{DOWN}"
Loop Until sContent = latdContent
Set oDataObject = Nothing
ThisWorkbook.Sheets(1).Range("A1").Resize(UBound(result), 1) = Application.Transpose(result)
Msgbox "执行完毕，用时" & Timer - t & "秒"
End Sub

复制代码

电脑没装微信没有测试，逻辑也简单，有问题自己改下就好了

企鹅先森 · 发表于 2020-11-10 12:05

kldxlb 发表于 2020-11-10 09:54
电脑没装微信没有测试，逻辑也简单，有问题自己改下就好了

好的，我晚点测试一下，谢谢

ax212786 · 发表于 2020-11-24 08:10

0.0.................

592rmb · 发表于 2022-5-17 10:57

kldxlb 发表于 2020-11-10 09:54
电脑没装微信没有测试，逻辑也简单，有问题自己改下就好了

ThisWorkbook.Sheets(1).Range("A1").Resize(UBound(result), 1) = Application.Transpose(result)
老师，这一句提示类型错误，麻烦看一下是什么情况？谢谢

592rmb · 发表于 2022-5-18 09:55

kldxlb 发表于 2020-11-10 09:54
电脑没装微信没有测试，逻辑也简单，有问题自己改下就好了

ThisWorkbook.Sheets(1).Range("A1").Resize(UBound(result), 1) = Application.Transpose(result)
老师，这一句提示类型错误，麻烦看一下是什么情况？谢谢

592rmb · 发表于 2022-5-19 09:20

kldxlb 发表于 2020-11-10 09:54
电脑没装微信没有测试，逻辑也简单，有问题自己改下就好了

请问微信好友批量提取搞定了吗？能不能发个搞好的模板给我，谢谢

SCWYZJ · 发表于 2022-9-24 11:25

老师，停留时间可以改吗？还有我鼠标是滚轮的，没有中键怎么办？我试了一下，没有中键的情况下，一直不停复制粘贴同一个好友，又是什么解决办法吗、谢谢

SCWYZJ · 发表于 2022-9-24 11:29

企鹅先森发表于 2020-11-10 12:05
好的，我晚点测试一下，谢谢

企鹅先森老师，停留时间可以改吗？还有我鼠标是滚轮的，没有中键怎么办？我试了一下，没有中键的情况下，一直不停复制粘贴同一个好友，又是什么解决办法吗、谢谢

		自动登录	找回密码
密码			免费注册

[分享] 微信好友批量提取