Compare commits

...

12 Commits

Author SHA1 Message Date
Andy
59dacf67bd 2026.10.26.0
YT
Exclude AI from results and correct handling

SC
API.UserDataBase: force put text into the 'text' folder
API.Instagram: fix saved posts
API.OnlyFans: text posts are not downloading
API.Xhamster: correct processing progress
2026-10-26 17:59:40 +03:00
Andy
51d8326807 2026.9.21.0
YT
VideoOptionsForm: handling of type 'audio+video'
YouTubeMediaContainerBase: move 'DataReceivedEventHandler' to a public module

SC
REMOVE: Mastodon, Imgur
API.UserDataBase: remove unused references; optimize the use of '_ForceSaveUserData' and '_ForceSaveUserInfo'; update 'ErrorDownloading' function
API.Base.YTDLP: add 'SetProgress' and 'CreateFileExchanger' functions
API.Bluesky: add 'UseMD5Comparison' and 'RemoveExistingDuplicates' options; handling errors 502 and 504; update 'UserExists' detection
API.Instagram: switch to 'GraphQL'
API.OnlyFans: add a special label 'DRM'
API.PornHub: fix photo and video downloads; add yt-dlp support
API.Reddit: remove predefined 'ClientID' and 'ClientSecret'; update 'AvailableTrueValue' function; add REST API support; fix carousels downloading; remove Imgur support
API.ThisVid: fix profile info
API.Twitter: remove Mastodon compatibility; update bookmarks link
API.Xhamster: update yt-dlp
Automation: remove unused references
DownloadFeedForm: new feeds do not appear in the 'Load' toolbar dropdown
MissingPostsForm: add 'ESC' hotkey
TDownloader: implement the ability to add to the log a list of users who have missing posts; exclude the 'Path' plugin from downloading
VideoDownloaderForm: remove Imgur support
DownloadableMediaHost: remove Imgur support; protect photos from deletion
PluginHost: remove Mastodon
SettingsCLS: add 'AddMissingPostUsersToLog' property
2026-09-21 17:57:58 +03:00
Andy
ffab035cee 2026.8.7.0
API: updated EditorExchangeOptionsBase and its inheritances
API.Base.SiteSettingsBase: updated 'Responser' creation algorithm
API.Base.UserDataBase: updated 'DownloadContentDefault_ConvertWebp_Impl' function
API.Instagram: added 'USE_GQL_Highlights' property; updated 'DocId' to get highlights and user info; remove 'ValidateExtension'; add 'DownloadContentDefault_ConvertWebp' to convert 'heic' files; fix highlights downloading; update getting username by ID
API.Reddit: fix missing posts downloading
API.ThisVid: fix a bug with updating/adding cookies
API.Twitter: fix post text is not downloaded completely
API.Xhamster: fix some posts are not downloaded
DownloadFeedForm: improve filters; add loading buttons 'Current', 'Favorite' and 'Load'
FeedMedia: fix an issue where post text would not load in older feeds
FeedFilter: add search by labels; fix saving filters when selecting users; fix an issue with the 'TEMP' filter
SiteEditorForm: get a cookies instance from the source
2026-08-07 17:29:35 +03:00
Andy
9b3c172fc3 Update README.md 2026-06-01 11:12:04 +03:00
Andy
9ba78d2fa0 2026.5.13.0
API.Base: add 'IThumbList' interface; add the 'ReparseMissing_ClearList' function to the base class
API.Instagram: protect all necessary controls; fix error getting user info
API.OnlyFans: add the 'CookieDateProvider' class to avoid cookies error
API.PornHub: add image and title additional regex; fix subscription downloading bug
API.ThisVid: add 'ReparseMissing' function
Feed: add the most frequently used buttons to the top
FeedMedia: fix subscription bug
2026-05-13 20:45:18 +03:00
Andy
be97752b7c 2026.3.23.0
API.EditorExchangeOptionsBase: move the 'Apply' function
API.EditorExchangeOptionsBase_P: remove the 'Apply' function
API.UserDataBase: update the 'UserSiteNameUpdate' function; remove the '_ForceSaveUserInfoOnException' property; update the 'DownloadContentDefault_ConvertWebp' function; add the 'DownloadContentDefault_ConvertWebp_TestImg' and 'DownloadContentDefault_ConvertWebp_Impl' functions
API.Bluesky: add the 'EditorExchangeOptions' class; add 'did:' handle for recognizing
API.PornHub: update M3U8 download functions
API.TikTok: fix where gallery-dl would hang when downloading stories
API.Twitter: fix downloading a single media file (standalone downloader) fails
API.Xhamster: add 'webm' to 'jpg' correct conversion
FeedMedia: move the 'ImageRenderer2' class into the 'UserImage' class
UserImage: add the 'ImageRenderer2' class
2026-03-23 17:21:04 +03:00
Andy
d0d8e5470e 2026.2.14.0
TokenBatch: add 'MyWorkingDirectory' property
API.Instagram: update 'ID' extraction; reduce the number of downloaded stories (GQL) to 5
API.Twitter: get a new username based on the user ID
API.XHamster: videos aren't downloading
Feed: fix a bug when removing from favorites
2026-02-14 14:24:03 +03:00
Andy
164b999de7 2026.1.24.0
Instagram: update settings; fix a bug in line 1437
OnlyFans: update the URLs that open posts
2026-01-24 18:17:28 +03:00
Andy
e6d5fc2b95 2026.1.17.0
UserDataBase: move GLD functions from 'Twitter'
Instagram: add 'Reposts' and 'Likes' to the 'Sections' enum
OnlyFans: update the regex in 'DynamicRulesEnv'; handling error 502
PornHub: fix videos aren't downloading
ThreadsNet: add user name and description extraction
TikTok: fix downloading new videos; add downloading 'Stories' and 'Reposts'
Twitter: move GLD functions to 'UserDataBase'
Xhamster: fix a bug when adding new users; fix incorrect cache location
Download groups: add excluded groups
MainFrame: fix the 'Feed' tooltip
2026-01-17 20:06:37 +03:00
Andy
6d4380ccac 2025.11.25.0
YT
YouTubeSettings: add property 'DefaultSubtitlesEmbed'
YouTubeMediaContainerBase: improve trim options; update command for 'DefaultSubtitlesEmbed'

SCrawler
TokenBatch, GDLBatch, YTDLPBatch: optimize code; add default encoding
UserMedia: add property 'IsPhotoType'
API.TikTok: optimize code; download descriptions
API.Twitter: optimize code; fix downloading of site name, description and avatar
API.Xhamster: add the properties 'UseYTDLPJSON', 'UseYTDLPDownload' and 'UseYTDLPForceDisableInternal'; add yt-dlp support; update parsing functions
Groups, automation: delete 'Modes'; add groups downloading among other options; optimize code
DownloadSavedPostsForm, DownloadProgress: add hotkey 'Esc'
MainFrame: update 'BTT_VIEW_FILTER_LOAD_Click' function
2025-11-25 12:57:37 +03:00
Andy
8dfd4e8bd1 2025.10.4.0
YT
YouTubeSettings: add property 'ParseLongUserTitle'
YouTubeMediaContainerBase: concatenate artists

SCrawler
Bluesky: add saved posts downloading
xHamster: temporarily disable the plugin
2025-10-04 15:43:40 +03:00
Andy
1404afdfa3 2025.9.1.0
API.PornHub: update regex and data parsing
2025-09-01 16:41:44 +03:00
124 changed files with 4186 additions and 2409 deletions

File diff suppressed because it is too large Load Diff

7
FAQ.md
View File

@@ -33,6 +33,7 @@ I strongly recommend you to **regularly** create backup copies of the settings f
## General questions
- **PROFILES**
- I added a profile but **nothing downloaded** :arrow_forward: check your cookies and [site requirements](https://github.com/AAndyProgram/SCrawler/wiki/Settings#sites-requirements). If there are any optional fields that you don't fill in, do so. Still nothing works - [report it](#how-to-report-a-problem)!
- :exclamation: **Try to avoid Chinese/Japanese symbols in the paths.**
- User downloading failed :arrow_forward: check your credentials and **[SITES REQUIREMENTS](https://github.com/AAndyProgram/SCrawler/wiki/Settings#sites-requirements)**. If all settings are set and nothing works, [report it](#how-to-report-a-problem). **Don't forget to attach the LOG.**
- [How to redownload user](https://github.com/AAndyProgram/SCrawler/wiki#redownload-user)
- How to **add profile** to download :arrow_forward: copy the **[profile URL](https://github.com/AAndyProgram/SCrawler/wiki#add-user)** and press `Insert` or `Ctrl+Insert`. **ALWAYS PASTE THE USER PROFILE URL**. After that select this user and press `F5` or click the `Download selected` button.
@@ -61,14 +62,14 @@ I strongly recommend you to **regularly** create backup copies of the settings f
*How to use: find the site you need in the list and read the answer.*
- Reddit: don't use credentials at all or configure [OAuth](https://github.com/AAndyProgram/SCrawler/wiki/Settings#how-to-get-reddit-credentials). **Reddit profiles can be downloaded without any credentials at all. Subreddits require OAuth! If nothing downloads, use OAuth!** Don't use OAuth token to download saved posts (use cookies only).
- Reddit: add cookies and/or configure [OAuth](https://github.com/AAndyProgram/SCrawler/wiki/Settings#how-to-get-reddit-credentials). **Reddit profiles can be downloaded without credentials using cookies. Subreddits require OAuth! If nothing downloads, use OAuth!** Don't use OAuth token to download saved posts (use cookies only).
- **META** (**Instagram**, Threads, Facebook): you need **cookies** and fill in **all fields**
- **Instagram [TIPS](https://github.com/AAndyProgram/SCrawler/wiki/Settings#instagram-tips)**
- **Instagram saved posts**: I don't consider questions like "I have 10k saved posts and only 1000 were downloaded". Download posts, remove them from saved posts, delete the `Saved posts` **settings folder**, repeat.
- TikTok: works via yt-dlp. If something doesn't download, we need to wait until yt-dlp fixes it. TikTok doesn't require cookies to download.
- TikTok: works via yt-dlp. If something doesn't download, we need to wait until yt-dlp fixes it. TikTok doesn't require cookies to download. Photos are downloaded using gallery-dl.
- Porn sites: **COOKIES**!
- ThisVid: https://github.com/AAndyProgram/SCrawler/wiki/Settings#thisvid-faq
- **OnlyFans**: cookies + **all fields** + [OF-Scraper (download the correct version that I pointed)](https://github.com/AAndyProgram/SCrawler/wiki/Settings#of-scraper) & [mp4decrypt](https://www.bento4.com/downloads/) & **DRM keys** to download DRM protected videos. [OF-Scraper support](https://github.com/AAndyProgram/SCrawler/wiki/Settings#of-scraper-support). Also read [this](https://github.com/AAndyProgram/SCrawler/wiki/Settings#onlyfans-faq)
- **OnlyFans**: cookies + **all fields** + [OF-Scraper (download the correct version that I pointed)](https://github.com/AAndyProgram/SCrawler/wiki/Settings#of-scraper) & **DRM keys** to download DRM protected videos. [OF-Scraper support](https://github.com/AAndyProgram/SCrawler/wiki/Settings#of-scraper-support). Also read [this](https://github.com/AAndyProgram/SCrawler/wiki/Settings#onlyfans-faq)
- **JustForFans**: **THE VIDEO ISN'T DOWNLOADING AT THE MOMENT** ([Issue](https://discord.com/channels/1124032649682493462/1205547615199039551/1231349555132366870))
## Other questions

View File

@@ -8,3 +8,4 @@ List of available plugins:
Tools:
- [image2post](https://github.com/unknown81311/SCrawler-image2post) by @unknown81311: **get reddit post URL from file.**
- [Update-SCrawler-Tools](https://github.com/cjb900/Update-SCrawler-Tools) by @cjb900: **a tool for updating third-party programs such as yt-dlp and gallery-dl**

Binary file not shown.

After

Width:  |  Height:  |  Size: 847 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 101 KiB

After

Width:  |  Height:  |  Size: 121 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 17 KiB

After

Width:  |  Height:  |  Size: 26 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 39 KiB

After

Width:  |  Height:  |  Size: 56 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 26 KiB

After

Width:  |  Height:  |  Size: 38 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 16 KiB

After

Width:  |  Height:  |  Size: 28 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 31 KiB

After

Width:  |  Height:  |  Size: 53 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 28 KiB

After

Width:  |  Height:  |  Size: 46 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 25 KiB

After

Width:  |  Height:  |  Size: 41 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 23 KiB

After

Width:  |  Height:  |  Size: 42 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 31 KiB

After

Width:  |  Height:  |  Size: 48 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 14 KiB

After

Width:  |  Height:  |  Size: 24 KiB

View File

@@ -1,5 +1,4 @@
# 🏳️‍🌈 Happy LGBT Pride Month 🎉
<!---# 🏳️‍🌈 Happy LGBT Pride Month 🎉--->
# 🏳️‍🌈 Social networks crawler 🏳️‍🌈
[![GitHub release (latest by date)](https://img.shields.io/github/v/release/AAndyProgram/SCrawler)](https://github.com/AAndyProgram/SCrawler/releases/latest)
@@ -41,14 +40,11 @@ A program to download photo and video from [any site](#supported-sites) (e.g. Yo
- Bluesky images and videos, text;
- OnlyFans images and videos, text, saved (bookmarked) posts, stories;
- JustForFans images and videos, saved (bookmarked) posts;
- Mastodon images and videos, saved (bookmarked) posts;
- Instagram images and videos, text, tagged posts, stories, saved posts;
- Threads images and videos, text, saved posts;
- Facebook images and videos, stories, saved posts;
- TikTok images and videos;
- Pinterest boards, users, saved posts;
- Imgur images, galleries and videos;
- Gfycat videos;
- PornHub images, videos, save (liked) posts, search queries, search categories;
- XHamster images, videos, saved posts, search queries, search categories, search tags;
- XVIDEOS videos, saved posts, search queries, search categories;
@@ -85,12 +81,9 @@ A program to download photo and video from [any site](#supported-sites) (e.g. Yo
- **Threads**
- **Facebook**
- JustForFans *(partial support) ([video issue](https://discord.com/channels/1124032649682493462/1205547615199039551/1231349555132366870))*[^1]
- Mastodon *(out of support)*
- TikTok
- RedGifs
- Pinterest
- Imgur *(out of support)*
- Gfycat
- LPSG
- **PornHub**
- **XHamster**
@@ -135,7 +128,6 @@ First, the program downloads the full profile. After the program downloads only
- [Twitter](https://github.com/AAndyProgram/SCrawler/wiki/Settings#twitter)
- [Bluesky](https://github.com/AAndyProgram/SCrawler/wiki/Settings#bluesky)
- [OnlyFans](https://github.com/AAndyProgram/SCrawler/wiki/Settings#onlyfans)
- [Mastodon](https://github.com/AAndyProgram/SCrawler/wiki/Settings#mastodon)
- [Instagram](https://github.com/AAndyProgram/SCrawler/wiki/Settings#instagram)
- [Threads](https://github.com/AAndyProgram/SCrawler/wiki/Settings#threads)
- [Facebook](https://github.com/AAndyProgram/SCrawler/wiki/Settings#facebook)

View File

@@ -113,6 +113,51 @@ Namespace API.YouTube.Base
Return Protocols.Undefined
End Get
End Property
Public Language As String
Public ReadOnly Property LanguageCaption(Optional ByVal IncludeNote As Boolean = False) As String
Get
Dim c$ = String.Empty
If Not Language.IsEmptyString Then c = $"[{Language}]"
If Not FormatNote.IsEmptyString And IncludeNote Then c.StringAppend($"({FormatNoteClean.IfNullOrEmpty(FormatNote)})", " ")
Return c
End Get
End Property
Public FormatNote As String
Public FormatNoteClean As String
Public ReadOnly Property IsAI As Boolean
Get
Return Not FormatNote.IsEmptyString AndAlso FormatNote.ToLower.Contains("dubbed-auto")
End Get
End Property
Public ReadOnly Property IsOriginalLanguage As Boolean
Get
Return Not FormatNote.IsEmptyString AndAlso FormatNote.ToLower.Contains("original")
End Get
End Property
Public ReadOnly Property IsDefaultLanguage As Boolean
Get
Return Not FormatNote.IsEmptyString AndAlso FormatNote.ToLower.Contains("default")
End Get
End Property
Public ReadOnly Property IsDefaultOrOriginal As Boolean
Get
Return IsDefaultLanguage Or IsOriginalLanguage
End Get
End Property
Public ReadOnly Property FormatQuality As String
Get
If Not FormatNote.IsEmptyString Then
If FormatNote.Contains("high") Then
Return "high"
ElseIf FormatNote.Contains("medium") Then
Return "medium"
ElseIf FormatNote.Contains("low") Then
Return "low"
End If
End If
Return String.Empty
End Get
End Property
Public URL As String
Public Property Index As Integer Implements IIndexable.Index
Private Function SetIndex(ByVal Obj As Object, ByVal Index As Integer) As Object Implements IIndexable.SetIndex

View File

@@ -268,6 +268,9 @@ Namespace API.YouTube.Base
<Browsable(True), GridVisible, XMLVN({"Defaults"}, FileDateMode.None), Category("Defaults"), DisplayName("Add channel to file name"),
Description("Add channel name before/after the file name")>
Public ReadOnly Property FileAddChannelToFileName As XMLValue(Of FileDateMode)
<Browsable(True), GridVisible, XMLVN({"Defaults"}, True), Category("Defaults"), DisplayName("Parse long user titles"),
Description("Suitable for multiple artists")>
Public ReadOnly Property ParseLongUserTitle As XMLValue(Of Boolean)
#End Region
#Region "Defaults ChannelsDownload"
<Browsable(True), GridVisible, XMLVN({"Defaults", "Channels"}), Category("Defaults"), DisplayName("Default download tabs for channels"),
@@ -410,6 +413,15 @@ Namespace API.YouTube.Base
Private Function AvailableAudioFormats_Impl() As String()
Return AvailableAudioFormats
End Function
<Browsable(True), GridVisible, XMLVN({"DefaultsAudio"}, True), Category("Defaults Audio"), DisplayName("Language: exclude AI"),
Description("Exclude AI from results. Default: true.")>
Public ReadOnly Property DefaultAudioLanguage_ExcludeAI As XMLValue(Of Boolean)
<Browsable(True), GridVisible, XMLVN({"DefaultsAudio"}, True), Category("Defaults Audio"), DisplayName("Language: exclude not default"),
Description("Exclude non-default or non-original languages from the results. Default: true.")>
Public ReadOnly Property DefaultAudioLanguage_ExcludeNonDefault As XMLValue(Of Boolean)
<Browsable(True), GridVisible, XMLVN({"DefaultsAudio"}, True), Category("Defaults Audio"), DisplayName("Use default"),
Description("Use the original or default language. Default: true.")>
Public ReadOnly Property DefaultAudioLanguageUseDefault As XMLValue(Of Boolean)
<Browsable(True), GridVisible, XMLVN({"DefaultsAudio"}, "MP3"), Category("Defaults Audio"), DisplayName("Default codec for music"),
TypeConverter(GetType(FieldsTypeConverter)), GridStandardValuesProvider(NameOf(AvailableAudioFormats_Impl)),
Description("The default audio format for downloading music.")>
@@ -498,6 +510,9 @@ Namespace API.YouTube.Base
TypeConverter(GetType(ValueCollectionConverter)),
Description("Additional format for downloading subtitles. This means that all subtitles will be converted to the formats you choose and saved as separate files.")>
Public ReadOnly Property DefaultSubtitlesFormatAddit As XMLValuesCollection(Of String)
<Browsable(True), GridVisible, XMLVN({"DefaultsSubtitles"}), Category("Defaults Subtitles"), DisplayName("Embed subtitles"),
Description("Embed subtitles in the video (only for mp4, webm and mkv videos)")>
Public ReadOnly Property DefaultSubtitlesEmbed As XMLValue(Of Boolean)
#End Region
#Region "Trim"
<Browsable(True), GridVisible, XMLVN({"DefaultsTrim"}, False), Category("Defaults Trimming"), DisplayName("Delete original file"),

View File

@@ -22,37 +22,36 @@ Namespace API.YouTube.Controls
Private components As System.ComponentModel.IContainer
<System.Diagnostics.DebuggerStepThrough()>
Private Sub InitializeComponent()
Dim TP_MAIN As System.Windows.Forms.TableLayoutPanel
Me.TP_MAIN = New System.Windows.Forms.TableLayoutPanel()
Me.OPT_CHECKED = New System.Windows.Forms.RadioButton()
Me.LBL_DEFINITION_INFO = New System.Windows.Forms.Label()
Me.LBL_DEFINITION = New System.Windows.Forms.Label()
Me.LBL_CODECS = New System.Windows.Forms.Label()
Me.LBL_SIZE = New System.Windows.Forms.Label()
TP_MAIN = New System.Windows.Forms.TableLayoutPanel()
TP_MAIN.SuspendLayout()
Me.TP_MAIN.SuspendLayout()
Me.SuspendLayout()
'
'TP_MAIN
'
TP_MAIN.ColumnCount = 5
TP_MAIN.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Absolute, 36.0!))
TP_MAIN.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Absolute, 110.0!))
TP_MAIN.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Absolute, 58.0!))
TP_MAIN.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Percent, 100.0!))
TP_MAIN.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Absolute, 71.0!))
TP_MAIN.Controls.Add(Me.OPT_CHECKED, 0, 0)
TP_MAIN.Controls.Add(Me.LBL_DEFINITION_INFO, 1, 0)
TP_MAIN.Controls.Add(Me.LBL_DEFINITION, 2, 0)
TP_MAIN.Controls.Add(Me.LBL_CODECS, 3, 0)
TP_MAIN.Controls.Add(Me.LBL_SIZE, 4, 0)
TP_MAIN.Dock = System.Windows.Forms.DockStyle.Fill
TP_MAIN.Location = New System.Drawing.Point(0, 0)
TP_MAIN.Margin = New System.Windows.Forms.Padding(0)
TP_MAIN.Name = "TP_MAIN"
TP_MAIN.RowCount = 1
TP_MAIN.RowStyles.Add(New System.Windows.Forms.RowStyle(System.Windows.Forms.SizeType.Percent, 100.0!))
TP_MAIN.Size = New System.Drawing.Size(459, 30)
TP_MAIN.TabIndex = 0
Me.TP_MAIN.ColumnCount = 5
Me.TP_MAIN.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Absolute, 36.0!))
Me.TP_MAIN.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Absolute, 110.0!))
Me.TP_MAIN.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Absolute, 58.0!))
Me.TP_MAIN.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Percent, 100.0!))
Me.TP_MAIN.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Absolute, 71.0!))
Me.TP_MAIN.Controls.Add(Me.OPT_CHECKED, 0, 0)
Me.TP_MAIN.Controls.Add(Me.LBL_DEFINITION_INFO, 1, 0)
Me.TP_MAIN.Controls.Add(Me.LBL_DEFINITION, 2, 0)
Me.TP_MAIN.Controls.Add(Me.LBL_CODECS, 3, 0)
Me.TP_MAIN.Controls.Add(Me.LBL_SIZE, 4, 0)
Me.TP_MAIN.Dock = System.Windows.Forms.DockStyle.Fill
Me.TP_MAIN.Location = New System.Drawing.Point(0, 0)
Me.TP_MAIN.Margin = New System.Windows.Forms.Padding(0)
Me.TP_MAIN.Name = "TP_MAIN"
Me.TP_MAIN.RowCount = 1
Me.TP_MAIN.RowStyles.Add(New System.Windows.Forms.RowStyle(System.Windows.Forms.SizeType.Percent, 100.0!))
Me.TP_MAIN.Size = New System.Drawing.Size(459, 30)
Me.TP_MAIN.TabIndex = 0
'
'OPT_CHECKED
'
@@ -115,11 +114,11 @@ Namespace API.YouTube.Controls
'
Me.AutoScaleDimensions = New System.Drawing.SizeF(6.0!, 13.0!)
Me.AutoScaleMode = System.Windows.Forms.AutoScaleMode.Font
Me.Controls.Add(TP_MAIN)
Me.Controls.Add(Me.TP_MAIN)
Me.Name = "VideoOption"
Me.Size = New System.Drawing.Size(459, 30)
TP_MAIN.ResumeLayout(False)
TP_MAIN.PerformLayout()
Me.TP_MAIN.ResumeLayout(False)
Me.TP_MAIN.PerformLayout()
Me.ResumeLayout(False)
End Sub
@@ -128,5 +127,6 @@ Namespace API.YouTube.Controls
Private WithEvents LBL_DEFINITION As Label
Private WithEvents LBL_CODECS As Label
Private WithEvents LBL_SIZE As Label
Private WithEvents TP_MAIN As TableLayoutPanel
End Class
End Namespace

View File

@@ -117,7 +117,4 @@
<resheader name="writer">
<value>System.Resources.ResXResourceWriter, System.Windows.Forms, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</resheader>
<metadata name="TP_MAIN.GenerateMember" type="System.Boolean, mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
<value>False</value>
</metadata>
</root>

View File

@@ -8,10 +8,14 @@
' but WITHOUT ANY WARRANTY
Imports System.ComponentModel
Imports SCrawler.API.YouTube.Base
Imports SCrawler.API.YouTube.Objects
Imports UMTypes = SCrawler.Plugin.UserMediaTypes
Namespace API.YouTube.Controls
<DefaultEvent("CheckedChanged"), DesignTimeVisible(False), ToolboxItem(False)>
Friend Class VideoOption : Implements ISupportInitialize
Friend Event CheckedChanged As EventHandler
Private Const DRC As String = YouTubeMediaContainerBase.DRC
Private Const StringDelimiter As String = " " & ChrW(183) & " "
<Browsable(False)> Friend Property MyMedia As MediaObject
<Browsable(False)> Friend Property Checked As Boolean
Get
@@ -21,16 +25,43 @@ Namespace API.YouTube.Controls
OPT_CHECKED.Checked = _Checked
End Set
End Property
<Browsable(False)> Friend ReadOnly Property ContentType As UMTypes
Get
If MyMedia.Type = UMTypes.Audio Then
Return UMTypes.Audio
ElseIf MyMedia.Type = UMTypes.Video Or MyMedia.Type = YouTubeMediaContainerBase.TypeAudioVideo Then
Return UMTypes.Video
Else
Return UMTypes.Undefined
End If
End Get
End Property
Private _CodecLength As Integer = 0
<Browsable(False)> Friend ReadOnly Property CodecLengthBase As Integer
Get
With TP_MAIN.ColumnStyles
Return .Item(0).Width + .Item(1).Width + .Item(2).Width + .Item(4).Width
End With
End Get
End Property
<Browsable(False)> Friend ReadOnly Property CodecLength As Integer
Get
Return Math.Max(LBL_CODECS.PreferredWidth, _CodecLength)
End Get
End Property
Friend Sub SetAudioChangingHandler(ByVal obj As VideoOptionsForm)
AddHandler obj.AudioIndexChanged, AddressOf AudioChanged
End Sub
Friend Sub New()
InitializeComponent()
End Sub
Friend Sub New(ByVal m As MediaObject, Optional ByVal SelectedAudio As MediaObject = Nothing)
Me.New
Const d$ = " " & ChrW(183) & " "
Const DRC$ = Objects.YouTubeMediaContainerBase.DRC
MyMedia = m
If m.Type = Plugin.UserMediaTypes.Audio Then
If m.Bitrate >= 320 Then
If Not m.FormatQuality.IsEmptyString Then
LBL_DEFINITION_INFO.Text = $"{m.FormatQuality.ToUpperFirstChar} Quality"
ElseIf m.Bitrate >= 320 Then
LBL_DEFINITION_INFO.Text = "High Quality"
ElseIf m.Bitrate >= 190 Then
LBL_DEFINITION_INFO.Text = "Medium Quality"
@@ -38,8 +69,8 @@ Namespace API.YouTube.Controls
LBL_DEFINITION_INFO.Text = "Low Quality"
End If
LBL_DEFINITION.Text = $"{m.Bitrate}k"
LBL_CODECS.Text = $"{m.Extension} {d} {m.Codec} {d} {m.Bitrate}k"
If Not m.ID.IsEmptyString AndAlso m.ID.StringToLower.Contains(DRC) Then LBL_CODECS.Text &= $" {d} DRC"
'LBL_CODECS.Text = $"{m.Extension} {d} {m.Codec} {d} {m.Bitrate}k{If(m.LanguageCaption.IsEmptyString, String.Empty, $" {d} {m.LanguageCaption}")}"
'If Not m.ID.IsEmptyString AndAlso m.ID.StringToLower.Contains(DRC) Then LBL_CODECS.Text &= $" {d} DRC"
Else
If m.Height >= 1440 Then
LBL_DEFINITION_INFO.Text = "Ultra High Definition"
@@ -53,11 +84,13 @@ Namespace API.YouTube.Controls
LBL_DEFINITION_INFO.Text = "Low Definition"
End If
LBL_DEFINITION.Text = $"{m.Height}p"
LBL_CODECS.Text = $"{m.Extension.StringToUpper}{d}{m.Codec.StringToUpper}{d}{m.FPS}fps{d}{m.Bitrate}k"
If Not m.Protocol.IsEmptyString Then LBL_CODECS.Text &= $" ({m.Protocol})"
If Not m.ID.IsEmptyString AndAlso m.ID.StringToLower.Contains(DRC) Then LBL_CODECS.Text &= $"{d}DRC"
If Not SelectedAudio.ID.IsEmptyString Then LBL_CODECS.Text &= $" / {SelectedAudio.Extension}{d}{SelectedAudio.Codec}{d}{SelectedAudio.Bitrate}k"
If Not SelectedAudio.ID.IsEmptyString AndAlso SelectedAudio.ID.StringToLower.Contains(DRC) Then LBL_CODECS.Text &= $"{d}DRC"
'LBL_CODECS.Text = $"{m.Extension.StringToUpper}{d}{m.Codec.StringToUpper}{d}{m.FPS}fps{d}{m.Bitrate}k"
'If Not m.Protocol.IsEmptyString Then LBL_CODECS.Text &= $" ({m.Protocol})"
'If Not m.ID.IsEmptyString AndAlso m.ID.StringToLower.Contains(DRC) Then LBL_CODECS.Text &= $"{d}DRC"
'With SelectedAudio
' If Not .ID.IsEmptyString Then LBL_CODECS.Text &= $" / {If(.LanguageCaption.IsEmptyString, String.Empty, $"{ .LanguageCaption} {d}")}{ .Bitrate}k ({ .Extension}, { .Codec})"
' If Not .ID.IsEmptyString AndAlso .ID.StringToLower.Contains(DRC) Then LBL_CODECS.Text &= $"{d}DRC"
'End With
If MyYouTubeSettings.DefaultVideoHighlightFPS_H > 0 AndAlso m.FPS > MyYouTubeSettings.DefaultVideoHighlightFPS_H Then _
BackColor = MyColor.DeleteBack : ForeColor = MyColor.DeleteFore
@@ -65,6 +98,8 @@ Namespace API.YouTube.Controls
BackColor = MyColor.UpdateBack : ForeColor = MyColor.UpdateFore
End If
GenerateInfoCaption(SelectedAudio)
Dim sv% = m.Size / 1024
If sv >= 1000 Then
LBL_SIZE.Text = AConvert(Of String)(sv / 1024, VideoSizeProvider)
@@ -74,9 +109,36 @@ Namespace API.YouTube.Controls
LBL_SIZE.Text &= " MB"
End If
End Sub
Private Sub GenerateInfoCaption(ByVal SelectedAudio As MediaObject)
Const d$ = StringDelimiter
If ContentType = UMTypes.Audio Then
With MyMedia
LBL_CODECS.Text = $"{ .Extension} {d} { .Codec} {d} { .Bitrate}k{If(.LanguageCaption.IsEmptyString, String.Empty, $" {d} { .LanguageCaption(True)}")}"
If Not .ID.IsEmptyString AndAlso .ID.StringToLower.Contains(DRC) Then LBL_CODECS.Text &= $" {d} DRC"
End With
Else
With MyMedia
LBL_CODECS.Text = $"{ .Extension.StringToUpper}{d}{ .Codec.StringToUpper}{d}{ .FPS}fps{d}{ .Bitrate}k"
If Not .Protocol.IsEmptyString Then LBL_CODECS.Text &= $" ({ .Protocol})"
If Not .ID.IsEmptyString AndAlso .ID.StringToLower.Contains(DRC) Then LBL_CODECS.Text &= $"{d}DRC"
_CodecLength = LBL_CODECS.Text.MeasureTextDefault(LBL_CODECS.Font).Width
End With
With SelectedAudio
If Not .ID.IsEmptyString Then LBL_CODECS.Text &= $" / {If(.LanguageCaption.IsEmptyString, String.Empty, $"{ .LanguageCaption} {d}")}{ .Bitrate}k ({ .Extension}, { .Codec})"
If Not .ID.IsEmptyString AndAlso .ID.StringToLower.Contains(DRC) Then LBL_CODECS.Text &= $"{d}DRC"
End With
End If
End Sub
Private Sub OPT_CHECKED_CheckedChanged(sender As Object, e As EventArgs) Handles OPT_CHECKED.CheckedChanged
RaiseEvent CheckedChanged(Me, e)
End Sub
Private Sub AudioChanged(ByVal Sender As Object, ByVal e As EventArgs)
If ContentType = UMTypes.Video AndAlso Not Sender Is Nothing Then
With DirectCast(Sender, VideoOption)
If .ContentType = UMTypes.Audio And .Checked Then GenerateInfoCaption(.MyMedia)
End With
End If
End Sub
Private Sub Labels_Click(sender As Object, e As EventArgs) Handles LBL_DEFINITION_INFO.Click, LBL_DEFINITION.Click, LBL_CODECS.Click, LBL_SIZE.Click
OPT_CHECKED.Checked = True
End Sub

View File

@@ -20,6 +20,7 @@ Imports UMTypes = SCrawler.Plugin.UserMediaTypes
Imports ADB = PersonalUtilities.Forms.Controls.Base.ActionButton.DefaultButtons
Namespace API.YouTube.Controls
Friend Class VideoOptionsForm : Implements IDesignXMLContainer
Friend Event AudioIndexChanged As EventHandler
#Region "Declarations"
Private MyView As FormView
Private ReadOnly MyFieldsChecker As FieldsChecker
@@ -29,6 +30,7 @@ Namespace API.YouTube.Controls
Private Const ControlsRow As Integer = 7
Private ReadOnly Property CNT_PROCESSOR As TableControlsProcessor
Friend Property MyContainer As YouTubeMediaContainerBase
Private ReadOnly AVControls As List(Of VideoOption)
Private Initialization As Boolean = True
Private ReadOnly InheritsFromContainer As Boolean
Private ReadOnly M3U8Files As List(Of SFile)
@@ -63,6 +65,7 @@ Namespace API.YouTube.Controls
InitializeComponent()
M3U8Files = New List(Of SFile)
MyContainer = Container
AVControls = New List(Of VideoOption)
CNT_PROCESSOR = New TableControlsProcessor(TP_CONTROLS)
Me.InheritsFromContainer = InheritsFromContainer
MyFieldsChecker = New FieldsChecker
@@ -137,6 +140,19 @@ Namespace API.YouTube.Controls
End If
CMB_FORMAT.Enabled = OPT_VIDEO.Checked
With .MediaObjects
Dim disableOpts As Boolean = False
If .Count = 0 Or .Count = 1 Then
disableOpts = True
ElseIf .Exists(Function(mm) mm.Type = UMTypes.Video Or mm.Type = YouTubeMediaContainerBase.TypeAudioVideo) And
.Exists(Function(mm) mm.Type = UMTypes.Audio) Then
disableOpts = False
Else
disableOpts = True
End If
If disableOpts Then OPT_AUDIO.Enabled = False : OPT_VIDEO.Enabled = False
End With
arr = AvailableVideoFormats
CMB_FORMAT.Items.AddRange(arr)
If InheritsFromContainer Then
@@ -197,6 +213,7 @@ Namespace API.YouTube.Controls
MyView.DisposeIfReady()
MyFieldsChecker.DisposeIfReady()
M3U8Files.Clear()
AVControls.ListClearDispose
End Sub
#End Region
#Region "Refill"
@@ -205,6 +222,7 @@ Namespace API.YouTube.Controls
Dim h% = -1
Dim rh% = IIf(MyContainer.HasElements, 60, 25)
Dim s As New Size(Width, h)
Dim codecW% = 0
Dim CalculateSize As Action(Of Integer) =
Sub(ByVal InitHeight As Integer)
With TP_MAIN.RowStyles(ControlsRow) : .SizeType = SizeType.Absolute : .Height = InitHeight : End With
@@ -217,7 +235,7 @@ Namespace API.YouTube.Controls
Dim __contentType As UMTypes = IIf(OPT_VIDEO.Checked, UMTypes.Video, UMTypes.Audio)
With TP_CONTROLS
If .Controls.Count > 0 Then
For Each cnt As Control In .Controls : cnt.Dispose() : Next
'For Each cnt As Control In .Controls : cnt.Dispose() : Next
.Controls.Clear()
End If
.RowStyles.Clear()
@@ -226,14 +244,29 @@ Namespace API.YouTube.Controls
With MyContainer
Dim audio As MediaObject = Nothing
If __contentType = UMTypes.Video Then audio = .SelectedAudio
Dim data As IEnumerable(Of Control)
Dim data As IEnumerable(Of Control) = Nothing
If .HasElements Then
data = .Elements.Select(Function(ee) New MediaItem(ee, True) With {.Dock = DockStyle.Fill, .Checked = ee.Checked, .UseCookies = UseCookies})
Else
data = (From m As MediaObject In .Self.MediaObjects
Where m.Type = __contentType
Select New VideoOption(m, audio) With {.Dock = DockStyle.Fill, .Checked = m.Index = MyContainer.SelectedVideoIndex})
If AVControls.Count = 0 Then
AVControls.AddRange(From m As MediaObject In .Self.MediaObjects
Where m.Type = UMTypes.Audio Or m.Type = UMTypes.Video Or m.Type = YouTubeMediaContainerBase.TypeAudioVideo
Select New VideoOption(m, audio) With {
.Dock = DockStyle.Fill,
.Checked = m.Index = If(m.Type = UMTypes.Audio, MyContainer.SelectedAudioIndex, MyContainer.SelectedVideoIndex)
})
If AVControls.Count > 0 Then
AVControls.ForEach(Sub(ByVal av As VideoOption)
AddHandler av.CheckedChanged, AddressOf VideoOption_CheckedChanged
av.SetAudioChangingHandler(Me)
End Sub)
End If
End If
'data = (From m As MediaObject In .Self.MediaObjects
' Where m.Type = __contentType Or (__contentType = UMTypes.Video And m.Type = YouTubeMediaContainerBase.TypeAudioVideo)
' Select New VideoOption(m, audio) With {.Dock = DockStyle.Fill, .Checked = m.Index = MyContainer.SelectedVideoIndex})
If AVControls.Count > 0 Then data = AVControls.Where(Function(av) av.ContentType = __contentType)
End If
If data.ListExists Then
@@ -299,6 +332,16 @@ Namespace API.YouTube.Controls
End With
End If
If Not .HasElements Then
codecW = AVControls.Max(Function(av) av.CodecLength)
Dim baseW% = DirectCast(TP_CONTROLS.Controls(0), VideoOption).CodecLengthBase
If baseW + codecW + 12 + 30 > Width Then
s.Width += Math.Abs((Size.Width - baseW - codecW - 12 - 30))
'MinimumSize = s
'Size = s
End If
End If
With TP_CONTROLS
.PerformLayout()
.Select()
@@ -319,6 +362,16 @@ Namespace API.YouTube.Controls
Private Sub MediaItem_CheckedChanged(ByVal Sender As MediaItem, ByVal Container As IYouTubeMediaContainer)
ControlInvokeFast(TP_CONTROLS, Sub() Container.Checked = Sender.Checked, EDP.None)
End Sub
Private Sub VideoOption_CheckedChanged(ByVal Sender As Object, ByVal e As EventArgs)
If Not Sender Is Nothing Then
With DirectCast(Sender, VideoOption)
If .MyMedia.Type = UMTypes.Audio And .Checked Then
MyContainer.SelectedAudioIndex = .MyMedia.Index
RaiseEvent AudioIndexChanged(Sender, e)
End If
End With
End If
End Sub
Private Sub MediaItem_BeforeOpenEditor(ByVal Sender As MediaItem, ByVal Container As IYouTubeMediaContainer)
MediaItem_BeforeOpenEditorImpl(Sender, Container, False)
End Sub

View File

@@ -56,7 +56,9 @@ Namespace API.YouTube
Friend ReadOnly TimeToStringProvider As IFormatProvider = New TimeToStringConverter
Friend ReadOnly TimeToStringProviderH As IFormatProvider = New TimeToStringConverter(True)
Friend ReadOnly TitleHtmlConverter As Func(Of String, String) = Function(Input) Input.StringRemoveWinForbiddenSymbols().StringTrim()
Friend ReadOnly MediaObjParseLang As RParams = RParams.DM("(?i)^(.+?)(?:\s*-\s*( .+?))?(?=\s*(?:,\s*)?(?:low|medium|high|DRC)\b|$)", 0, EDP.ReturnValue)
Friend ReadOnly ProgressProvider As IMyProgressNumberProvider = MyProgressNumberProvider.Percentage
Friend ReadOnly DownloadProgressPattern As RParams = RParams.DMS("\[download\]\s*([\d\.,]+)", 1, EDP.ReturnValue)
Public ReadOnly TrueUrlRegEx As RParams = RParams.DM(Base.YouTubeFunctions.TrueUrlPattern, 0, EDP.ReturnValue)
Friend ReadOnly MusicUrlApply As RParams = RParams.DMS("https://([w\.]*)youtube.com.+", 1, RegexReturn.Replace, EDP.ReturnValue,
CType(Function(input$) "music.", Func(Of String, String)), String.Empty)
@@ -78,6 +80,16 @@ Namespace API.YouTube
Return f
End If
End Function
Public Function CreateYtdlpProgressHandler(ByVal Progress As MyProgress, ByVal Token As Threading.CancellationToken, ByVal Batch As BatchExecutor,
Optional ByVal ValCalc As Func(Of Double, Double) = Nothing) As DataReceivedEventHandler
Return Sub(ByVal Sender As Object, ByVal e As DataReceivedEventArgs)
If Not e.Data.IsEmptyString Then
Dim v# = AConvert(Of Double)(RegexReplace(e.Data, DownloadProgressPattern), NumberProvider, -1)
If v >= 0 Then v = If(ValCalc Is Nothing, v, ValCalc.Invoke(v)) : Progress.Value = v : Progress.Perform(0)
If Token.IsCancellationRequested Then Batch.Kill()
End If
End Sub
End Function
Private Class TimeToStringConverter : Implements ICustomProvider
Private ReadOnly _Provider As New ADateTime("mm\:ss") With {.TimeParseMode = ADateTime.TimeModes.TimeSpan}
Private ReadOnly _ProviderWithHours As New ADateTime("h\:mm\:ss") With {.TimeParseMode = ADateTime.TimeModes.TimeSpan}

View File

@@ -13,7 +13,7 @@ Imports System.Runtime.InteropServices
<Assembly: AssemblyDescription("YouTube plugin environment")>
<Assembly: AssemblyCompany("AndyProgram")>
<Assembly: AssemblyProduct("SCrawler.YouTube")>
<Assembly: AssemblyCopyright("Copyright © 2025")>
<Assembly: AssemblyCopyright("Copyright © 2027")>
<Assembly: AssemblyTrademark("AndyProgram")>
<Assembly: ComVisible(False)>
@@ -32,6 +32,6 @@ Imports System.Runtime.InteropServices
' by using the '*' as shown below:
' <Assembly: AssemblyVersion("1.0.*")>
<Assembly: AssemblyVersion("2025.8.30.0")>
<Assembly: AssemblyFileVersion("2025.8.30.0")>
<Assembly: AssemblyVersion("2026.10.26.0")>
<Assembly: AssemblyFileVersion("2026.10.26.0")>
<Assembly: NeutralResourcesLanguage("en")>

View File

@@ -827,6 +827,7 @@ Namespace API.YouTube.Objects
subs = ListAddList(Nothing, Subtitles.Select(Function(s, i) If(SubtitlesSelectedIndexes.Contains(i), s.FullID, String.Empty)),
LAP.NotContainsOnly, EDP.ReturnValue).ListToString(",")
subs = $"--write-subs --write-auto-subs --sub-format {OutputSubtitlesFormat.StringToLower} --sub-langs ""{subs}"" --convert-subs {OutputSubtitlesFormat.StringToLower}"
If MyYouTubeSettings.DefaultSubtitlesEmbed Then subs = $"--write-auto-sub --embed-subs {subs}"
End If
If Not cmd.IsEmptyString Then
'2023.3.4 -> 2023.7.6
@@ -950,7 +951,6 @@ Namespace API.YouTube.Objects
Return String.Format(m3u8DataRow, CInt(.Duration.TotalSeconds), fName, __f)
End With
End Function
Private ReadOnly DownloadProgressPattern As RParams = RParams.DMS("\[download\]\s*([\d\.,]+)", 1, EDP.ReturnValue)
Public Property Progress As MyProgress Implements IYouTubeMediaContainer.Progress
Private Property IDownloadableMedia_Progress As Object Implements IDownloadableMedia.Progress
Get
@@ -1190,13 +1190,7 @@ Namespace API.YouTube.Objects
If MediaState = UMStates.Downloaded Or Not Checked Then Exit Sub
RaiseEvent FileDownloadStarted(Me, Nothing)
Using batch As New BatchExecutor(True) With {.Encoding = 65001}
Dim h As DataReceivedEventHandler = Sub(ByVal Sender As Object, ByVal e As DataReceivedEventArgs)
If Not e.Data.IsEmptyString Then
Dim v# = AConvert(Of Double)(RegexReplace(e.Data, DownloadProgressPattern), NumberProvider, -1)
If v >= 0 Then Progress.Value = v : Progress.Perform(0)
If Token.IsCancellationRequested Then batch.Kill()
End If
End Sub
Dim h As DataReceivedEventHandler = CreateYtdlpProgressHandler(Progress, Token, batch)
With batch
Dim prExists As Boolean = Not Progress Is Nothing
If prExists Then
@@ -1458,8 +1452,10 @@ Namespace API.YouTube.Objects
Const trimCommand$ = "ffmpeg -i ""{0}"" -ss {1} -to {2} -c:v copy -c:a copy ""{3}"""
Dim trimFirstFile As SFile = Nothing
Dim trimFirstAdded As Boolean = False
Dim processTrim As Action(Of TrimOption, SFile) =
Sub(ByVal opt As TrimOption, ByVal pFile As SFile)
Dim trimSingleReplace As Boolean = TrimOptions.Count = 1 And TrimDeleteOriginalFile
Dim audioReplace As New Dictionary(Of SFile, SFile)
Dim processTrim As Action(Of TrimOption, SFile, Boolean) =
Sub(ByVal opt As TrimOption, ByVal pFile As SFile, ByVal isAudio As Boolean)
Dim fNew As SFile = pFile
fNew.Name &= $"_{opt.Name}"
If TrimSeparateFolder Then fNew = $"{fNew.PathNoSeparator}\{MyYouTubeSettings.TrimSeparateFolderName.Value.IfNullOrEmpty(YouTubeSettings.TrimSeparateFolderNameDefault)}\{fNew.File}" : fNew.Exists(SFO.Path)
@@ -1471,22 +1467,46 @@ Namespace API.YouTube.Objects
fNew))
If fNew.Exists Then
If trimFirstFile.IsEmptyString Then trimFirstFile = fNew
AddFile(fNew)
If Not trimSingleReplace Then AddFile(fNew)
If isAudio And trimSingleReplace And Not audioReplace.ContainsKey(pFile) Then audioReplace.Add(pFile, fNew)
If format = mp3 And MyYouTubeSettings.DefaultAudioEmbedThumbnail_ExtractedFiles Then _
embedThumbTo.Invoke(fNew) : mp3ThumbEmbedded = True
If (TrimAddTrimmedFilesToM3U8 Or (TrimDeleteOriginalFile And Not trimFirstAdded)) AndAlso
If Not trimSingleReplace AndAlso
(TrimAddTrimmedFilesToM3U8 Or (TrimDeleteOriginalFile And Not trimFirstAdded)) AndAlso
(M3U8_PlaylistFiles.ListExists OrElse
(format = mp3 AndAlso MyYouTubeSettings.VideoPlaylist_AddExtractedMP3.Value)) Then _
M3U8_Append(fNew) : trimFirstAdded = True
End If
End Sub
For Each tr As TrimOption In TrimOptions
processTrim(tr, File)
processTrim(tr, File, False)
If audioFiles.Count > 0 Then
For Each f In audioFiles : processTrim(tr, f) : Next
For Each f In audioFiles : processTrim(tr, f, True) : Next
End If
Next
If TrimDeleteOriginalFile Then File.Delete() : File = trimFirstFile
If TrimDeleteOriginalFile Then
Dim silentEDP As New ErrorsDescriber(EDP.ReturnValue)
File.Delete(,, silentEDP)
If trimSingleReplace Then
File = SFile.Rename(trimFirstFile, File,, New ErrorsDescriber(False, False, False, trimFirstFile))
If audioReplace.Count > 0 Then
For Each kvf As KeyValuePair(Of SFile, SFile) In audioReplace
If kvf.Key.Exists And kvf.Value.Exists Then
kvf.Key.Delete(,, silentEDP)
SFile.Rename(kvf.Value, kvf.Key,, silentEDP)
End If
Next
audioReplace.Clear()
End If
Else
File = trimFirstFile
If audioFiles.Count > 0 Then
For Each f In audioFiles
If Not f = File Then f.Delete(,, silentEDP)
Next
End If
End If
End If
End If
End If
@@ -1671,6 +1691,7 @@ Namespace API.YouTube.Objects
#End Region
#Region "Parse"
Friend Const DRC As String = "drc"
Friend Const TypeAudioVideo As UMTypes = UMTypes.Audio + UMTypes.Video
Public Overridable Function Parse(ByVal Container As EContainer, ByVal Path As SFile, ByVal IsMusic As Boolean,
Optional ByVal Token As CancellationToken = Nothing, Optional ByVal Progress As IMyProgress = Nothing) As Boolean Implements IYouTubeMediaContainer.Parse
Try
@@ -1716,12 +1737,20 @@ Namespace API.YouTube.Objects
If Not tmpPls.IsEmptyString Then PlaylistTitle = tmpPls
End If
Dim tmpTitle$
UserID = .Value("uploader_id")
UserTitle = TitleHtmlConverter.Invoke(.Value("uploader"))
If Not UserTitle.IsEmptyString Then
Dim tmpTitle$ = UserTitle.Replace("Topic", String.Empty).StringTrimEnd(" ", "-")
tmpTitle = UserTitle.Replace("Topic", String.Empty).StringTrimEnd(" ", "-")
If Not tmpTitle.IsEmptyString Then UserTitle = tmpTitle
End If
If MyYouTubeSettings.ParseLongUserTitle Or UserTitle.IsEmptyString Then
tmpTitle = TitleHtmlConverter.Invoke(.Value("artist"))
If Not tmpTitle.IsEmptyString Then
If Not UserTitle.IsEmptyString AndAlso Not tmpTitle.Contains(UserTitle) Then tmpTitle = $"{UserTitle}, {tmpTitle}"
UserTitle = ListAddList(Nothing, tmpTitle.Split(","), CType(Function(v$) v.StringTrim, Func(Of Object, Object)), EDP.ReturnValue).ListToString(" & ").IfNullOrEmpty(UserTitle)
End If
End If
Dim ext$ = IIf(IsMusic,
MyYouTubeSettings.DefaultAudioCodecMusic.Value.StringToLower,
@@ -1815,7 +1844,6 @@ Namespace API.YouTube.Objects
Return _Exists
End Function
Protected Sub ParseFormats(ByVal e As EContainer)
Const av As UMTypes = UMTypes.Audio + UMTypes.Video
If If(e({"formats"})?.Count, 0) > 0 Then
Dim obj As MediaObject
Dim nValue#
@@ -1838,6 +1866,12 @@ Namespace API.YouTube.Objects
obj.FPS = AConvert(Of Double)(ee.Value("fps"), NumberProvider, -1)
obj.Bitrate = AConvert(Of Double)(ee.Value("tbr"), NumberProvider, -1)
obj.Protocol = ee.Value("protocol")
obj.FormatNote = ee.Value("format_note")
If Not obj.FormatNote.IsEmptyString Then
obj.FormatNoteClean = RegexReplace(obj.FormatNote, MediaObjParseLang)
If Not obj.FormatNoteClean.IsEmptyString Then obj.FormatNoteClean = obj.FormatNoteClean.StringTrimEnd({CChar(" "), CChar("-"), CChar(",")})
End If
obj.Language = ee.Value("language")
If Not obj.Protocol.IsEmptyString Then obj.Protocol = obj.Protocol.Split("_").FirstOrDefault
nValue = AConvert(Of Double)(ee.Value("filesize"), NumberProvider, -1)
If nValue > 0 Then obj.Size = (nValue / 1024).RoundVal(2)
@@ -1852,30 +1886,36 @@ Namespace API.YouTube.Objects
If validCodecValue(ee.Value("vcodec")) Then
obj.Type = UMTypes.Video
obj.Codec = sValue.Split(".").First
If validCodecValue(ee.Value("acodec")) Then obj.Type = av
If validCodecValue(ee.Value("acodec")) Then obj.Type = TypeAudioVideo
ElseIf validCodecValue(ee.Value("acodec")) Then
obj.Type = UMTypes.Audio
obj.Codec = sValue.Split(".").First
Else
Dim fd As Boolean = False
sValue = ee.Value("format_note")
If Not sValue.IsEmptyString Then
With ListAddList(Nothing, sValue.Split(","), CType(Function(v) CStr(v).StringToLower.StringTrim, Func(Of Object, Object)), EDP.ReturnValue)
If .ListContains({"high", "low"}) Then
If Not obj.FormatQuality.IsEmptyString Or ee.Value("resolution") = "audio only" Then
obj.Type = UMTypes.Audio
obj.Codec = ee.Value("ext")
If obj.Protocol.StringToLower.StartsWith("m3u8") Then obj.Protocol = "m3u8"
If obj.Bitrate <= 0 Then obj.Bitrate = IIf(.Contains("high"), 129, 53)
If obj.Bitrate <= 0 Then obj.Bitrate = IIf(obj.FormatQuality = "high", 129, 53)
If obj.Size <= 0 Then obj.Size = 1
fd = True
End If
End With
End If
If Not fd Then Continue For
End If
MediaObjects.Add(obj)
Next
MediaObjects.RemoveAll(Function(m) (m.Type = UMTypes.Video And (m.Width <= 0 Or m.Height <= 0)) Or m.URL.IsEmptyString)
With MyYouTubeSettings
If .DefaultAudioLanguage_ExcludeAI Or .DefaultAudioLanguage_ExcludeNonDefault Then
If .DefaultAudioLanguage_ExcludeAI.Value AndAlso MediaObjects.LongCount(Function(m) m.Type = UMTypes.Audio And Not m.IsAI) > 0 Then _
MediaObjects.RemoveAll(Function(m) m.Type = UMTypes.Audio And m.IsAI)
If MediaObjects.Count > 0 AndAlso .DefaultAudioLanguage_ExcludeNonDefault.Value AndAlso
MediaObjects.LongCount(Function(m) m.Type = UMTypes.Audio And m.IsDefaultOrOriginal) > 0 Then _
MediaObjects.RemoveAll(Function(m) m.Type = UMTypes.Audio And Not m.IsDefaultOrOriginal)
End If
End With
Dim DupRemover As Action(Of UMTypes) =
Sub(ByVal t As UMTypes)
Const webm$ = "webm"

View File

@@ -13,7 +13,7 @@ Imports System.Runtime.InteropServices
<Assembly: AssemblyDescription("SCrawler YouTube downloader")>
<Assembly: AssemblyCompany("AndyProgram")>
<Assembly: AssemblyProduct("SCrawler.YouTubeDownloader")>
<Assembly: AssemblyCopyright("Copyright © 2025")>
<Assembly: AssemblyCopyright("Copyright © 2027")>
<Assembly: AssemblyTrademark("AndyProgram")>
<Assembly: ComVisible(False)>
@@ -32,6 +32,6 @@ Imports System.Runtime.InteropServices
' by using the '*' as shown below:
' <Assembly: AssemblyVersion("1.0.*")>
<Assembly: AssemblyVersion("2025.8.30.0")>
<Assembly: AssemblyFileVersion("2025.8.30.0")>
<Assembly: AssemblyVersion("2026.10.26.0")>
<Assembly: AssemblyFileVersion("2026.10.26.0")>
<Assembly: NeutralResourcesLanguage("en")>

View File

@@ -57,6 +57,17 @@ dotnet_naming_rule.constant_fields_should_be_pascal_case.style = pascal_case_
dotnet_naming_symbols.constant_fields.applicable_kinds = field
dotnet_naming_symbols.constant_fields.applicable_accessibilities = *
dotnet_naming_symbols.constant_fields.required_modifiers = const
dotnet_style_operator_placement_when_wrapping = beginning_of_line
tab_width = 4
end_of_line = crlf
dotnet_style_prefer_simplified_boolean_expressions = true:suggestion
dotnet_style_prefer_compound_assignment = true:suggestion
dotnet_style_prefer_simplified_interpolation = true:suggestion
dotnet_style_prefer_collection_expression = when_types_loosely_match:suggestion
dotnet_style_namespace_match_folder = true:suggestion
dotnet_style_allow_multiple_blank_lines_experimental = true:silent
dotnet_style_allow_statement_immediately_after_block_experimental = true:silent
dotnet_code_quality_unused_parameters = all:suggestion
###############################
# C# Coding Conventions #
###############################

View File

@@ -11,6 +11,9 @@ Imports PersonalUtilities.Forms
Imports PersonalUtilities.Functions.RegularExpressions
Namespace API.Base
Friend Module Declarations
Friend Interface IThumbList
Property Thumbs As List(Of String)
End Interface
Friend Const UserLabelName As String = "User"
Friend Const SearchRequestLabelName As String = "Search request"
Friend ReadOnly LNC As New ListAddParams(LAP.NotContainsOnly)

View File

@@ -11,6 +11,10 @@ Imports DN = SCrawler.API.Base.DeclaredNames
Namespace API.Base
Friend Class EditorExchangeOptionsBase
Friend Overridable Property SiteKey As String
<PSetting(Address:=SettingAddress.User, Caption:="Profile exists")>
Friend Overridable Property UserExists As Boolean = True
<PSetting(Address:=SettingAddress.User, Caption:="Profile suspended")>
Friend Overridable Property UserSuspended As Boolean = False
<PSetting(Address:=SettingAddress.User, Caption:=DN.UserNameChangeCaption, ToolTip:=DN.UserNameChangeToolTip)>
Friend Overridable Property UserName As String = String.Empty
<PSetting(Address:=SettingAddress.User, Caption:=DN.DownloadTextCaption, ToolTip:=DN.DownloadTextTip)>
@@ -20,6 +24,8 @@ Namespace API.Base
<PSetting(Address:=SettingAddress.User, Caption:=DN.DownloadTextSpecialFolderCaption, ToolTip:=DN.DownloadTextSpecialFolderTip)>
Friend Overridable Property DownloadTextSpecialFolder As Boolean = False
Friend Sub New(ByVal u As UserDataBase)
UserExists = u.UserExists
UserSuspended = u.UserSuspended
UserName = u.NameTrue(True)
DownloadText = u.DownloadText
DownloadTextPosts = u.DownloadTextPosts
@@ -35,6 +41,8 @@ Namespace API.Base
Protected _ApplyBase_Name As Boolean = True
Protected _ApplyBase_Text As Boolean = True
Friend Sub ApplyBase(ByRef u As UserDataBase)
u.UserExists = UserExists
u.UserSuspended = UserSuspended
If _ApplyBase_Name Then u.NameTrue = UserName
If _ApplyBase_Text Then
u.DownloadText = DownloadText
@@ -42,5 +50,9 @@ Namespace API.Base
u.DownloadTextSpecialFolder = DownloadTextSpecialFolder
End If
End Sub
Friend Overridable Sub Apply(ByRef u As UserDataBase)
ApplyBase(u)
If TypeOf u Is IPSite And TypeOf Me Is IPSite Then DirectCast(u, IPSite).QueryString = DirectCast(Me, IPSite).QueryString
End Sub
End Class
End Namespace

View File

@@ -31,10 +31,6 @@ Namespace API.Base
MyBase.New(s)
DisableBase()
End Sub
Friend Overridable Sub Apply(ByRef u As IPSite)
ApplyBase(u)
u.QueryString = QueryString
End Sub
Protected Overridable Sub DisableBase()
_ApplyBase_Name = False
_ApplyBase_Text = False

View File

@@ -10,10 +10,8 @@ Namespace API.Base.GDL
Friend Class GDLBatch : Inherits TokenBatch
Friend Const UrlLibStart As String = "[urllib3.connectionpool][debug]"
Friend Const UrlTextStart As String = UrlLibStart & " https"
Friend Sub New(ByVal _Token As Threading.CancellationToken)
MyBase.New(_Token)
MainProcessName = "gallery-dl"
ChangeDirectory(Settings.GalleryDLFile.File)
Friend Sub New(ByVal _Token As Threading.CancellationToken, Optional ByVal __MainProcessName As String = Nothing, Optional ByVal WorkingDir As SFile = Nothing)
MyBase.New(_Token, __MainProcessName.IfNullOrEmpty(Settings.GalleryDLFile.File.Name), WorkingDir.IfNullOrEmpty(Settings.GalleryDLFile.File))
End Sub
Protected Overrides Async Sub OutputDataReceiver(ByVal Sender As Object, ByVal e As DataReceivedEventArgs)
If Not ProcessKilled Then

View File

@@ -53,7 +53,12 @@ Namespace API.Base
End Get
End Property
Private Property Logger As ILogProvider = LogConnector Implements ISiteSettings.Logger
Friend Overridable ReadOnly Property Responser As Responser
Protected _Responser As Responser = Nothing
Friend ReadOnly Property Responser As Responser
Get
Return _Responser
End Get
End Property
Private _UserOptionsExists As Boolean = False
Private _UserOptionsType As Type = Nothing
Protected Overridable Function UserOptionsValid(ByVal Options As Object) As Boolean
@@ -122,6 +127,11 @@ Namespace API.Base
_CookiesNetscapeFile.Name &= "_Cookies_Netscape"
_CookiesNetscapeFile.Extension = "txt"
End Sub
Protected Overridable Sub ChangeResponserOnInit()
End Sub
Friend Overridable Function GetCookieKeeperInstance() As CookieKeeper
Return New CookieKeeper
End Function
#End Region
#Region "GetInstance"
Friend MustOverride Function GetInstance(ByVal What As Download) As IPluginContentProvider Implements ISiteSettings.GetInstance
@@ -131,7 +141,8 @@ Namespace API.Base
Site = SiteName
_Icon = __Icon
_Image = __Image
Responser = New Responser With {.DeclaredError = EDP.ThrowException}
_Responser = New Responser With {.DeclaredError = EDP.ThrowException}
ChangeResponserOnInit()
SettingsVersion = New PropertyValue(0)
DownloadText = New PropertyValue(False)
DownloadTextPosts = New PropertyValue(False)

View File

@@ -58,6 +58,11 @@ Namespace API.Base
Return Type = Types.Audio Or Type = Types.AudioPre
End Get
End Property
Friend ReadOnly Property IsPhotoType As Boolean
Get
Return Type = Types.Picture Or Type = Types.GIF
End Get
End Property
Friend URL_BASE As String
Friend URL As String
Friend MD5 As String

View File

@@ -13,10 +13,21 @@ Namespace API.Base
Friend Property TempPostsList As List(Of String)
Protected ReadOnly Token As CancellationToken
Friend Property DebugMode As Boolean = False
Friend Sub New(ByVal _Token As CancellationToken)
Friend Overridable Property MyWorkingDirectory As SFile = Nothing
Friend Sub New(ByVal _Token As CancellationToken, Optional ByVal _MainProcessName As String = Nothing, Optional ByVal WorkingDir As SFile = Nothing)
MyBase.New(True)
Token = _Token
MainProcessName = _MainProcessName
If Not WorkingDir.IsEmptyString Then ChangeDirectory(WorkingDir)
End Sub
Public Overrides Sub ChangeDirectory(ByVal Directory As SFile)
MyBase.ChangeDirectory(Directory)
If Not Directory.IsEmptyString Then MyWorkingDirectory = Directory
End Sub
Protected Overrides Function Internal_Execute(ByVal Commands As IEnumerable(Of String), ByVal e As ErrorsDescriber) As Boolean
If Not Encoding.HasValue Then Encoding = UnicodeEncoding
Return MyBase.Internal_Execute(Commands, e)
End Function
Public Overrides Sub Create()
If TempPostsList Is Nothing Then TempPostsList = New List(Of String)
MyBase.Create()

View File

@@ -28,6 +28,7 @@ Namespace API.Base
Friend MustInherit Class UserDataBase : Implements IUserData, IPluginContentProvider, IThrower
Friend Const UserFileAppender As String = "User"
Friend Const PostTextSpecialFolderDefault As String = "txt"
Friend Const PostTextTEXTSpecialFolderDefault As String = "Text"
#Region "Events"
Private ReadOnly UserUpdatedEventHandlers As List(Of IUserData.UserUpdatedEventHandler)
Friend Custom Event UserUpdated As IUserData.UserUpdatedEventHandler Implements IUserData.UserUpdated
@@ -183,8 +184,6 @@ Namespace API.Base
#Region "Additional names"
Protected Const Name_SiteMode As String = "SiteMode"
Protected Const Name_TrueName As String = "TrueName"
'TODELETE Name_TrueName2
<Obsolete> Protected Const Name_TrueName2 As String = "NameTrue"
Protected Const Name_Arguments As String = "Arguments"
#End Region
#End Region
@@ -360,8 +359,8 @@ Namespace API.Base
Me._UserSiteName = _UserSiteName
End Set
End Property
Protected Sub UserSiteNameUpdate(ByVal NewName As String)
If Not NewName.IsEmptyString And (UserSiteName.IsEmptyString Or Settings.UpdateUserSiteNameEveryTime) Then UserSiteName = NewName
Protected Sub UserSiteNameUpdate(ByVal NewName As String, Optional ByVal Force As Boolean = False)
If Not NewName.IsEmptyString And (UserSiteName.IsEmptyString Or Settings.UpdateUserSiteNameEveryTime Or Force) Then UserSiteName = NewName
End Sub
Friend ReadOnly Property UserModel As UsageModel Implements IUserData.UserModel
Get
@@ -977,9 +976,6 @@ BlockNullPicture:
Using x As New XmlFile(MyFileSettings) With {.XmlReadOnly = True}
If User.Name.IsEmptyString Then User.Name = x.Value(Name_UserName)
_NameTrue = x.Value(Name_TrueName)
#Disable Warning BC40008
If _NameTrue.IsEmptyString AndAlso x.Contains(Name_TrueName2) Then _NameTrue = x.Value(Name_TrueName2)
#Enable Warning
UserExists = x.Value(Name_UserExists).FromXML(Of Boolean)(True)
UserSuspended = x.Value(Name_UserSuspended).FromXML(Of Boolean)(False)
ID = x.Value(Name_UserID)
@@ -1030,7 +1026,7 @@ BlockNullPicture:
End Try
End Sub
Private Sub UpdateUserInformation_Ex()
If _ForceSaveUserInfoOnException Then UpdateUserInformation()
If _ForceSaveUserInfo Then UpdateUserInformation()
End Sub
Friend Overridable Overloads Sub UpdateUserInformation() Implements IUserData.UpdateUserInformation
UpdateUserInformation(False)
@@ -1207,7 +1203,6 @@ BlockNullPicture:
Protected UseClientTokens As Boolean = False
Protected _ForceSaveUserData As Boolean = False
Protected _ForceSaveUserInfo As Boolean = False
Protected _ForceSaveUserInfoOnException As Boolean = False
Private _DownloadInProgress As Boolean = False
Private _EnvirUserExists As Boolean
Private _EnvirUserSuspended As Boolean
@@ -1225,16 +1220,15 @@ BlockNullPicture:
_DownloadInProgress = True
_DescriptionChecked = False
_DescriptionEveryTime = Settings.UpdateUserDescriptionEveryTime
_ForceSaveUserData = False
_ForceSaveUserInfo = False
_ForceSaveUserInfoOnException = False
_EnvirUserExists = UserExists
_EnvirUserSuspended = UserSuspended
_EnvirCreatedByChannel = CreatedByChannel
_EnvirChanged = False
_EnvirInvokeUserUpdated = False
UserExists = True
UserSuspended = False
_EnvirCreatedByChannel = CreatedByChannel
_ForceSaveUserData = False
_ForceSaveUserInfo = False
_EnvirChanged = False
_EnvirInvokeUserUpdated = False
DownloadedPictures(False) = 0
DownloadedVideos(False) = 0
_PictureExists = Settings.ViewModeIsPicture AndAlso Not GetPicture(Of Image)(False) Is Nothing
@@ -1242,10 +1236,10 @@ BlockNullPicture:
Private Sub EnvirChanged(ByVal NewValue As Object, <CallerMemberName> Optional ByVal Caller As String = Nothing)
If _DownloadInProgress Then
Select Case Caller
Case NameOf(UserExists) : If Not _EnvirUserExists = CBool(NewValue) Then _EnvirChanged = True : _EnvirInvokeUserUpdated = True
Case NameOf(UserSuspended) : If Not _EnvirUserSuspended = CBool(NewValue) Then _EnvirChanged = True : _EnvirInvokeUserUpdated = True
Case NameOf(NameTrue) : _EnvirChanged = True : _ForceSaveUserInfo = True : _ForceSaveUserInfoOnException = True
Case NameOf(ID) : _EnvirChanged = True : _ForceSaveUserInfo = True : _ForceSaveUserInfoOnException = True
Case NameOf(UserExists) : If Not _EnvirUserExists = CBool(NewValue) Then _EnvirChanged = True : _EnvirInvokeUserUpdated = True : _ForceSaveUserInfo = True
Case NameOf(UserSuspended) : If Not _EnvirUserSuspended = CBool(NewValue) Then _EnvirChanged = True : _EnvirInvokeUserUpdated = True : _ForceSaveUserInfo = True
Case NameOf(NameTrue) : _EnvirChanged = True : _ForceSaveUserInfo = True
Case NameOf(ID) : _EnvirChanged = True : _ForceSaveUserInfo = True
Case Else : _EnvirChanged = True
End Select
End If
@@ -1439,6 +1433,18 @@ BlockNullPicture:
Cache.Validate()
Return Cache
End Function
#Region "GDL File Names"
Protected GDLFileNameProvider As ANumbers = Nothing
Protected Sub GDLResetFileNameProvider(Optional ByVal GroupSize As Integer? = Nothing)
GDLFileNameProvider = New ANumbers With {
.FormatOptions = ANumbers.Options.FormatNumberGroup + ANumbers.Options.Groups,
.GroupSize = If(GroupSize, 3)
}
End Sub
Protected Function GDLRenameFile(ByVal Input As SFile, ByVal i As Integer) As SFile
Return SFile.Rename(Input, $"{Input.PathWithSeparator}{i.NumToString(GDLFileNameProvider)}.{Input.Extension}",, EDP.ThrowException)
End Function
#End Region
#Region "DownloadSingleObject"
Protected IsSingleObjectDownload As Boolean = False
Friend Overridable Sub DownloadSingleObject(ByVal Data As YouTube.Objects.IYouTubeMediaContainer, ByVal Token As CancellationToken) Implements IUserData.DownloadSingleObject
@@ -1542,6 +1548,12 @@ BlockNullPicture:
''' </summary>
Protected Overridable Sub ReparseMissing(ByVal Token As CancellationToken)
End Sub
Protected Sub ReparseMissing_ClearList(ByRef rList As List(Of Integer))
If rList.Count > 0 Then
For i% = rList.Count - 1 To 0 Step -1 : _ContentList.RemoveAt(rList(i)) : Next
rList.Clear()
End If
End Sub
#End Region
#Region "MD5 support"
Private Const VALIDATE_MD5_ERROR As String = "VALIDATE_MD5_ERROR"
@@ -1718,7 +1730,7 @@ BlockNullPicture:
If _ContentNew.Count > 0 Then
If UseMD5Comparison Then LoadMD5()
MyFile.Exists(SFO.Path)
Dim MissingErrorsAdd As Boolean = Settings.AddMissingErrorsToLog
Dim MissingErrorsAdd As Boolean = Settings.AddMissingToLog And Settings.AddMissingErrorsToLog
Dim MyDir$ = DownloadContentDefault_GetRootDir()
Dim vsf As Boolean = SeparateVideoFolderF
Dim __isVideo As Boolean
@@ -1833,7 +1845,8 @@ BlockNullPicture:
updateDownCount(False)
v.File = DownloadContentDefault_ConvertWebp(ChangeFileNameByProvider(f, v), postProcessWebp)
v.File = ChangeFileNameByProvider(f, v)
v.File = DownloadContentDefault_ConvertWebp(v, postProcessWebp)
v.State = UStates.Downloaded
DownloadContentDefault_PostProcessing(v, f, Token)
If UseMD5Comparison And (v.Type = UTypes.GIF Or v.Type = UTypes.Picture) Then
@@ -1864,8 +1877,13 @@ stxt:
Continue For
End If
End If
If Not fTxt.Path.StartsWith(MyDir) Then fTxt.Path = MyDir
v.PostTextFileSpecialFolder = DownloadTextSpecialFolder
If DownloadTextSpecialFolder Then fTxt.Path = $"{fTxt.Path.StringTrimEnd("\")}\{PostTextSpecialFolderDefault}"
If v.Type = UTypes.Text Then
fTxt.Path = $"{fTxt.Path.StringTrimEnd("\")}\{PostTextTEXTSpecialFolderDefault}"
ElseIf DownloadTextSpecialFolder Then
fTxt.Path = $"{fTxt.Path.StringTrimEnd("\")}\{PostTextSpecialFolderDefault}"
End If
fTxt.Extension = "txt"
v.PostTextFile = TextSaver.SaveTextToFile(v.PostText, fTxt,,, Settings.FeedShowTextPosts_LogErrors_E)
If Not v.PostTextFile.Exists Then Throw New ArgumentNullException("Text", "Error downloading text") With {.HelpLink = 10}
@@ -1933,7 +1951,11 @@ stxt:
End Function
Protected Overridable Sub DownloadContentDefault_PostProcessing(ByRef m As UserMedia, ByVal File As SFile, ByVal Token As CancellationToken)
End Sub
Protected Overridable Function DownloadContentDefault_ConvertWebp(ByVal WebpFile As SFile, ByVal Process As Boolean) As SFile
Protected Overridable Function DownloadContentDefault_ConvertWebp(ByVal m As UserMedia, ByVal Process As Boolean) As SFile
Return DownloadContentDefault_ConvertWebp_Impl(m, Process)
End Function
Protected Overridable Function DownloadContentDefault_ConvertWebp_Impl(ByVal m As UserMedia, ByVal Process As Boolean, Optional ByVal ConvertWebpForce As Boolean = False) As SFile
Dim WebpFile As SFile = m.File
Dim f As SFile = WebpFile
If Process AndAlso f.Exists Then
f.Path = $"{f.PathWithSeparator}Sources"
@@ -1941,7 +1963,7 @@ stxt:
If WebpFile.Copy(f) Then
Dim newFile As SFile = WebpFile
newFile.Extension = UserImage.ExtJpg
f = UserImage.ConvertWebp(f, newFile)
f = UserImage.ConvertWebp(f, newFile, ConvertWebpForce)
If f.Exists Then WebpFile.Delete(SFO.File, SFODelete.DeletePermanently, EDP.ReturnValue)
Else
f = WebpFile
@@ -1949,6 +1971,24 @@ stxt:
End If
Return f
End Function
Protected Function DownloadContentDefault_ConvertWebp_TestImg(ByVal m As UserMedia, ByVal Process As Boolean) As SFile
If m.Type = UTypes.Picture And Settings.DownloadNativeImageFormat Then
Using testImg As New UserImage.ImageRenderer2(m.File, EDP.ReturnValue)
If testImg.IsWebP Then
Dim f As SFile = m.File
If f.Extension.IsEmptyString OrElse Not f.Extension = UserImage.ExtWebp Then
f.Extension = UserImage.ExtWebp
f = SFile.Rename(m.File, f,, EDP.ReturnValue).IfNullOrEmpty(m.File)
End If
m.File = f
Return DownloadContentDefault_ConvertWebp_Impl(m, True).IfNullOrEmpty(f)
End If
End Using
ElseIf Process Then
Return DownloadContentDefault_ConvertWebp_Impl(m, Process)
End If
Return m.File
End Function
Protected Overridable Function DownloadContentDefault_ProcessDownloadException() As Boolean
Return True
End Function
@@ -2312,7 +2352,7 @@ stxt:
ErrorsDescriber.Execute(If(e.Exists, e, New ErrorsDescriber(EDP.SendToLog)), ex, $"{ToStringForLog()}: {Message}")
End Sub
Protected Sub ErrorDownloading(ByVal f As SFile, ByVal URL As String)
If Not f.Exists Then MyMainLOG = $"Error downloading from [{URL}] to [{f}]"
If Not f.Exists Then LogError(Nothing, $"error downloading{vbCr}{URL}{vbCr}{f}")
End Sub
''' <exception cref="ObjectDisposedException"></exception>
Protected Sub ThrowIfDisposed()
@@ -2453,6 +2493,7 @@ stxt:
_TempPostsList.Clear()
_MD5List.Clear()
TokenPersonal = Nothing
GDLFileNameProvider = Nothing
If Not ProgressPre Is Nothing Then ProgressPre.Reset() : ProgressPre.Dispose()
If Not Responser Is Nothing Then Responser.Dispose()
If Not BTT_CONTEXT_DOWN Is Nothing Then BTT_CONTEXT_DOWN.Dispose()

View File

@@ -6,13 +6,20 @@
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports PersonalUtilities.Tools
Imports PersonalUtilities.Forms.Toolbars
Imports SCrawler.API.YouTube
Namespace API.Base.YTDLP
Friend Class YTDLPBatch : Inherits GDL.GDLBatch
Friend Sub New(ByVal _Token As Threading.CancellationToken)
MyBase.New(_Token)
Commands.Clear()
MainProcessName = Settings.YtdlpFile.File.Name '"yt-dlp"
ChangeDirectory(Settings.YtdlpFile.File)
Friend Sub New(ByVal _Token As Threading.CancellationToken, Optional ByVal __MainProcessName As String = Nothing, Optional ByVal WorkingDir As SFile = Nothing)
MyBase.New(_Token, __MainProcessName.IfNullOrEmpty(Settings.YtdlpFile.File.Name), WorkingDir.IfNullOrEmpty(Settings.YtdlpFile.File))
End Sub
Friend Sub SetProgress(ByVal Progress As MyProgress, Optional ByVal ValCalc As Func(Of Double, Double) = Nothing)
If Not Progress Is Nothing Then AddHandler OutputDataReceived, CreateYtdlpProgressHandler(Progress, Token, Me, ValCalc)
End Sub
Friend Sub CreateFileExchanger(ByVal cache As CacheKeeper, Optional ByVal root As SFile = Nothing)
FileExchanger = cache.NewInstance(Of BatchFileExchanger)(root, EDP.ReturnValue)
If Not FileExchanger Is Nothing Then FileExchanger.DeleteCacheOnDispose = True
End Sub
End Class
End Namespace

View File

@@ -0,0 +1,56 @@
' Copyright (C) Andy https://github.com/AAndyProgram
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation, either version 3 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports SCrawler.API.Base
Imports SCrawler.Plugin.Attributes
Namespace API.Bluesky
Friend Class EditorExchangeOptions : Inherits EditorExchangeOptionsBase
Friend Overrides Property SiteKey As String = BlueskySiteKey
<PSetting(NameOf(SiteSettings.DownloadModelMedia), NameOf(MySettings), Address:=SettingAddress.User)>
Friend Overridable Property DownloadModelMedia As Boolean = False
<PSetting(NameOf(SiteSettings.DownloadModelProfile), NameOf(MySettings), Address:=SettingAddress.User)>
Friend Overridable Property DownloadModelProfile As Boolean = False
<PSetting(NameOf(Twitter.SiteSettings.UseMD5Comparison), NameOf(MySettings))>
Friend Property UseMD5Comparison As Boolean = False
<PSetting(Caption:="Remove existing duplicates",
ToolTip:="Existing files will be checked for duplicates and duplicates removed." & vbCr &
"Works only on the first activation 'Use MD5 comparison'.")>
Friend Property RemoveExistingDuplicates As Boolean = False
Private ReadOnly Property MySettings As Object
Friend Sub New(ByVal s As SiteSettings)
MyBase.New(s)
DownloadModelMedia = s.DownloadModelMedia.Value
DownloadModelProfile = s.DownloadModelProfile.Value
MySettings = s
End Sub
Friend Sub New(ByVal u As UserData)
MyBase.New(u)
DownloadModelMedia = u.DownloadModelMedia
DownloadModelProfile = u.DownloadModelProfile
UseMD5Comparison = u.UseMD5Comparison
RemoveExistingDuplicates = u.RemoveExistingDuplicates
MySettings = u.HOST.Source
End Sub
Friend Overrides Sub Apply(ByRef u As UserDataBase)
MyBase.Apply(u)
If Not DownloadModelMedia And Not DownloadModelProfile Then
DownloadModelMedia = True
ElseIf DownloadModelMedia Then
DownloadModelProfile = False
Else
DownloadModelMedia = False
End If
With DirectCast(u, UserData)
.DownloadModelMedia = DownloadModelMedia
.DownloadModelProfile = DownloadModelProfile
.UseMD5Comparison = UseMD5Comparison
.RemoveExistingDuplicates = RemoveExistingDuplicates
End With
End Sub
End Class
End Namespace

View File

@@ -14,7 +14,7 @@ Imports PersonalUtilities.Functions.RegularExpressions
Imports PersonalUtilities.Tools.Web.Clients
Imports PersonalUtilities.Tools.Web.Documents.JSON
Namespace API.Bluesky
<Manifest(BlueskySiteKey), SpecialForm(False)>
<Manifest(BlueskySiteKey), SpecialForm(False), SavedPosts>
Friend Class SiteSettings : Inherits SiteSettingsBase
<PropertyOption(ControlText:="Cookies enabled", ControlToolTip:="If checked, cookies will be used in requests", IsAuth:=True), PXML, PClonable, HiddenControl>
Friend ReadOnly Property CookiesEnabled As PropertyValue
@@ -26,6 +26,10 @@ Namespace API.Bluesky
<PXML> Friend ReadOnly Property TokenUpdateTime As PropertyValue
<PropertyOption(ControlText:="Token update", ControlToolTip:="Token refresh interval (in minutes)." & vbCr & "Default: 120.", IsAuth:=True), PXML, PClonable, HiddenControl>
Friend ReadOnly Property TokenRefreshInterval As PropertyValue
<PropertyOption(ControlText:="Download model 'Media'", ControlToolTip:="Parse the 'Media' block", Category:=DeclaredNames.CAT_UserDefs), PXML, PClonable>
Friend ReadOnly Property DownloadModelMedia As PropertyValue
<PropertyOption(ControlText:="Download model 'Profile'", ControlToolTip:="Parse the 'Posts' block", Category:=DeclaredNames.CAT_UserDefs), PXML, PClonable>
Friend ReadOnly Property DownloadModelProfile As PropertyValue
Friend Sub New(ByVal AccName As String, ByVal Temp As Boolean)
MyBase.New("Bluesky", "bsky.app", AccName, Temp, My.Resources.SiteResources.BlueskyIcon_32, My.Resources.SiteResources.BlueskyPic_32)
@@ -38,11 +42,14 @@ Namespace API.Bluesky
TokenUpdateTime = New PropertyValue(Now.AddYears(-1))
TokenRefreshInterval = New PropertyValue(120)
DownloadModelMedia = New PropertyValue(True)
DownloadModelProfile = New PropertyValue(False)
_AllowUserAgentUpdate = False
UrlPatternUser = "https://bsky.app/profile/{0}"
ImageVideoContains = "bsky.app"
UserRegex = RParams.DMS("bsky.app/profile/([^/\?]+)", 1, EDP.ReturnValue)
UserOptionsType = GetType(EditorExchangeOptionsBase)
UserOptionsType = GetType(EditorExchangeOptions)
End Sub
Protected Overrides Function UserOptionsValid(ByVal Options As Object) As Boolean
Return DirectCast(Options, EditorExchangeOptionsBase).SiteKey = BlueskySiteKey
@@ -96,5 +103,10 @@ Namespace API.Bluesky
_TokenUpdating = False
End Try
End Function
Friend Overrides Function IsMyUser(ByVal UserURL As String) As ExchangeOptions
Dim e As ExchangeOptions = MyBase.IsMyUser(UserURL)
If Not e.UserName.IsEmptyString AndAlso e.UserName.StartsWith("did:") Then e.UserName = e.UserName.Replace(":", "@")
Return e
End Function
End Class
End Namespace

View File

@@ -7,15 +7,22 @@
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports System.Threading
Imports SCrawler.Plugin
Imports SCrawler.API.Base
Imports SCrawler.API.YouTube.Objects
Imports PersonalUtilities.Functions.XML
Imports PersonalUtilities.Functions.RegularExpressions
Imports PersonalUtilities.Tools.Web.Clients
Imports PersonalUtilities.Tools.Web.Documents.JSON
Imports UTypes = SCrawler.API.Base.UserMedia.Types
Imports UStates = SCrawler.API.Base.UserMedia.States
Namespace API.Bluesky
Friend Class UserData : Inherits UserDataBase
#Region "XML names"
Private Const Name_DownloadModelMedia As String = "DownloadModelMedia"
Private Const Name_DownloadModelProfile As String = "DownloadModelProfile"
Private Const Name_ForceParseProfileInfo As String = "ForceParseProfileInfo"
#End Region
#Region "Declarations"
Private ReadOnly Property MySettings As SiteSettings
Get
@@ -28,16 +35,49 @@ Namespace API.Bluesky
End Get
End Property
Private ReadOnly _TmpPosts2 As List(Of String)
Friend Property DownloadModelMedia As Boolean = True
Friend Property DownloadModelProfile As Boolean = False
Private Property ForceParseProfileInfo As Boolean = False
#End Region
#Region "Loader"
Private Sub UpdateUserOptions()
If ID.IsEmptyString AndAlso Not Name.IsEmptyString AndAlso Name.StartsWith("did@") Then
NameTrue = Name.Replace("@", ":")
ID = NameTrue
ForceParseProfileInfo = True
End If
End Sub
Protected Overrides Sub LoadUserInformation_OptionalFields(ByRef Container As XmlFile, ByVal Loading As Boolean)
With Container
If Loading Then
If .Contains(Name_DownloadModelMedia) Then
DownloadModelMedia = .Value(Name_DownloadModelMedia).FromXML(Of Boolean)(True)
DownloadModelProfile = .Value(Name_DownloadModelProfile).FromXML(Of Boolean)(False)
Else
DownloadModelMedia = ParseUserMediaOnly
DownloadModelProfile = Not ParseUserMediaOnly
End If
ForceParseProfileInfo = .Value(Name_ForceParseProfileInfo).FromXML(Of Boolean)(False)
UseMD5Comparison = .Value(Name_UseMD5Comparison).FromXML(Of Boolean)(False)
RemoveExistingDuplicates = .Value(Name_RemoveExistingDuplicates).FromXML(Of Boolean)(False)
Else
If ID.IsEmptyString Then
UpdateUserOptions()
.Value(Name_UserID) = ID
End If
.Add(Name_DownloadModelMedia, DownloadModelMedia.BoolToInteger)
.Add(Name_DownloadModelProfile, DownloadModelProfile.BoolToInteger)
.Add(Name_ForceParseProfileInfo, ForceParseProfileInfo.BoolToInteger)
.Add(Name_UseMD5Comparison, UseMD5Comparison.BoolToInteger)
.Add(Name_RemoveExistingDuplicates, RemoveExistingDuplicates.BoolToInteger)
End If
End With
End Sub
Friend Overrides Function ExchangeOptionsGet() As Object
Return New EditorExchangeOptionsBase(Me) With {.SiteKey = BlueskySiteKey}
Return New EditorExchangeOptions(Me)
End Function
Friend Overrides Sub ExchangeOptionsSet(ByVal Obj As Object)
If Not Obj Is Nothing AndAlso TypeOf Obj Is EditorExchangeOptionsBase AndAlso
DirectCast(Obj, EditorExchangeOptionsBase).SiteKey = BlueskySiteKey Then DirectCast(Obj, EditorExchangeOptionsBase).ApplyBase(Me)
If Not Obj Is Nothing AndAlso TypeOf Obj Is EditorExchangeOptions Then DirectCast(Obj, EditorExchangeOptions).Apply(Me)
End Sub
#End Region
#Region "Initializer"
@@ -64,8 +104,16 @@ Namespace API.Bluesky
#Region "Download"
Private _PostCount As Integer = 0
Protected Overrides Sub DownloadDataF(ByVal Token As CancellationToken)
_CurlProfileTried = False
_TmpPosts2.Clear()
Try
If Not DownloadModelMedia And Not DownloadModelProfile Then
DownloadModelMedia = True
ElseIf DownloadModelMedia Then
DownloadModelProfile = False
Else
DownloadModelMedia = False
End If
If Not CBool(MySettings.CookiesEnabled.Value) Then Responser.Cookies.Clear()
UpdateToken(, True)
_TokenUpdateCount = 0
@@ -79,23 +127,36 @@ Namespace API.Bluesky
Private Overloads Sub DownloadData(ByVal Cursor As String, ByVal Token As CancellationToken)
Dim URL$ = String.Empty
Try
If ID.IsEmptyString Then GetProfileInfo(Token)
If ID.IsEmptyString Then Throw New ArgumentNullException("ID", "ID is null")
If (Not IsSavedPosts And ID.IsEmptyString) Or ForceParseProfileInfo Then GetProfileInfo(Token)
If Not IsSavedPosts And ID.IsEmptyString Then Throw New ArgumentNullException("ID", "ID is null")
If UpdateToken() Then
Dim nextCursor$ = String.Empty
Dim c%
URL = $"https://bsky.social/xrpc/app.bsky.feed.getAuthorFeed?actor={ID_Encoded}&filter=posts_and_author_threads&includePins=false&limit=99"
Dim n$(), p$()
If IsSavedPosts Then
URL = "https://bsky.social/xrpc/app.bsky.bookmark.getBookmarks"
If Not Cursor.IsEmptyString Then URL &= $"?cursor={Cursor}"
n = {"bookmarks"}
p = {"item"}
Else
'posts_and_author_threads
'posts_with_media
URL = $"https://bsky.social/xrpc/app.bsky.feed.getAuthorFeed?actor={ID_Encoded}&filter={IIf(DownloadModelMedia, "posts_with_media", "posts_and_author_threads")}&includePins=false&limit=99"
If Not Cursor.IsEmptyString Then URL &= $"&cursor={SymbolsConverter.ASCII.EncodeSymbolsOnly(Cursor)}"
n = {"feed"}
p = {"post"}
End If
Dim r$ = Responser.GetResponse(URL)
TokenUpdateCountReset()
If Not r.IsEmptyString Then
Using j As EContainer = JsonDocument.Parse(r)
If j.ListExists Then
With j("feed")
nextCursor = j.Value("cursor")
With j(n)
If .ListExists Then
For Each post As EContainer In .Self
With post({"post"})
c = DefaultParser(.Self,, nextCursor)
With post(p)
c = DefaultParser(.Self) ',, nextCursor)
Select Case c
Case CInt(DateResult.Skip) * -1 : Continue For
Case CInt(DateResult.Exit) * -1 : Exit Sub
@@ -104,6 +165,8 @@ Namespace API.Bluesky
If DownloadTopCount.HasValue AndAlso DownloadTopCount.Value <= _PostCount Then Exit Sub
End With
Next
ElseIf IsSavedPosts Then
nextCursor = String.Empty
End If
End With
End If
@@ -113,7 +176,11 @@ Namespace API.Bluesky
End If
End If
Catch ex As Exception
ProcessException(ex, Token, $"DownloadData({URL})")
Select Case ProcessException(ex, Token, $"DownloadData({URL})")
Case 1 : DownloadData(Cursor, Token)
Case 2 : Throw ex
Case Else : Throw New ExitException($"StatusCode = {CInt(Responser.StatusCode)}", ex) With {.Silent = True}
End Select
End Try
End Sub
#End Region
@@ -126,7 +193,7 @@ Namespace API.Bluesky
Optional ByVal CheckTempPosts As Boolean = True, Optional ByVal State As UStates = UStates.Unknown) As Integer
Const exitReturn% = CInt(DateResult.Exit) * -1
Const skipReturn% = CInt(DateResult.Skip) * -1
Dim postID$, postDate$, __url$, __urlBase$, __txt$, __userId$
Dim postID$, postDate$, __url$, __urlBase$, __txt$, __userId$, __postAuthor$
Dim updateUrl As Boolean
Dim c% = 0
Dim m As UserMedia
@@ -138,11 +205,12 @@ Namespace API.Bluesky
__urlBase = String.Empty
__txt = String.Empty
__userId = .Value({"author"}, "did")
__postAuthor = String.Empty
With .Item({"record"})
If .ListExists Then
'2025-01-28T02:42:12.415Z
postDate = .Value("createdAt")
NextCursor = postDate
If Not IsSavedPosts Then NextCursor = postDate
If CheckDateLimits Then
Select Case CheckDatesLimit(postDate, DateProvider)
Case DateResult.Skip : Return skipReturn 'Continue For
@@ -155,9 +223,10 @@ Namespace API.Bluesky
If _TempPostsList.Contains(postID) Then Return exitReturn Else _TmpPosts2.Add(postID)
End If
If ParseUserMediaOnly And Not ID.IsEmptyString And Not __userId.IsEmptyString And Not ID = __userId Then Return skipReturn
If ParseUserMediaOnly And Not IsSavedPosts And Not ID.IsEmptyString And Not __userId.IsEmptyString And Not ID = __userId Then Return skipReturn
__urlBase = $"https://bsky.app/profile/{NameTrue}/post/{postID}"
__postAuthor = e.Value({"author"}, "did")
__urlBase = $"https://bsky.app/profile/{If(IsSavedPosts, __postAuthor, NameTrue)}/post/{postID}"
End If
End With
@@ -190,7 +259,11 @@ Namespace API.Bluesky
__url = d.Value("fullsize")
If __url.IsEmptyString Then __url = d.Value({"image", "ref"}, "$link") : updateUrl = True
If __url.IsEmptyString And SecondExtraction Then updateUrl = False : __url = e.Value({"embed"}, "thumb")
If Not __url.IsEmptyString Then createMedia(__url, UTypes.Picture)
If Not __url.IsEmptyString Then
If updateUrl AndAlso Not __url.StartsWith("http") Then _
__url = $"https://cdn.bsky.app/img/feed_fullsize/plain/{__postAuthor}/{__url}@jpeg"
createMedia(__url, UTypes.Picture)
End If
Next
End With
End If
@@ -217,14 +290,33 @@ Namespace API.Bluesky
End Function
#End Region
#Region "GetProfileInfo"
Private Sub GetProfileInfo(ByVal Token As CancellationToken)
Private _CurlProfileTried As Boolean = False
Private Sub GetProfileInfo(ByVal Token As CancellationToken, Optional ByVal UseCurl As Boolean = False)
Try
If UpdateToken() Then
If ForceParseProfileInfo Then ForceParseProfileInfo = False : _ForceSaveUserInfo = True
If UseCurl OrElse UpdateToken() Then
If UseCurl Then
With Responser
.Mode = Responser.Modes.Curl
.CurlSslNoRevoke = True
.CurlInsecure = True
End With
_CurlProfileTried = True
End If
Dim r$ = Responser.GetResponse($"https://bsky.social/xrpc/app.bsky.actor.getProfile?actor={ID.IfNullOrEmpty(NameTrue)}")
TokenUpdateCountReset()
If Not r.IsEmptyString Then
Using j As EContainer = JsonDocument.Parse(r)
If j.ListExists Then
If UseCurl Then
If j.Value("error").StringToLower = "accountdeactivated" OrElse
(j.Value("error").StringToLower = "invalidrequest" And j.Value("message").StringToLower = "profile not found") Then
UserExists = False
Throw New ExitException(r) With {.Silent = True}
Else
Throw New Exception(r)
End If
Else
ID = j.Value("did")
UserSiteNameUpdate(j.Value("displayName"))
UserDescriptionUpdate(j.Value("description"))
@@ -232,6 +324,7 @@ Namespace API.Bluesky
SimpleDownloadAvatar(j.Value("avatar"))
SimpleDownloadAvatar(j.Value("banner"))
End If
End If
End Using
End If
Else
@@ -239,6 +332,8 @@ Namespace API.Bluesky
End If
Catch ex As Exception
ProcessException(ex, Token, "GetProfileInfo")
Finally
If UseCurl Then Responser.Mode = Responser.Modes.Default
End Try
End Sub
#End Region
@@ -325,6 +420,9 @@ Namespace API.Bluesky
Protected Overrides Function DownloadM3U8(ByVal URL As String, ByVal Media As UserMedia, ByVal DestinationFile As SFile, ByVal Token As CancellationToken) As SFile
Return M3U8.Download(URL, DestinationFile, Token, Progress, Not IsSingleObjectDownload)
End Function
Protected Overrides Function DownloadContentDefault_ConvertWebp(ByVal m As UserMedia, ByVal Process As Boolean) As SFile
Return DownloadContentDefault_ConvertWebp_TestImg(m, Process)
End Function
#End Region
#Region "DownloadSingleObject"
Protected Overrides Sub DownloadSingleObject_GetPosts(ByVal Data As IYouTubeMediaContainer, ByVal Token As CancellationToken)
@@ -343,11 +441,17 @@ Namespace API.Bluesky
Protected Overrides Function DownloadingException(ByVal ex As Exception, ByVal Message As String, Optional ByVal FromPE As Boolean = False,
Optional ByVal EObj As Object = Nothing) As Integer
If Responser.StatusCode = Net.HttpStatusCode.BadRequest Then '400
If _TokenUpdateCount = 0 AndAlso UpdateToken(True) Then
If Not _CurlProfileTried Then
GetProfileInfo(Nothing, True)
Return 1
ElseIf _TokenUpdateCount = 0 AndAlso UpdateToken(True) Then
If _CurlProfileTried Then GetProfileInfo(Nothing, True) : _CurlProfileTried = False
Return 1
Else
Return 0
Return 2
End If
ElseIf Responser.StatusCode = Net.HttpStatusCode.BadGateway Or Responser.StatusCode = Net.HttpStatusCode.GatewayTimeout Then '502, 504
Return 3
Else
Return 0
End If

View File

@@ -68,14 +68,7 @@ Namespace API.Facebook
Return New UserExchangeOptions(Me)
End Function
Friend Overrides Sub ExchangeOptionsSet(ByVal Obj As Object)
If Not Obj Is Nothing AndAlso TypeOf Obj Is UserExchangeOptions Then
With DirectCast(Obj, UserExchangeOptions)
ParsePhotoBlock = .ParsePhotoBlock
ParseVideoBlock = .ParseVideoBlock
ParseReelsBlock = .ParseReelsBlock
ParseStoriesBlock = .ParseStoriesBlock
End With
End If
If Not Obj Is Nothing AndAlso TypeOf Obj Is UserExchangeOptions Then DirectCast(Obj, UserExchangeOptions).Apply(Me)
End Sub
#End Region
#Region "Loader"

View File

@@ -6,9 +6,10 @@
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports SCrawler.API.Base
Imports SCrawler.Plugin.Attributes
Namespace API.Facebook
Friend Class UserExchangeOptions
Friend Class UserExchangeOptions : Inherits EditorExchangeOptionsBase
<PSetting(NameOf(SiteSettings.ParsePhotoBlock), NameOf(MySettings))>
Friend Property ParsePhotoBlock As Boolean = True
<PSetting(NameOf(SiteSettings.ParseVideoBlock), NameOf(MySettings))>
@@ -19,6 +20,7 @@ Namespace API.Facebook
Friend Property ParseStoriesBlock As Boolean = True
Private ReadOnly Property MySettings As SiteSettings
Friend Sub New(ByVal u As UserData)
MyBase.New(u)
MySettings = u.HostCollection.Default.Source
ParsePhotoBlock = u.ParsePhotoBlock
ParseVideoBlock = u.ParseVideoBlock
@@ -26,11 +28,21 @@ Namespace API.Facebook
ParseStoriesBlock = u.ParseStoriesBlock
End Sub
Friend Sub New(ByVal s As SiteSettings)
MyBase.New(s)
MySettings = s
ParsePhotoBlock = s.ParsePhotoBlock.Value
ParseVideoBlock = s.ParseVideoBlock.Value
ParseReelsBlock = s.ParseReelsBlock.Value
ParseStoriesBlock = s.ParseStoriesBlock.Value
End Sub
Friend Overrides Sub Apply(ByRef u As UserDataBase)
MyBase.Apply(u)
With DirectCast(u, UserData)
.ParsePhotoBlock = ParsePhotoBlock
.ParseVideoBlock = ParseVideoBlock
.ParseReelsBlock = ParseReelsBlock
.ParseStoriesBlock = ParseStoriesBlock
End With
End Sub
End Class
End Namespace

View File

@@ -1,139 +0,0 @@
' Copyright (C) 2023 Andy https://github.com/AAndyProgram
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation, either version 3 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports System.Net
Imports System.Threading
Imports SCrawler.API.Base
Imports SCrawler.API.Imgur.Declarations
Imports SCrawler.API.YouTube.Objects
Imports SCrawler.Plugin.Hosts
Imports PersonalUtilities.Functions.XML
Imports PersonalUtilities.Functions.RegularExpressions
Imports PersonalUtilities.Tools.Web.Documents.JSON
Namespace API.Imgur
Namespace Declarations
Friend Module Imgur_Declarations
Friend ReadOnly PostRegex As RParams = RParams.DMS("/([^/]+?)(|#.*?|\.[\w]{0,4})(|\?.*?)\Z", 1)
End Module
End Namespace
Friend NotInheritable Class Envir : Inherits UserDataBase
Friend Const SiteKey As String = "AndyProgram_Imgur"
Friend Const SiteName As String = "Imgur"
Friend Sub New()
End Sub
#Region "UserDataBase Support"
Protected Overrides Sub LoadUserInformation_OptionalFields(ByRef Container As XmlFile, ByVal Loading As Boolean)
End Sub
Protected Overrides Sub DownloadDataF(ByVal Token As CancellationToken)
End Sub
Protected Overrides Sub DownloadContent(ByVal Token As CancellationToken)
SeparateVideoFolder = False
DownloadContentDefault(Token)
End Sub
Protected Overrides Function DownloadingException(ByVal ex As Exception, ByVal Message As String, Optional ByVal FromPE As Boolean = False,
Optional ByVal EObj As Object = Nothing) As Integer
Return 0
End Function
#End Region
Protected Overrides Sub DownloadSingleObject_GetPosts(ByVal Data As IYouTubeMediaContainer, ByVal Token As CancellationToken)
Dim videos As IEnumerable(Of UserMedia) = GetVideoInfo(Data.URL, EDP.SendToLog)
If videos.ListExists Then _TempMediaList.AddRange(videos)
End Sub
Friend Shared Function GetGallery(ByVal URL As String, Optional ByVal e As ErrorsDescriber = Nothing) As List(Of String)
Try
If Not Settings.ImgurClientID.IsEmptyString And Not URL.IsEmptyString Then
Dim __url$ = RegexReplace(URL, PostRegex)
If Not __url.IsEmptyString Then
__url = $"https://api.imgur.com/post/v1/albums/{__url}?client_id={Settings.ImgurClientID.Value}&include=media"
Using w As New WebClient
Dim r$ = w.DownloadString(__url)
If Not r.IsEmptyString Then
Using j As EContainer = JsonDocument.Parse(r).XmlIfNothing
If j.Contains("media") Then
Dim UrlsList As New List(Of String)
Dim tmpUrl$
For Each m As EContainer In j("media")
tmpUrl = m.Value("url")
If Not tmpUrl.IsEmptyString Then UrlsList.ListAddValue(tmpUrl, Base.LNC)
Next
Return UrlsList
End If
End Using
End If
End Using
End If
End If
Return Nothing
Catch ex As Exception
Return DownloadingException_Internal(ex, $"[API.Imgur.Envir.GetGallery({URL})]", Nothing, e)
End Try
End Function
Friend Shared Function GetImage(ByVal URL As String, Optional ByVal e As ErrorsDescriber = Nothing) As String
Try
If Not Settings.ImgurClientID.IsEmptyString And Not URL.IsEmptyString Then
Dim __url$ = RegexReplace(URL, PostRegex)
If Not __url.IsEmptyString Then
__url = $"https://api.imgur.com/3/image/{__url}?client_id={Settings.ImgurClientID.Value}&include=media"
Using w As New WebClient
Dim r$ = w.DownloadString(__url)
If Not r.IsEmptyString Then Return JsonDocument.Parse(r).XmlIfNothing.Value({"data"}, "link")
End Using
End If
End If
Return String.Empty
Catch ex As Exception
Return DownloadingException_Internal(ex, $"[API.Imgur.Envir.GetImage({URL})]", String.Empty, e)
End Try
End Function
Friend Shared Function GetVideoInfo(ByVal URL As String, Optional ByVal e As ErrorsDescriber = Nothing) As IEnumerable(Of UserMedia)
Try
If Not URL.IsEmptyString AndAlso URL.ToLower.Contains("imgur") AndAlso Not Settings.ImgurClientID.IsEmptyString Then
Dim imgList As List(Of String) = GetGallery(URL, EDP.ReturnValue)
If imgList.ListExists Then
Return imgList.Select(Function(u) New UserMedia(u))
Else
Dim img$ = GetImage(URL, EDP.ReturnValue)
If Not img.IsEmptyString Then Return {New UserMedia(img)}
End If
End If
Return Nothing
Catch ex As Exception
If Not e.Exists Then e = EDP.LogMessageValue
Return ErrorsDescriber.Execute(e, ex, $"[API.Imgur.Envir.GetVideoInfo({URL})]: fetch media error")
End Try
End Function
Friend Shared Function GetSingleMediaInstance(ByVal URL As String, ByVal OutputFile As SFile) As IYouTubeMediaContainer
If Not URL.IsEmptyString AndAlso URL.Contains("imgur.com") Then
Return New DownloadableMediaHost(URL, OutputFile) With {
.Instance = New Envir,
.Site = SiteName,
.SiteKey = SiteKey,
.SiteIcon = Nothing
}
Else
Return Nothing
End If
End Function
Private Shared Function DownloadingException_Internal(ByVal ex As Exception, ByVal Message As String,
ByVal NullArg As Object, ByVal e As ErrorsDescriber) As Object
If TypeOf ex Is WebException Then
Dim obj As HttpWebResponse = TryCast(DirectCast(ex, WebException).Response, HttpWebResponse)
If Not obj Is Nothing Then
If obj.StatusCode = HttpStatusCode.NotFound Then
Return NullArg
ElseIf obj.StatusCode = HttpStatusCode.Unauthorized Then
MyMainLOG = "Imgur credentials expired"
Return NullArg
End If
End If
End If
If Not e.Exists Then e = New ErrorsDescriber(EDP.ReturnValue + EDP.SendToLog)
Return ErrorsDescriber.Execute(e, ex, Message, NullArg)
End Function
End Class
End Namespace

View File

@@ -20,6 +20,8 @@ Namespace API.Instagram
Friend Const PageTokenRegexPatternDefault As String = "\[\],{""token"":""(.*?)""},\d+\]"
Friend ReadOnly Regex_UserToken_dtsg As RParams = RParams.DMS("DTSGInitialData["":,.\[\]]*?{\s*.token.:\s*""([^""]+)", 1, EDP.ReturnValue)
Friend ReadOnly Regex_UserToken_lsd As RParams = RParams.DMS("LSD["":,.\[\]]*?{\s*.token.:\s*""([^""]+)", 1, EDP.ReturnValue)
Friend ReadOnly Regex_BlockVersionID As RParams = RParams.DMS("""versioningID"":""([^""]+)""", 1, EDP.ReturnValue)
Friend ReadOnly Regex_ProfileID As RParams = RParams.DMS("profilePage_(\d+)", 1, EDP.ReturnValue)
Friend Sub UpdateResponser(ByVal Source As IResponse, ByRef Destination As Responser, ByVal UpdateWwwClaim As Boolean)
Const r_wwwClaimName$ = "x-ig-set-www-claim"
Const r_tokenName$ = SiteSettings.Header_CSRF_TOKEN_COOKIE

View File

@@ -36,6 +36,8 @@ Namespace API.Instagram
<PSetting(Caption:="Place the extracted image into the video folder")>
Friend Property PutImageVideoFolder As Boolean
Friend Overrides Property UserName As String
<PSetting(Address:=SettingAddress.User, Caption:="Verified profile", ToolTip:="This profile has a verified mark")>
Friend Property IsVerifiedProfile As Boolean = False
<PSetting(Address:=SettingAddress.User, Caption:="Force update UserName", ToolTip:="Try to force update UserName if it is not found on the site")>
Friend Property ForceUpdateUserName As Boolean = False
<PSetting(Address:=SettingAddress.User, Caption:="Force update user information")>
@@ -57,6 +59,8 @@ Namespace API.Instagram
PutImageVideoFolder = .PutImageVideoFolder
IsVerifiedProfile = .IsVerifiedProfile
ForceUpdateUserName = .ForceUpdateUserName
ForceUpdateUserInfo = .ForceUpdateUserInfo
End With

View File

@@ -70,7 +70,7 @@ Namespace API.Instagram
Friend Const Header_Browser As String = "Sec-Ch-Ua"
Friend Const Header_BrowserExt As String = "Sec-Ch-Ua-Full-Version-List"
Friend Const Header_Platform_Verion As String = "Sec-Ch-Ua-Platform-Version"
<PropertyOption(ControlText:="x-csrftoken", ControlToolTip:="Can be automatically extracted from cookies", IsAuth:=True, AllowNull:=True), PClonable(Clone:=False)>
<PropertyOption(ControlText:="x-csrftoken", ControlToolTip:="Can be automatically extracted from cookies", IsAuth:=True, AllowNull:=False), PClonable(Clone:=False)>
Friend ReadOnly Property HH_CSRF_TOKEN As PropertyValue
<CookieValueExtractor(NameOf(HH_CSRF_TOKEN))>
Private Function GetValueFromCookies(ByVal PropName As String, ByVal c As CookieKeeper) As String
@@ -78,7 +78,7 @@ Namespace API.Instagram
End Function
<PropertyOption(ControlText:="x-ig-app-id", IsAuth:=True, AllowNull:=False), PClonable(Clone:=False)>
Friend ReadOnly Property HH_IG_APP_ID As PropertyValue
<PropertyOption(ControlText:="x-asbd-id", IsAuth:=True, AllowNull:=True), PClonable(Clone:=False)>
<PropertyOption(ControlText:="x-asbd-id", IsAuth:=True, AllowNull:=False), PClonable(Clone:=False)>
Friend ReadOnly Property HH_ASBD_ID As PropertyValue
'PropertyOption(ControlText:="x-ig-www-claim", IsAuth:=True, AllowNull:=True)
<PClonable(Clone:=False)>
@@ -89,16 +89,16 @@ Namespace API.Instagram
Return Not v.IsEmptyString AndAlso v = "0"
End Get
End Property
<PropertyOption(ControlText:="sec-ch-ua", IsAuth:=True, AllowNull:=True,
<PropertyOption(ControlText:="sec-ch-ua", IsAuth:=True, AllowNull:=False,
InheritanceName:=SettingsCLS.HEADER_DEF_sec_ch_ua), PClonable, PXML(OnlyForChecked:=True)>
Private ReadOnly Property HH_BROWSER As PropertyValue
<PropertyOption(ControlText:="sec-ch-ua-full", ControlToolTip:="sec-ch-ua-full-version-list", IsAuth:=True, AllowNull:=True,
<PropertyOption(ControlText:="sec-ch-ua-full", ControlToolTip:="sec-ch-ua-full-version-list", IsAuth:=True, AllowNull:=False,
InheritanceName:=SettingsCLS.HEADER_DEF_sec_ch_ua_full_version_list), PClonable, PXML(OnlyForChecked:=True)>
Private ReadOnly Property HH_BROWSER_EXT As PropertyValue
<PropertyOption(ControlText:="sec-ch-ua-platform-ver", ControlToolTip:="sec-ch-ua-platform-version", IsAuth:=True, AllowNull:=True, LeftOffset:=135,
<PropertyOption(ControlText:="sec-ch-ua-platform-ver", ControlToolTip:="sec-ch-ua-platform-version", IsAuth:=True, AllowNull:=False, LeftOffset:=135,
InheritanceName:=SettingsCLS.HEADER_DEF_sec_ch_ua_platform_version), PClonable, PXML(OnlyForChecked:=True)>
Private ReadOnly Property HH_PLATFORM As PropertyValue
<PropertyOption(ControlText:="UserAgent", IsAuth:=True, AllowNull:=True,
<PropertyOption(ControlText:="UserAgent", IsAuth:=True, AllowNull:=False,
InheritanceName:=SettingsCLS.HEADER_DEF_UserAgent), PClonable, PXML(OnlyForChecked:=True)>
Private ReadOnly Property HH_USER_AGENT As PropertyValue
Friend Overrides Function BaseAuthExists() As Boolean
@@ -146,8 +146,12 @@ Namespace API.Instagram
<Provider(NameOf(HH_IG_WWW_CLAIM_UPDATE_INTERVAL), FieldsChecker:=True)>
Private ReadOnly Property TokenUpdateIntervalProvider As IFormatProvider
#End Region
<PropertyOption(ControlText:="Use GraphQL to download", IsAuth:=True), PXML, PClonable>
<PropertyOption(ControlText:="Use GraphQL to download", IsAuth:=True), PXML, PClonable, HiddenControl>
Friend ReadOnly Property USE_GQL As PropertyValue
<PropertyOption(ControlText:="Use GraphQL to download user data", IsAuth:=True), PXML, PClonable, HiddenControl>
Friend ReadOnly Property USE_GQL_UserData As PropertyValue
<PropertyOption(ControlText:="Use GraphQL to download user stories (highlights)", IsAuth:=True), PXML, PClonable, HiddenControl>
Friend ReadOnly Property USE_GQL_Highlights As PropertyValue
#End Region
#Region "Download data"
<PropertyOption(ControlText:="Download timeline", Category:=CAT_DOWN), PXML, PClonable>
@@ -165,6 +169,14 @@ Namespace API.Instagram
<PropertyOption(ControlText:="Download tagged posts", Category:=CAT_DOWN), PXML, PClonable>
Friend ReadOnly Property DownloadTagged As PropertyValue
<PXML> Private ReadOnly Property DownloadTagged_Def As PropertyValue
<PropertyOption(ControlText:="Number of posts (verified)", ControlToolTip:="The number of posts received per request if the profile has a verified mark", Category:=CAT_DOWN), PXML, PClonable, HiddenControl>
Friend ReadOnly Property PostNumberVerified As PropertyValue
<Provider(NameOf(PostNumberVerified), FieldsChecker:=True)>
Private ReadOnly Property PostNumberVerifiedProvider As IFormatProvider
<PropertyOption(ControlText:="Number of posts (unverified)", ControlToolTip:="The number of posts received per request if the profile doesn't have a verified mark", Category:=CAT_DOWN), PXML, PClonable, HiddenControl>
Friend ReadOnly Property PostNumberVerifiedNot As PropertyValue
<Provider(NameOf(PostNumberVerifiedNot), FieldsChecker:=True)>
Private ReadOnly Property PostNumberVerifiedNotProvider As IFormatProvider
#End Region
#Region "Timers"
Friend Const TimersUrgentTip As String = vbCr & "It is highly recommended not to change the default value."
@@ -480,11 +492,13 @@ Namespace API.Instagram
HH_IG_WWW_CLAIM_UPDATE_INTERVAL = New PropertyValue(120)
HH_IG_WWW_CLAIM_ALWAYS_ZERO = New PropertyValue(False)
HH_IG_WWW_CLAIM_RESET_EACH_SESSION = New PropertyValue(True)
HH_IG_WWW_CLAIM_RESET_EACH_TARGET = New PropertyValue(True)
HH_IG_WWW_CLAIM_RESET_EACH_TARGET = New PropertyValue(False)
HH_IG_WWW_CLAIM_USE = New PropertyValue(True)
HH_IG_WWW_CLAIM_USE_DEFAULT_ALGO = New PropertyValue(True)
TokenUpdateIntervalProvider = New TokenRefreshIntervalProvider
USE_GQL = New PropertyValue(False)
USE_GQL = New PropertyValue(True)
USE_GQL_UserData = New PropertyValue(True)
USE_GQL_Highlights = New PropertyValue(True)
DownloadTimeline = New PropertyValue(True)
DownloadTimeline_Def = New PropertyValue(DownloadTimeline.Value, GetType(Boolean))
@@ -496,8 +510,12 @@ Namespace API.Instagram
DownloadStoriesUser_Def = New PropertyValue(DownloadStoriesUser.Value, GetType(Boolean))
DownloadTagged = New PropertyValue(False)
DownloadTagged_Def = New PropertyValue(DownloadTagged.Value, GetType(Boolean))
PostNumberVerified = New PropertyValue(50)
PostNumberVerifiedProvider = New TimersChecker(12)
PostNumberVerifiedNot = New PropertyValue(12)
PostNumberVerifiedNotProvider = New TimersChecker(12)
RequestsWaitTimer_Any = New PropertyValue(1000)
RequestsWaitTimer_Any = New PropertyValue(5000)
RequestsWaitTimer_AnyProvider = New TimersChecker(0)
RequestsWaitTimer = New PropertyValue(1000)
RequestsWaitTimerProvider = New TimersChecker(100)
@@ -526,10 +544,10 @@ Namespace API.Instagram
SkipErrors_AddToLog_Silent = New PropertyValue(String.Empty, GetType(String))
IgnoreStoriesDownloadingErrors = New PropertyValue(False)
DownDetectorValue = New PropertyValue(20)
DownDetectorValue = New PropertyValue(30)
DownDetectorValueProvider = New TimersChecker(-1)
DownDetectorValueAddToLog = New PropertyValue(False)
TaggedNotifyLimit = New PropertyValue(200)
DownDetectorValueAddToLog = New PropertyValue(True)
TaggedNotifyLimit = New PropertyValue(50)
TaggedNotifyLimitProvider = New TaggedNotifyLimitChecker
DownloadingErrorDate = New PropertyValue(Now.AddYears(-10), GetType(Date))
@@ -545,18 +563,13 @@ Namespace API.Instagram
UserRegex = RParams.DMS(String.Format(UserRegexDefaultPattern, "instagram.com/"), 1)
ImageVideoContains = "instagram.com"
End Sub
Private Const SettingsVersionCurrent As Integer = 2
Private Const SettingsVersionCurrent As Integer = 4
Friend Overrides Sub EndInit()
Try : MyLastRequests.Add(LastDownloadDate.Value, LastRequestsCount.Value) : Catch : End Try
If Not CBool(HH_IG_WWW_CLAIM_USE.Value) Then Responser.Headers.Remove(Header_IG_WWW_CLAIM)
If CInt(SettingsVersion.Value) < SettingsVersionCurrent Then
SettingsVersion.Value = SettingsVersionCurrent
HH_IG_WWW_CLAIM_UPDATE_INTERVAL.Value = 120
HH_IG_WWW_CLAIM_ALWAYS_ZERO.Value = False
HH_IG_WWW_CLAIM_RESET_EACH_SESSION.Value = True
HH_IG_WWW_CLAIM_RESET_EACH_TARGET.Value = True
HH_IG_WWW_CLAIM_USE.Value = True
HH_IG_WWW_CLAIM_USE_DEFAULT_ALGO.Value = True
USE_GQL.Value = True
End If
MyBase.EndInit()
End Sub

View File

@@ -6,12 +6,13 @@
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports System.Security.Cryptography
Imports System.Threading
Imports SCrawler.API.Base
Imports PersonalUtilities.Functions.XML
Imports PersonalUtilities.Functions.RegularExpressions
Imports PersonalUtilities.Functions.XML
Imports PersonalUtilities.Tools.Web.Clients
Imports PersonalUtilities.Tools.Web.Documents.JSON
Imports SCrawler.API.Base
Namespace API.Instagram
Partial Friend Class UserData
#Region "Tokens"
@@ -26,26 +27,30 @@ Namespace API.Instagram
Token_dtsg = String.Empty
Token_lsd = String.Empty
End Sub
Protected Property BlockVersionID As String = String.Empty
#End Region
#Region "Headers"
Friend Const GQL_HEADER_FB_FRINDLY_NAME As String = "x-fb-friendly-name"
Friend Const GQL_HEADER_FB_LSD As String = "x-fb-lsd"
Friend Const GQL_HEADER_BLOCK_VERSION_ID As String = "x-bloks-version-id"
Friend Const GQL_HEADER_ROOT_FIELD_NAME As String = "x-root-field-name"
Friend Const GQL_HEADER_ROOT_FIELD_NAME_Value As String = "fetch__XDTUserDict"
#End Region
#Region "Data constants"
Private Const GQL_UserData_DocId As String = "7381344031985950"
Private Const GQL_UserData_DocId As String = "26672929172408668" '"35710877621861450" '"7381344031985950"
Private Const GQL_UserData_FbFriendlyName As String = "PolarisProfilePageContentQuery"
Private Const GQL_Highlights_DocId As String = "8298007123561120"
Private Const GQL_Highlights_DocId_Second As String = "7559771384111300"
Private Const GQL_Highlights_DocId As String = "36997000523232338" '"8298007123561120"
Private Const GQL_Highlights_DocId_Second As String = "27618287167780519" '"7559771384111300"
Private Const GQL_Highlights_FbFriendlyName As String = "PolarisProfileStoryHighlightsTrayContentQuery"
Private Const GQL_Highlights_FbFriendlyName_Second As String = "PolarisStoriesV3HighlightsPageQuery"
Private Const GQL_UserStories_DocId As String = "25231722019806941"
Private Const GQL_UserStories_FbFriendlyName As String = "PolarisStoriesV3ReelPageStandaloneQuery"
Private Const GQL_Timeline_DocId As String = "7268577773270422"
Private Const GQL_Timeline_DocId As String = "7268577773270422" '"34579740524958711" '"7268577773270422"
Private Const GQL_Timeline_FbFriendlyName As String = "PolarisProfilePostsQuery"
Private Const GQL_Timeline_DocId_Second As String = "7286316061475375"
Private Const GQL_Timeline_DocId_Second As String = "7286316061475375" '"33944389991841132" '"7286316061475375"
Private Const GQL_Timeline_FbFriendlyName_Second As String = "PolarisProfilePostsTabContentQuery_connection"
Private Const GQL_Reels_DocId As String = "7191572580905225"
@@ -60,52 +65,80 @@ Namespace API.Instagram
Private Const GQL_URL_Q As String = "https://www.instagram.com/graphql/query"
#End Region
#Region "Download functions"
Protected Sub UpdateHeadersGQL(ByVal HeaderValue As String)
Responser.Headers.Add(GQL_HEADER_FB_FRINDLY_NAME, HeaderValue)
Responser.Headers.Add(GQL_HEADER_FB_LSD, Token_lsd)
Protected Sub UpdateHeadersGQL(ByVal HeaderValue As String, Optional ByVal Add As Boolean = True)
With Responser.Headers
If Add Then
.Add(GQL_HEADER_FB_FRINDLY_NAME, HeaderValue)
.Add(GQL_HEADER_FB_LSD, Token_lsd)
'.Add(GQL_HEADER_BLOCK_VERSION_ID, BlockVersionID)
'.Add(GQL_HEADER_ROOT_FIELD_NAME, GQL_HEADER_ROOT_FIELD_NAME_Value)
Else
.Remove(GQL_HEADER_FB_FRINDLY_NAME)
.Remove(GQL_HEADER_FB_LSD)
'.Remove(GQL_HEADER_BLOCK_VERSION_ID)
'.Remove(GQL_HEADER_ROOT_FIELD_NAME)
End If
End With
End Sub
<Obsolete("Use 'GET' function: 'GetUserData'", False)>
Private Sub GetUserDataGQL(ByVal Token As CancellationToken)
'<Obsolete("Use 'GET' function: 'GetUserData'", False)>
Private Function GetUserDataGQL(ByVal Token As CancellationToken) As String
UpdateTokens(Not ValidateBaseTokens())
'Dim vars$ = String.Format(GQL_URL_PATTERN_VARS, GQL_UserData_DocId, Token_lsd, Token_dtsg_Var, GQL_UserData_FbFriendlyName,
' SymbolsConverter.ASCII.EncodeSymbolsOnly("{" & $"""id"":""{ID}"",""relay_header"":false,""render_surface"":""PROFILE""" & "}"))
Dim vars$ = String.Format(GQL_URL_PATTERN_VARS, GQL_UserData_DocId, Token_lsd, Token_dtsg_Var, GQL_UserData_FbFriendlyName,
SymbolsConverter.ASCII.EncodeSymbolsOnly("{" & $"""id"":""{ID}"",""relay_header"":false,""render_surface"":""PROFILE""" & "}"))
SymbolsConverter.ASCII.EncodeSymbolsOnly("{" & $"""enable_integrity_filters"":true,""id"":""{ID}"",""__relay_internal__pv__PolarisCannesGuardianExperienceEnabledrelayprovider"":true,""__relay_internal__pv__PolarisCASB976ProfileEnabledrelayprovider"":false,""__relay_internal__pv__PolarisWebSchoolsEnabledrelayprovider"":false,""__relay_internal__pv__PolarisRepostsConsumptionEnabledrelayprovider"":true" & "}"))
UpdateRequestNumber()
ChangeResponserMode(True)
UpdateHeadersGQL(GQL_UserData_FbFriendlyName)
Dim r$ = Responser.GetResponse(GQL_URL, vars)
If Not r.IsEmptyString Then
Using j As EContainer = JsonDocument.Parse(r)
If j.ListExists Then
With j({"data", "user"})
If .ListExists Then
UserSiteName = .Value("full_name").IfNullOrEmpty(UserSiteName)
Dim f As New SFile With {.Path = DownloadContentDefault_GetRootDir(), .Name = "ProfilePicture", .Extension = "jpg"}
Dim pic$ = .Value({"hd_profile_pic_url_info"}, "url").IfNullOrEmpty(.Value("profile_pic_url"))
If Not pic.IsEmptyString Then GetWebFile(pic, f, EDP.ReturnValue)
UserDescriptionUpdate(.Value("biography"))
End If
End With
End If
End Using
End If
End Sub
Dim r$ = Responser.GetResponse(GQL_URL_Q, vars)
Return r
'If Not r.IsEmptyString Then
' Using j As EContainer = JsonDocument.Parse(r)
' If j.ListExists Then
' With j({"data", "user"})
' If .ListExists Then
' UserSiteName = .Value("full_name").IfNullOrEmpty(UserSiteName)
' IsVerifiedProfile = .Value("is_verified").FromXML(Of Boolean)(False)
' IsVerifiedProfile_Checked = True
' Dim descr$ = .Value("biography")
' If If(.Item("bio_links")?.Count, 0) > 0 Then descr.StringAppend(.Item("bio_links").Select(Function(bl) bl.Value("url")).ListToString(vbNewLine), vbNewLine)
' Dim eUrl$ = .Value("external_url")
' If Not eUrl.IsEmptyString AndAlso (descr.IsEmptyString OrElse Not descr.Contains(eUrl)) Then descr.StringAppendLine(eUrl)
' UserDescriptionUpdate(descr)
' Dim f As New SFile With {.Path = DownloadContentDefault_GetRootDir(), .Name = "ProfilePicture", .Extension = "jpg"}
' Dim pic$ = .Value({"hd_profile_pic_url_info"}, "url").IfNullOrEmpty(.Value("profile_pic_url"))
' If Not pic.IsEmptyString Then GetWebFile(pic, f, EDP.ReturnValue)
' End If
' End With
' End If
' End Using
'End If
End Function
Private Function GetTimelineGQL(ByVal Cursor As String, ByVal Token As CancellationToken) As String
Const none_cursor$ = "none"
Dim nextCursor$ = String.Empty, hasNextPage$ = String.Empty
Dim nextCursor$ = String.Empty
Dim hasNextPage As Boolean = False
Dim vars$
ThrowAny(Token)
UpdateTokens(Not ValidateBaseTokens())
UpdateRequestNumber()
ChangeResponserMode(True)
If Cursor.IsEmptyString Then
vars = "{""data"":{""count"":50,""include_relationship_info"":true,""latest_besties_reel_media"":true,""latest_reel_media"":true},""username"":""" &
vars = "{""data"":{""count"":" & PostNumberPerRequest & ",""include_relationship_info"":true,""latest_besties_reel_media"":true,""latest_reel_media"":true},""username"":""" &
NameTrue & """,""__relay_internal__pv__PolarisShareMenurelayprovider"":false}"
'vars = "{""data"":{""count"":" & PostNumberPerRequest & ",""include_reel_media_seen_timestamp"":true,""include_relationship_info"":true,""latest_besties_reel_media"":true,""latest_reel_media"":true},""username"":""" &
' NameTrue & """,""__relay_internal__pv__PolarisShareMenurelayprovider"":false}"
vars = String.Format(GQL_URL_PATTERN_VARS, GQL_Timeline_DocId, Token_lsd, Token_dtsg_Var, GQL_Timeline_FbFriendlyName,
SymbolsConverter.ASCII.EncodeSymbolsOnly(vars))
UpdateHeadersGQL(GQL_Timeline_FbFriendlyName)
Else
vars = "{""after"":""" & Cursor & """,""before"":null,""data"":{""count"":50,""include_relationship_info"":true,""latest_besties_reel_media"":true,""latest_reel_media"":true},""first"":50,""last"":null,""username"":""" &
vars = "{""after"":""" & Cursor & """,""before"":null,""data"":{""count"":" & PostNumberPerRequest & ",""include_relationship_info"":true,""latest_besties_reel_media"":true,""latest_reel_media"":true},""first"":" & PostNumberPerRequest & ",""last"":null,""username"":""" &
NameTrue & """,""__relay_internal__pv__PolarisShareMenurelayprovider"":false}"
'vars = "{""after"":""" & Cursor & """,""before"":null,""data"":{""count"":" & PostNumberPerRequest & ",""include_reel_media_seen_timestamp"":true,""include_relationship_info"":true,""latest_besties_reel_media"":true,""latest_reel_media"":true},""first"":" & PostNumberPerRequest & ",""last"":null,""username"":""" &
' NameTrue & """}"
vars = String.Format(GQL_URL_PATTERN_VARS, GQL_Timeline_DocId_Second, Token_lsd, Token_dtsg_Var, GQL_Timeline_FbFriendlyName_Second,
SymbolsConverter.ASCII.EncodeSymbolsOnly(vars))
UpdateHeadersGQL(GQL_Timeline_FbFriendlyName_Second)
@@ -139,8 +172,9 @@ Namespace API.Instagram
Return If(hasNextPage And (Not nextCursor.IsEmptyString AndAlso Not nextCursor.StringToLower = none_cursor), nextCursor, String.Empty)
End Function
Private Function GetHighlightsGQL_List() As List(Of String)
Dim nextCursor$ = String.Empty, hasNextPage$ = String.Empty
UpdateTokens(Not ValidateBaseTokens())
Dim nextCursor$ = String.Empty
Dim hasNextPage As Boolean = False
Dim i% = -1
Dim hList As New List(Of String)
Dim tmpList As New List(Of String)
@@ -174,12 +208,15 @@ Namespace API.Instagram
Return hList
End Function
Private Sub GetHighlightsGQL(ByRef StoriesList As List(Of String), ByVal Token As CancellationToken)
Const highlightData$ = """first"":50,""initial_reel_id"":""{0}"",""last"":2,""reel_ids"":[{1}]"
Const highlightData$ = """initial_reel_id"":""{0}"",""reel_ids"":[{1}],""first"":50,""last"":2,""__relay_internal__pv__PolarisCommunityNoteStoriesLabelEnabledrelayprovider"":true"
Dim tmpList As New List(Of String)
Dim i% = -1
If StoriesList.ListExists Then
tmpList.AddRange(StoriesList.Take(10))
'TODO: 5 Instagram stories
'tmpList.AddRange(StoriesList.Take(10))
tmpList.AddRange(StoriesList.Take(5))
StoriesList.RemoveRange(0, tmpList.Count)
UpdateTokens(Not ValidateBaseTokens())
Dim vars$ = String.Format(GQL_URL_PATTERN_VARS, GQL_Highlights_DocId_Second, Token_lsd, Token_dtsg_Var, GQL_Highlights_FbFriendlyName_Second,
SymbolsConverter.ASCII.EncodeSymbolsOnly("{" & String.Format(highlightData, tmpList(0), tmpList.Select(Function(hl) $"""{hl}""").ListToString(",")) & "}"))
@@ -206,6 +243,7 @@ Namespace API.Instagram
tmpList.Clear()
End Sub
Private Sub GetUserStoriesGQL(ByVal Token As CancellationToken)
UpdateTokens(Not ValidateBaseTokens())
'"{" & $"""user_id"":""{ID}""" & "}"
Dim vars$ = String.Format(GQL_URL_PATTERN_VARS, GQL_UserStories_DocId, Token_lsd, Token_dtsg_Var, GQL_UserStories_FbFriendlyName,
SymbolsConverter.ASCII.EncodeSymbolsOnly("{" & $"""reel_ids_arr"":[""{ID}""]" & "}"))
@@ -238,11 +276,9 @@ Namespace API.Instagram
Private Function GetReelsGQL(ByVal Cursor As String) As String
GetReelsGQL_SetEnvir = True
Dim errData$ = String.Empty
If Cursor.IsEmptyString And Not ValidateBaseTokens() Then GetPageTokens()
If Cursor.IsEmptyString And Not ValidateBaseTokens(errData) Then ValidateBaseTokens_Error(errData)
UpdateTokens(Cursor.IsEmptyString Or Not ValidateBaseTokens())
Dim vars$ = """data"":{""include_feed_video"":true,""page_size"":50,""target_user_id"":""" & ID & """}"
Dim vars$ = """data"":{""include_feed_video"":true,""page_size"":" & PostNumberPerRequest & ",""target_user_id"":""" & ID & """}"
If Not Cursor.IsEmptyString Then vars = $"""after"":""{Cursor}"",""before"":null,{vars},""first"":4,""last"":null"
vars = String.Format(GQL_URL_PATTERN_VARS, GQL_Reels_DocId, Token_lsd, Token_dtsg_Var, GQL_Reels_FbFriendlyName,
SymbolsConverter.ASCII.EncodeSymbolsOnly("{" & vars & "}"))
@@ -253,15 +289,16 @@ Namespace API.Instagram
End Function
''' <summary>Response</summary>
Private Function GetTaggedGQL(ByVal Cursor As String) As String
UpdateTokens(Not ValidateBaseTokens())
'default count = 12
'max count = 21
Dim vars$
If Cursor.IsEmptyString Then
vars = String.Format(GQL_URL_PATTERN_VARS, GQL_Tagged_DocId, Token_lsd, Token_dtsg_Var, GQL_Tagged_FbFriendlyName,
SymbolsConverter.ASCII.EncodeSymbolsOnly("{" & $"""count"":50,""user_id"":""{ID}""" & "}"))
SymbolsConverter.ASCII.EncodeSymbolsOnly("{" & $"""count"":{PostNumberPerRequest},""user_id"":""{ID}""" & "}"))
Else
vars = String.Format(GQL_URL_PATTERN_VARS, GQL_Tagged_DocId, Token_lsd, Token_dtsg_Var, GQL_Tagged_FbFriendlyName,
SymbolsConverter.ASCII.EncodeSymbolsOnly("{" & $"""after"":""{Cursor}"",""before"":null,""count"":50,""first"":50,""last"":null,""user_id"":""{ID}""" & "}"))
SymbolsConverter.ASCII.EncodeSymbolsOnly("{" & $"""after"":""{Cursor}"",""before"":null,""count"":{PostNumberPerRequest},""first"":{PostNumberPerRequest},""last"":null,""user_id"":""{ID}""" & "}"))
End If
UpdateRequestNumber()
ChangeResponserMode(True)
@@ -270,6 +307,13 @@ Namespace API.Instagram
End Function
#End Region
#Region "ValidateBaseTokens"
Private Sub UpdateTokens(ByVal process As Boolean)
If process Then
Dim TokensErrData$ = String.Empty
If Not ValidateBaseTokens() Then GetPageTokens()
If Not ValidateBaseTokens(TokensErrData) Then ValidateBaseTokens_Error(TokensErrData)
End If
End Sub
Protected Overridable Overloads Function ValidateBaseTokens() As Boolean
Return ValidateBaseTokens(Nothing)
End Function
@@ -296,7 +340,12 @@ Namespace API.Instagram
.Add(HttpHeaderCollection.GetSpecialHeader(MyHeaderTypes.SecFetchMode, "navigate"))
End With
End With
Dim r$ = Responser.GetResponse(MySiteSettings.GetUserUrl(Me))
Dim r$
If UserNameRequested Then
r = Responser.GetResponse("https://www.instagram.com/")
Else
r = Responser.GetResponse(MySiteSettings.GetUserUrl(Me))
End If
ParseTokens(r, 0)
Catch ex As Exception
Finally
@@ -307,6 +356,10 @@ Namespace API.Instagram
Try
If Not r.IsEmptyString Then
ResetBaseTokens()
If ID.IsEmptyString Then
Dim __id$ = RegexReplace(r, Regex_ProfileID)
If CLng(AConvert(Of Long)(__id, 0, EDP.ReturnValue)) <> 0 Then ID = __id
End If
Select Case Attempt
Case 0
Dim rr As RParams = RParams.DM(PageTokenRegexPatternDefault, 0, RegexReturn.List, EDP.ReturnValue)
@@ -318,6 +371,7 @@ Namespace API.Instagram
.MatchSub = 1
.WhatGet = RegexReturn.Value
End With
BlockVersionID = RegexReplace(r, Regex_BlockVersionID)
For Each tt In tokens
If Not Token_lsd.IsEmptyString And Not Token_dtsg.IsEmptyString Then
Exit For
@@ -336,6 +390,7 @@ Namespace API.Instagram
Case 1
Token_dtsg = RegexReplace(r, Regex_UserToken_dtsg)
Token_lsd = RegexReplace(r, Regex_UserToken_lsd)
BlockVersionID = RegexReplace(r, Regex_BlockVersionID)
End Select
If Not ValidateBaseTokens() And Attempt = 0 Then ParseTokens(r, Attempt + 1)
End If

View File

@@ -39,6 +39,8 @@ Namespace API.Instagram
Private Const Name_TaggedChecked As String = "TaggedChecked"
Private Const Name_ForceUpdateUserName As String = "ForceUpdateUserName"
Private Const Name_ForceUpdateUserInfo As String = "ForceUpdateUserInfo"
Private Const Name_IsVerifiedProfile As String = "IsVerifiedProfile"
Private Const Name_IsVerifiedProfile_Checked As String = "IsVerifiedProfile_Checked"
#End Region
#Region "Declarations"
Friend Structure PostKV : Implements IEContainerProvider
@@ -115,6 +117,13 @@ Namespace API.Instagram
Private UserNameRequested As Boolean = False
Friend Property ForceUpdateUserName As Boolean = False
Friend Property ForceUpdateUserInfo As Boolean = False
Friend Property IsVerifiedProfile As Boolean = False
Friend Property IsVerifiedProfile_Checked As Boolean = False
Private ReadOnly Property PostNumberPerRequest As Integer
Get
With MySiteSettings : Return If(IsVerifiedProfile, .PostNumberVerified, .PostNumberVerifiedNot).Value : End With
End Get
End Property
#End Region
#Region "Loader"
Protected Overrides Sub LoadUserInformation_OptionalFields(ByRef Container As XmlFile, ByVal Loading As Boolean)
@@ -136,6 +145,8 @@ Namespace API.Instagram
TaggedChecked = .Value(Name_TaggedChecked).FromXML(Of Boolean)(False)
ForceUpdateUserName = .Value(Name_ForceUpdateUserName).FromXML(Of Boolean)(False)
ForceUpdateUserInfo = .Value(Name_ForceUpdateUserInfo).FromXML(Of Boolean)(False)
IsVerifiedProfile = .Value(Name_IsVerifiedProfile).FromXML(Of Boolean)(False)
IsVerifiedProfile_Checked = .Value(Name_IsVerifiedProfile_Checked).FromXML(Of Boolean)(False)
Else
.Add(Name_LastCursor, LastCursor)
.Add(Name_FirstLoadingDone, FirstLoadingDone.BoolToInteger)
@@ -153,6 +164,8 @@ Namespace API.Instagram
.Add(Name_TaggedChecked, TaggedChecked.BoolToInteger)
.Add(Name_ForceUpdateUserName, ForceUpdateUserName.BoolToInteger)
.Add(Name_ForceUpdateUserInfo, ForceUpdateUserInfo.BoolToInteger)
.Add(Name_IsVerifiedProfile, IsVerifiedProfile.BoolToInteger)
.Add(Name_IsVerifiedProfile_Checked, IsVerifiedProfile_Checked.BoolToInteger)
End If
End With
End Sub
@@ -164,7 +177,7 @@ Namespace API.Instagram
Friend Overrides Sub ExchangeOptionsSet(ByVal Obj As Object)
If Not Obj Is Nothing AndAlso TypeOf Obj Is EditorExchangeOptions Then
With DirectCast(Obj, EditorExchangeOptions)
.ApplyBase(Me)
.Apply(Me)
GetTimeline = .GetTimeline
GetReels = .GetReels
GetStories = .GetStories
@@ -179,6 +192,9 @@ Namespace API.Instagram
PutImageVideoFolder = .PutImageVideoFolder
IsVerifiedProfile = .IsVerifiedProfile
If IsVerifiedProfile Then IsVerifiedProfile_Checked = True
ForceUpdateUserName = .ForceUpdateUserName
ForceUpdateUserInfo = .ForceUpdateUserInfo
End With
@@ -317,6 +333,7 @@ Namespace API.Instagram
Private _LastWwwClaim As String = String.Empty
Private _ResponserGQLMode As Boolean = False
Private _UseGQL As Boolean = False
Private Const ImgHeic$ = "heic"
Private Sub ChangeResponserMode(ByVal GQL As Boolean, Optional ByVal Force As Boolean = False)
If Not _ResponserGQLMode = GQL Or Force Then
_ResponserGQLMode = GQL
@@ -346,8 +363,7 @@ Namespace API.Instagram
With .Headers
.Remove("origin")
.Remove("authority")
.Remove(GQL_HEADER_FB_FRINDLY_NAME)
.Remove(GQL_HEADER_FB_LSD)
UpdateHeadersGQL(String.Empty, False)
Dim hv$ = MySiteSettings.Responser.Headers.Value(HttpHeaderCollection.GetSpecialHeader(MyHeaderTypes.SecFetchDest)).IfNullOrEmpty("empty")
.Add(HttpHeaderCollection.GetSpecialHeader(MyHeaderTypes.SecFetchDest, hv))
hv = MySiteSettings.Responser.Headers.Value(HttpHeaderCollection.GetSpecialHeader(MyHeaderTypes.SecFetchMode)).IfNullOrEmpty("cors")
@@ -491,26 +507,26 @@ Namespace API.Instagram
If Not errorFound Then LoadSavePostsKV(False)
End Try
End Sub
'TODELETE: ValidateExtension
Protected Sub ValidateExtension()
Dim tmpList As List(Of UserMedia) = Nothing
Try
Const heic$ = "heic"
If _TempMediaList.Count > 0 AndAlso _TempMediaList.Exists(Function(mm) mm.File.Extension = heic) Then
Dim m As UserMedia
tmpList = New List(Of UserMedia)
tmpList.ListAddList(_TempMediaList)
_TempMediaList.Clear()
For i% = 0 To tmpList.Count - 1
m = tmpList(i)
_TempMediaList.Add(m)
If m.Type = UTypes.Picture AndAlso Not m.File.Extension.IsEmptyString AndAlso m.File.Extension = heic Then _
m.File.Extension = "jpg" : _TempMediaList.Add(m)
Next
tmpList.Clear()
End If
Catch ex As Exception
If tmpList.ListExists Then _TempMediaList.Clear() : _TempMediaList.ListAddList(tmpList) : tmpList.Clear()
End Try
'Dim tmpList As List(Of UserMedia) = Nothing
'Try
' If _TempMediaList.Count > 0 AndAlso _TempMediaList.Exists(Function(mm) mm.File.Extension = ImgHeic) Then
' Dim m As UserMedia
' tmpList = New List(Of UserMedia)
' tmpList.ListAddList(_TempMediaList)
' _TempMediaList.Clear()
' For i% = 0 To tmpList.Count - 1
' m = tmpList(i)
' _TempMediaList.Add(m)
' If m.Type = UTypes.Picture AndAlso Not m.File.Extension.IsEmptyString AndAlso m.File.Extension = ImgHeic Then _
' m.File.Extension = "jpg" : _TempMediaList.Add(m)
' Next
' tmpList.Clear()
' End If
'Catch ex As Exception
' If tmpList.ListExists Then _TempMediaList.Clear() : _TempMediaList.ListAddList(tmpList) : tmpList.Clear()
'End Try
End Sub
Protected Overridable Sub UpdateResponser()
Try
@@ -525,7 +541,7 @@ Namespace API.Instagram
Protected Overrides Sub Responser_ResponseReceived(ByVal Sender As Object, ByVal e As EventArguments.WebDataResponse)
Declarations.UpdateResponser(e, Responser, WwwClaimUpdate)
End Sub
Friend Enum Sections : Timeline : Reels : Tagged : Stories : UserStories : SavedPosts : End Enum
Friend Enum Sections : Timeline : Reels : Tagged : Stories : UserStories : SavedPosts : Reposts : Likes : End Enum
Protected Const StoriesFolder As String = "Stories"
Private Const TaggedFolder As String = "Tagged"
#Region "429 bypass"
@@ -663,6 +679,7 @@ Namespace API.Instagram
Dim StoriesList As List(Of String) = Nothing
Dim StoriesRequested As Boolean = False
Dim dValue% = 1
Dim __idIsEmpty As Boolean = ID.IsEmptyString
LastCursor = Cursor
Try
Do While dValue = 1
@@ -676,7 +693,6 @@ Namespace API.Instagram
Dim HasNextPage As Boolean = False
Dim EndCursor$ = String.Empty
Dim PostID$ = String.Empty, PostDate$ = String.Empty, SpecFolder$ = String.Empty
Dim TokensErrData$ = String.Empty
Dim PostIDKV As PostKV
Dim ENode() As Object = Nothing
Dim processGetResponse As Boolean = True
@@ -684,14 +700,11 @@ Namespace API.Instagram
'Check environment
If Not IsSavedPosts Then
If ID.IsEmptyString Then GetUserData()
If ID.IsEmptyString Then UserExists = False : _ForceSaveUserInfoOnException = True : Throw New Plugin.ExitException("can't get user ID")
If _UseGQL And Cursor.IsEmptyString And Not Section = Sections.SavedPosts Then
If Not ValidateBaseTokens() Then GetPageTokens()
If Not ValidateBaseTokens(TokensErrData) Then ValidateBaseTokens_Error(TokensErrData)
End If
If ForceUpdateUserName Then GetUserNameById()
If ForceUpdateUserInfo Then GetUserData()
If _UseGQL And Cursor.IsEmptyString And Not Section = Sections.SavedPosts Then UpdateTokens(True)
If ID.IsEmptyString Or __idIsEmpty Or Not IsVerifiedProfile_Checked Then GetUserData(Token)
If ID.IsEmptyString Then UserExists = False : _ForceSaveUserInfo = True : Throw New Plugin.ExitException("can't get user ID")
If ForceUpdateUserName Then GetUserNameById(Token)
If ForceUpdateUserInfo Then GetUserData(Token)
End If
'Create query
@@ -703,7 +716,7 @@ Namespace API.Instagram
MySiteSettings.TooManyRequests(False)
GoTo NextPageBlock
Else
URL = $"https://www.instagram.com/api/v1/feed/user/{NameTrue}/username/?count=50" &
URL = $"https://www.instagram.com/api/v1/feed/user/{NameTrue}/username/?count={PostNumberPerRequest}" &
If(Cursor.IsEmptyString, String.Empty, $"&max_id={Cursor}")
ENode = Nothing
End If
@@ -714,7 +727,7 @@ Namespace API.Instagram
processGetResponse = False
Case Sections.SavedPosts
ChangeResponserMode(False)
EndCursor = SavedPostsDownload(String.Empty, Token)
EndCursor = DownloadSavedPosts(Cursor, Token)
HasNextPage = Not EndCursor.IsEmptyString
MySiteSettings.TooManyRequests(False)
ThrowAny(Token)
@@ -726,7 +739,7 @@ Namespace API.Instagram
ENode = {"data", "xdt_api__v1__usertags__user_id__feed_connection"}
processGetResponse = False
Else
Dim vars$ = "{""id"":" & ID & ",""first"":50,""after"":""" & Cursor & """}"
Dim vars$ = "{""id"":" & ID & $",""first"":{PostNumberPerRequest},""after"":""" & Cursor & """}"
vars = SymbolsConverter.ASCII.EncodeSymbolsOnly(vars)
URL = $"https://www.instagram.com/graphql/query/?doc_id=17946422347485809&variables={vars}"
ENode = {"data", "user", "edge_user_to_photos_of_you"}
@@ -952,7 +965,7 @@ NextPageBlock:
End Try
End Sub
''' <summary>Cursor</summary>
Private Function SavedPostsDownload(ByVal Cursor As String, ByVal Token As CancellationToken) As String
Private Function DownloadSavedPosts(ByVal Cursor As String, ByVal Token As CancellationToken) As String
Dim URL$ = $"https://www.instagram.com/api/v1/feed/saved/posts/?max_id={Cursor}"
Dim HasNextPage As Boolean = False
Dim NextCursor$ = String.Empty
@@ -1241,25 +1254,38 @@ NextPageBlock:
End Sub
#End Region
#Region "GetUserId, GetUserName"
Private Sub GetUserData()
Private Sub GetUserData(ByVal Token As CancellationToken)
Dim __idFound As Boolean = False
If ForceUpdateUserInfo Then ForceUpdateUserInfo = False : _ForceSaveUserInfo = True
Try
Dim r$
Dim ____dataGql As Boolean = _UseGQL Or CBool(MySiteSettings.USE_GQL_UserData.Value)
If ____dataGql Then
UpdateTokens(True)
r = GetUserDataGQL(Token)
If Not _UseGQL Then ChangeResponserMode(_UseGQL)
Else
ChangeResponserMode(False)
UpdateRequestNumber()
Dim r$ = Responser.GetResponse($"https://i.instagram.com/api/v1/users/web_profile_info/?username={NameTrue}")
r = Responser.GetResponse($"https://i.instagram.com/api/v1/users/web_profile_info/?username={NameTrue}")
End If
If Not r.IsEmptyString Then
Using j As EContainer = JsonDocument.Parse(r)
If Not j Is Nothing AndAlso j.Contains({"data", "user"}) Then
With j({"data", "user"})
ID = .Value("id")
If Not ____dataGql Or ID.IsEmptyString Then ID = .Value("id")
__idFound = True
If Not .Value("username").IsEmptyString Then NameTrue = .Value("username")
UserSiteNameUpdate(.Value("full_name"))
IsVerifiedProfile = .Value("is_verified").FromXML(Of Boolean)(False)
IsVerifiedProfile_Checked = True
Dim descr$ = .Value("biography")
If If(.Item("bio_links")?.Count, 0) > 0 Then descr.StringAppend(.Item("bio_links").Select(Function(bl) bl.Value("url")).ListToString(vbNewLine), vbNewLine)
Dim eUrl$ = .Value("external_url")
If Not eUrl.IsEmptyString AndAlso (descr.IsEmptyString OrElse Not descr.Contains(eUrl)) Then descr.StringAppendLine(eUrl)
UserDescriptionUpdate(descr)
Dim f As New SFile With {.Path = DownloadContentDefault_GetRootDir(), .Name = "ProfilePicture", .Extension = "jpg"}
f = SFile.IndexReindex(f)
If Not f.Exists Then
@@ -1283,9 +1309,17 @@ NextPageBlock:
ChangeResponserMode(_UseGQL)
End Try
End Sub
Private Function GetUserNameById() As Boolean
Private Function GetUserNameById(ByVal Token As CancellationToken) As Boolean
UserNameRequested = True
If ForceUpdateUserName Then ForceUpdateUserName = False : _ForceSaveUserInfo = True
If Not ID.IsEmptyString Then
Dim currentName$ = NameTrue
GetUserData(Token)
If Not currentName = NameTrue Then UserNameRequested = False : Return True
End If
Return False
Try
If Not ID.IsEmptyString Then
UpdateRequestNumber()
@@ -1319,6 +1353,7 @@ NextPageBlock:
#Region "Pinned stories"
Private Sub GetStoriesData(ByRef StoriesList As List(Of String), ByVal GetUserStory As Boolean, ByVal Token As CancellationToken)
Const ReqUrl$ = "https://i.instagram.com/api/v1/feed/reels_media/?{0}"
Const hPattern$ = "highlight:"
Dim tmpList As IEnumerable(Of String) = Nothing
Dim qStr$, r$
Dim i% = -1
@@ -1331,7 +1366,7 @@ NextPageBlock:
If GetUserStory Then
qStr = $"https://www.instagram.com/api/v1/feed/reels_media/?reel_ids={ID}"
Else
qStr = String.Format(ReqUrl, tmpList.Select(Function(q) $"reel_ids=highlight:{q}").ListToString("&"))
qStr = String.Format(ReqUrl, tmpList.Select(Function(q) $"reel_ids={hPattern}{q.Replace(hPattern, String.Empty)}").ListToString("&"))
End If
UpdateRequestNumber()
r = Responser.GetResponse(qStr,, EDP.ThrowException)
@@ -1380,6 +1415,11 @@ NextPageBlock:
End If
End Sub
Private Function GetStoriesList() As List(Of String)
If CBool(MySiteSettings.USE_GQL_Highlights.Value) Then
Dim hList As List(Of String) = GetHighlightsGQL_List()
If Not _UseGQL Then ChangeResponserMode(_UseGQL)
Return hList
Else
UpdateRequestNumber()
Dim r$ = Responser.GetResponse($"https://i.instagram.com/api/v1/highlights/{ID}/highlights_tray/",, EDP.ThrowException)
If Not r.IsEmptyString Then
@@ -1389,12 +1429,20 @@ NextPageBlock:
End Using
End If
Return Nothing
End If
End Function
#End Region
#Region "Download content"
Protected Overrides Sub DownloadContent(ByVal Token As CancellationToken)
DownloadContentDefault(Token)
End Sub
Protected Overrides Function DownloadContentDefault_ConvertWebp(ByVal m As UserMedia, ByVal Process As Boolean) As SFile
If m.Type = UTypes.Picture AndAlso Not m.File.Extension.IsEmptyString AndAlso m.File.Extension = ImgHeic Then
Return DownloadContentDefault_ConvertWebp_Impl(m, True, True)
Else
Return MyBase.DownloadContentDefault_ConvertWebp(m, Process)
End If
End Function
#End Region
#Region "Erase"
Protected Overrides Sub EraseData_AdditionalDataFiles()
@@ -1417,7 +1465,7 @@ NextPageBlock:
Protected Overrides Function DownloadingException(ByVal ex As Exception, ByVal Message As String, Optional ByVal FromPE As Boolean = False,
Optional ByVal s As Object = Nothing) As Integer
If Responser.StatusCode = HttpStatusCode.NotFound Then '404
If Not UserNameRequested AndAlso GetUserNameById() Then Return 1 Else UserExists = False
If Not UserNameRequested AndAlso GetUserNameById(New CancellationToken) Then Return 1 Else UserExists = False
ElseIf Responser.StatusCode = HttpStatusCode.BadRequest Or Responser.StatusCode = HttpStatusCode.Unauthorized Then '400, 401
HasError = True
MyMainLOG = $"Instagram credentials have expired [{CInt(Responser.StatusCode)}]: {ToStringForLog()} [{s}]"
@@ -1434,7 +1482,7 @@ NextPageBlock:
MyMainLOG = $"Number of requests before error 429: {RequestsCount}"
Return 1
ElseIf Responser.StatusCode = 560 Or Responser.StatusCode = HttpStatusCode.InternalServerError Then '560, 500
If Responser.StatusCode = 560 And s = Sections.Stories And MySiteSettings.IgnoreStoriesDownloadingErrors Then
If Responser.StatusCode = 560 And s = Sections.Stories And MySiteSettings.IgnoreStoriesDownloadingErrors.Value Then
MyMainLOG = $"{ToStringForLog()}: Stories downloading skipped (560)"
Return ErrHandlingValueStories
Else

View File

@@ -1,48 +0,0 @@
' Copyright (C) 2023 Andy https://github.com/AAndyProgram
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation, either version 3 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports PersonalUtilities.Functions.XML
Imports PersonalUtilities.Functions.XML.Base
Namespace API.Mastodon
Friend Structure Credentials : Implements IEContainerProvider
Private Const Name_Bearer As String = "Bearer"
Private Const Name_Csrf As String = "Csrf"
Friend Domain As String
Friend Bearer As String
Friend Csrf As String
Friend ReadOnly Property Exists As Boolean
Get
Return Not Domain.IsEmptyString And Not Bearer.IsEmptyString And Not Csrf.IsEmptyString
End Get
End Property
Private Sub New(ByVal e As EContainer)
Domain = e.Value
Bearer = e.Attribute(Name_Bearer)
Csrf = e.Attribute(Name_Csrf)
End Sub
Public Shared Widening Operator CType(ByVal e As EContainer) As Credentials
Return New Credentials(e)
End Operator
Public Shared Widening Operator CType(ByVal Domain As String) As Credentials
Return New Credentials With {.Domain = Domain}
End Operator
Private Function ToEContainer(Optional ByVal e As ErrorsDescriber = Nothing) As EContainer Implements IEContainerProvider.ToEContainer
Return New EContainer("Item", Domain, {New EAttribute(Name_Bearer, Bearer), New EAttribute(Name_Csrf, Csrf)})
End Function
Public Overrides Function Equals(ByVal Obj As Object) As Boolean
If Not IsNothing(Obj) Then
If TypeOf Obj Is Credentials Then
Return Domain = DirectCast(Obj, Credentials).Domain
Else
Return Domain = CStr(Obj)
End If
End If
Return False
End Function
End Structure
End Namespace

View File

@@ -1,14 +0,0 @@
' Copyright (C) 2023 Andy https://github.com/AAndyProgram
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation, either version 3 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Namespace API.Mastodon
Friend Module Declarations
Friend Const MastodonSiteKey As String = "AndyProgram_Mastodon"
Friend ReadOnly DateProvider As New ADateTime("O")
End Module
End Namespace

View File

@@ -1,27 +0,0 @@
' Copyright (C) 2023 Andy https://github.com/AAndyProgram
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation, either version 3 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports SCrawler.Plugin.Attributes
Namespace API.Mastodon
Friend Class EditorExchangeOptions : Inherits Twitter.EditorExchangeOptions
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property MediaModelAllowNonUserTweets As Boolean
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property DownloadModelMedia As Boolean
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property DownloadModelProfile As Boolean
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property DownloadModelSearch As Boolean
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property DownloadModelForceApply As Boolean
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property DownloadModelLikes As Boolean
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property DownloadBroadcasts As Boolean
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property UserName As String
Friend Sub New(ByVal s As SiteSettings)
MyBase.New(s)
End Sub
Friend Sub New(ByVal u As UserData)
MyBase.New(u)
End Sub
End Class
End Namespace

View File

@@ -1,253 +0,0 @@
' Copyright (C) 2023 Andy https://github.com/AAndyProgram
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation, either version 3 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports SCrawler.API.Base
Imports SCrawler.Plugin
Imports SCrawler.Plugin.Attributes
Imports PersonalUtilities.Functions.XML
Imports PersonalUtilities.Functions.RegularExpressions
Imports PersonalUtilities.Tools.Web.Clients
Imports PersonalUtilities.Tools.Web.Documents.JSON
Imports DN = SCrawler.API.Base.DeclaredNames
Namespace API.Mastodon
<Manifest(MastodonSiteKey), SavedPosts, SpecialForm(True), SpecialForm(False)>
Friend Class SiteSettings : Inherits SiteSettingsBase
#Region "Declarations"
#Region "Domains"
<PXML("Domains"), PClonable> Private ReadOnly Property SiteDomains As PropertyValue
Private Shadows ReadOnly Property DefaultInstance As SiteSettings
Get
Return MyBase.DefaultInstance
End Get
End Property
Private ReadOnly _Domains As DomainsContainer
Friend ReadOnly Property Domains As DomainsContainer
Get
Return If(DefaultInstance?.Domains, _Domains)
End Get
End Property
<PXML("DomainsLastUpdateDate")> Private ReadOnly Property Base_DomainsLastUpdateDate As PropertyValue
Private ReadOnly Property DomainsLastUpdateDate As PropertyValue
Get
Return If(DefaultInstance?.DomainsLastUpdateDate, Base_DomainsLastUpdateDate)
End Get
End Property
#End Region
#Region "Auth"
<PropertyOption(IsAuth:=True, AllowNull:=False, ControlText:="My domain",
ControlToolTip:="Your account domain without 'https://' (for example, 'mastodon.social')"), PXML, PClonable(Clone:=False)>
Friend ReadOnly Property MyDomain As PropertyValue
<PropertyOption(AllowNull:=False, IsAuth:=True, ControlText:="Authorization",
ControlToolTip:="Set authorization from [authorization] response header. This field must start from [Bearer] key word"), PClonable(Clone:=False)>
Friend ReadOnly Property Auth As PropertyValue
<PropertyOption(AllowNull:=False, IsAuth:=True, ControlText:="Token", ControlToolTip:="Set token from [x-csrf-token] response header"), PClonable(Clone:=False)>
Friend ReadOnly Property Token As PropertyValue
Private Sub ChangeResponserFields(ByVal PropName As String, ByVal Value As Object)
If Not PropName.IsEmptyString Then
Dim f$ = String.Empty
Select Case PropName
Case NameOf(Auth) : f = DN.Header_Authorization
Case NameOf(Token) : f = DN.Header_CSRFToken
End Select
If Not f.IsEmptyString Then
Responser.Headers.Remove(f)
If Not CStr(Value).IsEmptyString Then Responser.Headers.Add(f, CStr(Value))
Responser.SaveSettings()
End If
End If
End Sub
#End Region
#Region "Other properties"
<PropertyOption(IsAuth:=False, ControlText:=DN.GifsDownloadCaption, Category:=DN.CAT_UserDefs), PXML, PClonable>
Friend ReadOnly Property GifsDownload As PropertyValue
<PropertyOption(IsAuth:=False, ControlText:=DN.GifsSpecialFolderCaption, ControlToolTip:=DN.GifsSpecialFolderToolTip, Category:=DN.CAT_UserDefs), PXML, PClonable>
Friend ReadOnly Property GifsSpecialFolder As PropertyValue
<PropertyOption(IsAuth:=False, ControlText:=DN.GifsPrefixCaption, ControlToolTip:=DN.GifsPrefixToolTip, Category:=DN.CAT_UserDefs), PXML, PClonable>
Friend ReadOnly Property GifsPrefix As PropertyValue
<Provider(NameOf(GifsSpecialFolder), Interaction:=True), Provider(NameOf(GifsPrefix), Interaction:=True)>
Private ReadOnly Property GifStringChecker As IFormatProvider
<PropertyOption(IsAuth:=False, ControlText:=DN.UseMD5ComparisonCaption, ControlToolTip:=DN.UseMD5ComparisonToolTip, Category:=DN.CAT_UserDefs), PXML, PClonable>
Friend ReadOnly Property UseMD5Comparison As PropertyValue
<PropertyOption(IsAuth:=False, ControlText:="User related to my domain",
ControlToolTip:="Open user profiles and user posts through my domain."), PXML, PClonable>
Friend ReadOnly Property UserRelatedToMyDomain As PropertyValue
<DoNotUse> Friend Overrides Property DownloadText As PropertyValue
<DoNotUse> Friend Overrides Property DownloadTextPosts As PropertyValue
<DoNotUse> Friend Overrides Property DownloadTextSpecialFolder As PropertyValue
#End Region
#End Region
#Region "Initializer"
Friend Sub New(ByVal AccName As String, ByVal Temp As Boolean)
MyBase.New("Mastodon", "mastodon.social", AccName, Temp, My.Resources.SiteResources.MastodonIcon_48, My.Resources.SiteResources.MastodonPic_48)
_Domains = New DomainsContainer(Me, "mastodon.social")
SiteDomains = New PropertyValue(Domains.DomainsDefault, GetType(String))
Domains.DestinationProp = SiteDomains
Base_DomainsLastUpdateDate = New PropertyValue(Now.AddYears(-1))
Auth = New PropertyValue(Responser.Headers.Value(DN.Header_Authorization), GetType(String), Sub(v) ChangeResponserFields(NameOf(Auth), v))
Token = New PropertyValue(Responser.Headers.Value(DN.Header_CSRFToken), GetType(String), Sub(v) ChangeResponserFields(NameOf(Token), v))
GifsDownload = New PropertyValue(True)
GifsSpecialFolder = New PropertyValue(String.Empty, GetType(String))
GifsPrefix = New PropertyValue("GIF_")
GifStringChecker = New API.Twitter.SiteSettings.GifStringProvider
UseMD5Comparison = New PropertyValue(False)
MyDomain = New PropertyValue(String.Empty, GetType(String))
UserRelatedToMyDomain = New PropertyValue(False)
UserRegex = RParams.DMS("", 0, RegexReturn.ListByMatch, EDP.ReturnValue)
End Sub
Friend Overrides Sub EndInit()
Domains.PopulateInitialDomains(SiteDomains.Value)
If CDate(DomainsLastUpdateDate.Value).AddDays(7) < Now Then UpdateServersList()
MyBase.EndInit()
End Sub
#End Region
#Region "GetInstance"
Friend Overrides Function GetInstance(ByVal What As ISiteSettings.Download) As IPluginContentProvider
Return New UserData
End Function
#End Region
#Region "Domains Support"
Protected Overrides Sub DomainsApply()
Domains.Apply()
MyBase.DomainsApply()
End Sub
Protected Overrides Sub DomainsReset()
Domains.Reset()
MyBase.DomainsReset()
End Sub
Friend Overrides Sub OpenSettingsForm()
Domains.OpenSettingsForm()
End Sub
#End Region
#Region "Update"
Friend Overrides Sub Update()
If _SiteEditorFormOpened Then
Dim tf$ = GifsSpecialFolder.Value
If Not tf.IsEmptyString Then tf = tf.StringTrim("\") : GifsSpecialFolder.Value = tf
Dim md$ = AConvert(Of String)(MyDomain.Value, String.Empty)
If Not md.IsEmptyString AndAlso Not Domains.Domains.Contains(md) AndAlso Not Domains.DomainsTemp.Contains(md) Then
If Domains.Changed Then
Domains.DomainsTemp.Add(md)
Else
Domains.Domains.Add(md)
Domains.Save()
End If
End If
End If
MyBase.Update()
End Sub
#End Region
#Region "UserOptions"
Friend Overrides Sub UserOptions(ByRef Options As Object, ByVal OpenForm As Boolean)
If Options Is Nothing OrElse (Not TypeOf Options Is EditorExchangeOptions OrElse
Not DirectCast(Options, EditorExchangeOptions).SiteKey = MastodonSiteKey) Then _
Options = New EditorExchangeOptions(Me) With {.SiteKey = MastodonSiteKey}
If OpenForm Then
Using f As New InternalSettingsForm(Options, Me, False) : f.ShowDialog() : End Using
End If
End Sub
#End Region
#Region "Download"
Friend Overrides Function BaseAuthExists() As Boolean
Return ACheck(Token.Value) And ACheck(Auth.Value) And ACheck(MyDomain.Value)
End Function
Friend Overrides Function Available(ByVal What As ISiteSettings.Download, ByVal Silent As Boolean) As Boolean
If What = ISiteSettings.Download.SavedPosts Or What = ISiteSettings.Download.SingleObject Then
If Not ACheck(MyDomain.Value) Then MyMainLOG = "Mastodon account domain not set" : Return False
Else
If CDate(DomainsLastUpdateDate.Value).AddDays(7) < Now Then UpdateServersList()
End If
Return MyBase.Available(What, Silent)
End Function
#End Region
#Region "GetUserUrl, GetUserPostUrl"
Friend Overrides Function GetUserUrl(ByVal User As IPluginContentProvider) As String
If Not ACheck(MyDomain.Value) Then Return String.Empty
With DirectCast(User, UserData)
If UserRelatedToMyDomain.Value Then
If MyDomain.Value = .UserDomain Then
Return $"https://{ .UserDomain}/@{ .NameTrue}"
Else
Return $"https://{MyDomain.Value}/@{ .NameTrue}@{ .UserDomain}"
End If
Else
Return $"https://{ .UserDomain}/@{ .NameTrue}"
End If
End With
End Function
Friend Overrides Function GetUserPostUrl(ByVal User As UserDataBase, ByVal Media As UserMedia) As String
If Not ACheck(MyDomain.Value) Then Return String.Empty
Return $"{GetUserUrl(User)}/{Media.Post.ID}"
End Function
#End Region
#Region "IsMyUser, IsMyImageVideo"
Private Const UserRegexDefault As String = "https?://{0}/@([^/@]+)@?([^/]*)"
Friend Overloads Overrides Function IsMyUser(ByVal UserURL As String) As ExchangeOptions
If Domains.Count > 0 Then
Dim e As ExchangeOptions
If ACheck(MyDomain.Value) Then
e = IsMyUser(UserURL, MyDomain.Value)
If Not e.SiteName.IsEmptyString Then Return e
End If
For Each domain$ In Domains
e = IsMyUser(UserURL, domain)
If Not e.SiteName.IsEmptyString Then Return e
Next
End If
Return Nothing
End Function
Private Overloads Function IsMyUser(ByVal UserURL As String, ByVal Domain As String) As ExchangeOptions
UserRegex.Pattern = String.Format(UserRegexDefault, Domain)
Dim l As List(Of String) = RegexReplace(UserURL, UserRegex)
If l.ListExists(2) Then Return New ExchangeOptions(Site, $"{l(2).IfNullOrEmpty(Domain)}@{l(1)}") Else Return Nothing
End Function
Friend Overrides Function IsMyImageVideo(ByVal URL As String) As ExchangeOptions
If Not URL.IsEmptyString And Domains.Count > 0 Then
Dim urlDomain$ = RegexReplace(URL, RParams.DM("[^/]+", 1, EDP.ReturnValue, String.Empty))
If Not urlDomain.IsEmptyString Then
urlDomain = urlDomain.StringToLower
If Domains.Domains.Exists(Function(d) urlDomain = d.StringToLower) Then Return New ExchangeOptions(Site, URL) With {.Exists = True}
End If
End If
Return Nothing
End Function
#End Region
#Region "UpdateServersList"
Private Sub UpdateServersList()
Try
Using resp As New Responser With {
.ProcessExceptionDecision = Function(rr, obj, e) If(rr.StatusCode = Net.HttpStatusCode.ServiceUnavailable,
EDP.ReturnValue, EDP.ThrowException)}
Dim r$ = resp.GetResponse("https://api.joinmastodon.org/servers?language=&category=&region=&ownership=&registrations=")
If Not r.IsEmptyString Then
Dim j As EContainer = JsonDocument.Parse(r, EDP.ReturnValue)
If If(j?.Count, 0) > 0 Then
Domains.Domains.ListAddList(j.Select(Function(e) e.Value("domain")), LAP.NotContainsOnly, EDP.ReturnValue)
Domains.Domains.Sort()
Domains.Save()
j.Dispose()
End If
DomainsLastUpdateDate.Value = Now
End If
End Using
Catch ex As Exception
ErrorsDescriber.Execute(EDP.SendToLog, ex, "[API.Mastodon.SiteSettings.UpdateServersList]")
End Try
End Sub
#End Region
#Region "IDisposable Support"
Protected Overrides Sub Dispose(ByVal disposing As Boolean)
If Not disposedValue And disposing Then _Domains.Dispose()
MyBase.Dispose(disposing)
End Sub
#End Region
End Class
End Namespace

View File

@@ -1,319 +0,0 @@
' Copyright (C) 2023 Andy https://github.com/AAndyProgram
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation, either version 3 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports System.Threading
Imports SCrawler.API.Base
Imports SCrawler.API.YouTube.Objects
Imports PersonalUtilities.Functions.XML
Imports PersonalUtilities.Functions.RegularExpressions
Imports PersonalUtilities.Tools.Web.Documents.JSON
Imports UTypes = SCrawler.API.Base.UserMedia.Types
Imports UStates = SCrawler.API.Base.UserMedia.States
Namespace API.Mastodon
Friend Class UserData : Inherits Twitter.UserData
#Region "XML names"
Private Const Name_UserDomain As String = "UserDomain"
#End Region
#Region "Declarations"
Private _UserDomain As String = String.Empty
Friend Property UserDomain As String
Get
Return _UserDomain.IfNullOrEmpty(MySettings.MyDomain.Value)
End Get
Set(ByVal d As String)
_UserDomain = d
End Set
End Property
Private ReadOnly Property MySettings As SiteSettings
Get
Return HOST.Source
End Get
End Property
Private MyCredentials As Credentials
Private Sub ResetCredentials()
MyCredentials = New Credentials With {.Domain = MySettings.MyDomain.Value, .Bearer = MySettings.Auth.Value, .Csrf = MySettings.Token.Value}
With MyCredentials
Responser.Headers.Add(DeclaredNames.Header_Authorization, .Bearer)
Responser.Headers.Add(DeclaredNames.Header_CSRFToken, .Csrf)
End With
End Sub
#End Region
#Region "LoadUserInformation"
Protected Overrides Sub LoadUserInformation_OptionalFields(ByRef Container As XmlFile, ByVal Loading As Boolean)
MyBase.LoadUserInformation_OptionalFields(Container, Loading)
Dim obtainNames As Action = Sub()
If _UserDomain.IsEmptyString And Not Name.IsEmptyString Then
Dim l$() = Name.Split("@")
If l.ListExists(2) Then
_UserDomain = l(0)
NameTrue = l(1)
Else
_UserDomain = MySettings.MyDomain.Value
NameTrue = Name
End If
If FriendlyName.IsEmptyString Then FriendlyName = NameTrue
End If
End Sub
If Loading Then
_UserDomain = Container.Value(Name_UserDomain)
obtainNames.Invoke
Else
obtainNames.Invoke
Container.Add(Name_UserDomain, _UserDomain)
Container.Add(Name_TrueName, NameTrue(True))
Container.Value(Name_FriendlyName) = FriendlyName
End If
End Sub
#End Region
#Region "Download functions"
Protected Overrides Sub DownloadDataF(ByVal Token As CancellationToken)
ResetCredentials()
DownloadData(String.Empty, Token)
End Sub
Private Overloads Sub DownloadData(ByVal POST As String, ByVal Token As CancellationToken)
Dim URL$ = String.Empty
Try
Dim PostID$ = String.Empty
Dim PostDate$
Dim s As EContainer, ss As EContainer
Dim NewPostDetected As Boolean = False
Dim ExistsDetected As Boolean = False
If IsSavedPosts Then
URL = $"https://{MySettings.MyDomain.Value}/api/v1/bookmarks"
If Not POST.IsEmptyString Then URL &= $"?max_id={POST}"
Else
If POST.IsEmptyString And ID.IsEmptyString Then
ObtainUserID()
If ID.IsEmptyString Then Throw New ArgumentNullException("ID", "Unable to get user ID") With {.HelpLink = 1}
End If
URL = $"https://{MyCredentials.Domain}/api/v1/accounts/{ID}/statuses?"
If ParseUserMediaOnly Then URL &= "only_media=true&"
URL &= "limit=40"
If Not POST.IsEmptyString Then URL &= $"&max_id={POST}"
End If
ThrowAny(Token)
Dim r$ = Responser.GetResponse(URL)
If Not r.IsEmptyString Then
Using j As EContainer = JsonDocument.Parse(r)
If If(j?.Count, 0) > 0 Then
ProgressPre.ChangeMax(j.Count)
For Each jj As EContainer In j
ProgressPre.Perform()
With jj
If Not IsSavedPosts And POST.IsEmptyString And Not .Item("account") Is Nothing Then
With .Item("account")
If .Value("id") = ID Then
UserSiteNameUpdate(.Value("display_name"))
UserDescriptionUpdate(.Value("note"))
Dim __getImage As Action(Of String) = Sub(ByVal img As String)
If Not img.IsEmptyString Then
Dim __imgFile As SFile = img
If Not __imgFile.Name.IsEmptyString Then
If __imgFile.Extension.IsEmptyString Then __imgFile.Extension = "jpg"
__imgFile.Path = MyFile.CutPath.Path
If Not __imgFile.Exists Then GetWebFile(img, __imgFile, EDP.None)
If __imgFile.Exists Then IconBannerDownloaded = True
End If
End If
End Sub
If DownloadIconBanner Then
__getImage.Invoke(.Value("header").IfNullOrEmpty(.Value("header_static")))
__getImage.Invoke(.Value("avatar").IfNullOrEmpty(.Value("avatar_static")))
End If
End If
End With
End If
PostID = .Value("id")
PostDate = .Value("created_at")
If Not IsSavedPosts And Not PostDate.IsEmptyString Then
Select Case CheckDatesLimit(PostDate, DateProvider)
Case DateResult.Skip : Continue For
Case DateResult.Exit : Exit Sub
End Select
End If
If Not _TempPostsList.Contains(PostID) Then
NewPostDetected = True
_TempPostsList.Add(PostID)
Else
ExistsDetected = True
Continue For
End If
If IsSavedPosts OrElse (Not ParseUserMediaOnly OrElse
(If(.Item("reblog")?.Count, 0) = 0 OrElse .Value({"reblog", "account"}, "id") = ID)) Then
If If(.Item("media_attachments")?.Count, 0) > 0 Then
s = .Item("media_attachments")
Else
s = .Item({"reblog"}, "media_attachments")
End If
If s.ListExists Then
For Each ss In s : ObtainMedia(ss, PostID, PostDate) : Next
End If
End If
End With
Next
End If
End Using
End If
If POST.IsEmptyString And ExistsDetected Then Exit Sub
If Not PostID.IsEmptyString And NewPostDetected Then DownloadData(PostID, Token)
Catch ex As Exception
ProcessException(ex, Token, $"data downloading error{IIf(IsSavedPosts, " (Saved Posts)", String.Empty)} [{URL}]")
End Try
End Sub
Private Sub ObtainMedia(ByVal e As EContainer, ByVal PostID As String, ByVal PostDate As String, Optional ByVal BaseUrl As String = Nothing,
Optional ByVal SourceMedia As UserMedia = Nothing)
Dim t As UTypes = UTypes.Undefined
Select Case e.Value("type")
Case "video" : t = UTypes.Video
Case "image" : t = UTypes.Picture
Case "gifv" : t = UTypes.GIF
End Select
If Not t = UTypes.Undefined Then
Dim m As New UserMedia(e.Value("url"), t) With {
.Post = New UserPost(PostID, AConvert(Of Date)(PostDate, DateProvider, Nothing, EDP.ReturnValue)),
.URL_BASE = BaseUrl.IfNullOrEmpty(MySettings.GetUserPostUrl(Me, m))
}
If Not t = UTypes.GIF Or GifsDownload Then
If t = UTypes.GIF Then
If Not GifsSpecialFolder.IsEmptyString Then m.SpecialFolder = GifsSpecialFolder
If Not GifsPrefix.IsEmptyString Then m.File.Name = $"{GifsPrefix}{m.File.Name}"
End If
If Not m.URL.IsEmptyString Then
If SourceMedia.State = UStates.Missing Then
m.State = UStates.Missing
m.Attempts = SourceMedia.Attempts
End If
_TempMediaList.ListAddValue(m, LNC)
End If
End If
End If
End Sub
Private Sub ObtainUserID()
Try
If ID.IsEmptyString Then
Dim url$ = $"https://{MyCredentials.Domain}/api/v1/accounts/lookup?acct="
If Not UserDomain.IsEmptyString Then
If UserDomain = MyCredentials.Domain Then
url &= $"@{NameTrue}"
Else
url &= $"@{NameTrue}@{UserDomain}"
End If
Else
url &= $"@{NameTrue}"
End If
Dim r$ = Responser.GetResponse(url)
If Not r.IsEmptyString Then
Using j As EContainer = JsonDocument.Parse(r)
If Not j Is Nothing Then ID = j.Value("id")
End Using
End If
End If
Catch ex As Exception
ErrorsDescriber.Execute(EDP.SendToLog, ex, $"API.Mastodon.UserData.ObtainUserID({ToStringForLog()})")
End Try
End Sub
Private Function GetSinglePostPattern(ByVal Domain As String) As String
Return $"https://{Domain}/api/v1/statuses/" & "{0}"
End Function
Protected Overrides Sub ReparseMissing(ByVal Token As CancellationToken)
Dim rList As New List(Of Integer)
Dim URL$ = String.Empty
Try
If ContentMissingExists Then
Dim SinglePostUrl$ = GetSinglePostPattern(MyCredentials.Domain)
Dim m As UserMedia
Dim r$, PostDate$
Dim j As EContainer
ProgressPre.ChangeMax(_ContentList.Count)
For i% = 0 To _ContentList.Count - 1
ProgressPre.Perform()
If _ContentList(i).State = UStates.Missing Then
m = _ContentList(i)
If Not m.Post.ID.IsEmptyString Then
ThrowAny(Token)
URL = String.Format(SinglePostUrl, m.Post.ID)
r = Responser.GetResponse(URL,, EDP.ReturnValue)
If Not r.IsEmptyString Then
j = JsonDocument.Parse(r)
If Not j Is Nothing Then
PostDate = String.Empty
If j.Contains("created_at") Then PostDate = j("created_at").Value Else PostDate = String.Empty
ObtainMedia(j, m.Post.ID, PostDate, m.URL_BASE, m)
rList.Add(i)
j.Dispose()
End If
End If
End If
End If
Next
End If
Catch ex As Exception
ProcessException(ex, Token, $"ReparseMissing error [{URL}]")
Finally
If rList.Count > 0 Then
For i% = rList.Count - 1 To 0 Step -1 : _ContentList.RemoveAt(rList(i)) : Next
rList.Clear()
End If
End Try
End Sub
#End Region
#Region "DownloadSingleObject"
Protected Overrides Sub DownloadSingleObject_GetPosts(ByVal Data As IYouTubeMediaContainer, ByVal Token As CancellationToken)
Dim PostID$ = RegexReplace(Data.URL, RParams.DM("(?<=/)\d+", 0, EDP.ReturnValue))
If Not PostID.IsEmptyString Then
ResetCredentials()
Dim pattern$
If Not ACheck(MySettings.MyDomain.Value) Then
Throw New ArgumentNullException("Mastodon domain", "Mastodon domain not set")
Else
pattern = GetSinglePostPattern(MySettings.MyDomain.Value)
End If
Dim r$ = Responser.GetResponse(String.Format(pattern, PostID),, EDP.ReturnValue)
If Not r.IsEmptyString Then
Using j As EContainer = JsonDocument.Parse(r)
If j.ListExists AndAlso j.Contains("media_attachments") Then
For Each jj As EContainer In j("media_attachments") : ObtainMedia(jj, PostID, String.Empty, Data.URL) : Next
End If
End Using
End If
End If
End Sub
#End Region
#Region "Exception"
Protected Overrides Function DownloadingException(ByVal ex As Exception, ByVal Message As String, Optional ByVal FromPE As Boolean = False,
Optional ByVal EObj As Object = Nothing) As Integer
If TypeOf ex Is ArgumentNullException AndAlso Not ex.HelpLink.IsEmptyString And ex.HelpLink = 1 Then
Return 0
Else
If Responser.Status = Net.WebExceptionStatus.NameResolutionFailure Then
MyMainLOG = $"User domain ({UserDomain}) not found: {ToStringForLog()}"
Return 1
ElseIf Responser.StatusCode = Net.HttpStatusCode.NotFound Or Responser.StatusCode = Net.HttpStatusCode.Forbidden Then
UserExists = False
Return 1
ElseIf Responser.StatusCode = Net.HttpStatusCode.Unauthorized Then
MyMainLOG = $"{ToStringForLog()}: account credentials have expired"
Return 2
ElseIf Responser.StatusCode = Net.HttpStatusCode.Gone Then
UserSuspended = True
Return 1
Else
Return 0
End If
End If
End Function
#End Region
End Class
End Namespace

View File

@@ -17,5 +17,23 @@ Namespace API.OnlyFans
{{"files", "full", "url"}}
}
Friend Property Rules As DynamicRulesEnv
Friend Class CookieDateProvider : Implements ICustomProvider
Private ReadOnly DefaultProvider As IFormatProvider
Friend Sub New()
DefaultProvider = PersonalUtilities.Tools.Web.Cookies.CookieKeeper.DateProviderDefault
End Sub
Friend Function Convert(ByVal Value As Object, ByVal DestinationType As Type, ByVal Provider As IFormatProvider,
Optional ByVal NothingArg As Object = Nothing, Optional ByVal e As ErrorsDescriber = Nothing) As Object Implements ICustomProvider.Convert
If Not IsNothing(Value) AndAlso TypeOf Value Is String AndAlso Not CStr(Value).IsEmptyString Then
Dim v$ = Value
If v.Contains(",_") Then v = v.Substring(0, v.IndexOf(",_"))
Value = v
End If
Return AConvert(Of Date)(Value, DefaultProvider, Nothing)
End Function
Private Function GetFormat(ByVal FormatType As Type) As Object Implements IFormatProvider.GetFormat
Throw New NotImplementedException("'GetFormat' is not available in the 'CookieDateProvider'")
End Function
End Class
End Module
End Namespace

View File

@@ -219,12 +219,12 @@ Namespace API.OnlyFans
DynamicRulesXml.Extension = "xml"
ReplacePattern_RepoToRaw = New RParams("(.*github.com/([^/]+)/([^/]+)/blob/(.+))", Nothing, 0,
RegexReturn.ReplaceChangeListMatch, EDP.ReturnValue) With {
.PatternReplacement = "https://raw.githubusercontent.com/{2}/{3}/{4}"}
.PatternReplacement = "https://raw.githubusercontent.com/{2}/{3}/refs/heads/{4}"}
ReplacePattern_JsonInfo = ReplacePattern_RepoToRaw.Copy
ReplacePattern_JsonInfo.PatternReplacement = "https://github.com/{2}/{3}/latest-commit/{4}"
ReplacePattern_RawToRepo = ReplacePattern_RepoToRaw.Copy
ReplacePattern_RawToRepo.Pattern = "(.*raw.githubusercontent.com/([^/]+)/([^/]+)/([^/]+)/(.+))"
ReplacePattern_RawToRepo.PatternReplacement = "https://github.com/{2}/{3}/blob/{4}/{5}"
ReplacePattern_RawToRepo.Pattern = "(.*raw.githubusercontent.com/([^/]+)/([^/]+)(/refs/heads)?/([^/]+)/(.+))"
ReplacePattern_RawToRepo.PatternReplacement = "https://github.com/{2}/{3}/blob/{5}/{6}"
ConfigRulesExtract = RParams.DMS("DYNAMIC_RULE"":(\{.+?\}[\r\n]+)", 1, RegexOptions.Singleline, EDP.ReturnValue)
OFLOG = New TextSaver($"LOGs\OF_{Now:yyyyMMdd_HHmmss}.txt") With {.LogMode = True, .AutoSave = True, .AutoClear = True}
AddHandler OFLOG.TextSaved, AddressOf OFLOG_TextSaved

View File

@@ -99,6 +99,19 @@ Namespace API.OnlyFans
End Get
End Property
#End Region
#Region "Other"
<PClonable, PXML("OpenPostsUsingID")> Private ReadOnly Property OpenPostsUsingID_XML As PropertyValue
<PropertyOption(ControlText:="Open posts using ID", ControlToolTip:="Open posts using the user ID instead of the user name"), HiddenControl>
Private ReadOnly Property OpenPostsUsingID As PropertyValue
Get
If Not DefaultInstance Is Nothing Then
Return DirectCast(DefaultInstance, SiteSettings).OpenPostsUsingID_XML
Else
Return OpenPostsUsingID_XML
End If
End Get
End Property
#End Region
#Region "OFScraper"
<PClonable, PXML("OFScraperPath")> Private ReadOnly Property OFScraperPath_XML As PropertyValue
<PropertyOption(ControlText:="OF-Scraper path", ControlToolTip:="The path to the 'ofscraper.exe'", Category:=CAT_OFS)>
@@ -240,6 +253,7 @@ Namespace API.OnlyFans
.CookiesUpdateMode = CookieKeeper.UpdateModes.Disabled
.Cookies.ChangedAllowInternalDrop = False
.Cookies.Changed = False
.Cookies.DateProvider = New CookieDateProvider
With .Headers
.Add(HttpHeaderCollection.GetSpecialHeader(MyHeaderTypes.SecChUaPlatform))
.Add(HttpHeaderCollection.GetSpecialHeader(MyHeaderTypes.SecChUaMobile))
@@ -285,6 +299,8 @@ Namespace API.OnlyFans
UpdateRules401_XML = New PropertyValue(False)
OpenPostsUsingID_XML = New PropertyValue(True)
UserRegex = RParams.DMS(String.Format(UserRegexDefaultPattern, "onlyfans.com/"), 1, EDP.ReturnValue)
UrlPatternUser = "https://onlyfans.com/{0}"
ImageVideoContains = "onlyfans.com"
@@ -363,8 +379,9 @@ Namespace API.OnlyFans
End If
If p.IsEmptyString Then
Return GetUserUrl(User)
ElseIf CBool(OpenPostsUsingID.Value) Then
Return String.Format(UserPostPattern, p, If(User.ID.IsEmptyString, User.NameTrue, $"u{User.ID}"))
Else
'Return String.Format(UserPostPattern, p, If(User.ID.IsEmptyString, User.Name, $"u{User.ID}"))
Return String.Format(UserPostPattern, p, User.NameTrue)
End If
Else

View File

@@ -31,6 +31,7 @@ Namespace API.OnlyFans
Friend Property CCookie As CookieKeeper = Nothing
Private Const HeaderSign As String = "Sign"
Private Const HeaderTime As String = "Time"
Private Const LabelDRM As String = "DRM"
Private ReadOnly HighlightsList As List(Of String)
Friend Property MediaDownloadTimeline As Boolean = True
Friend Property MediaDownloadStories As Boolean = True
@@ -41,6 +42,11 @@ Namespace API.OnlyFans
Return HOST.Source
End Get
End Property
Friend Overrides ReadOnly Property SpecialLabels As IEnumerable(Of String)
Get
Return {LabelDRM}
End Get
End Property
#End Region
#Region "Load"
Protected Overrides Sub LoadUserInformation_OptionalFields(ByRef Container As XmlFile, ByVal Loading As Boolean)
@@ -66,7 +72,7 @@ Namespace API.OnlyFans
Friend Overrides Sub ExchangeOptionsSet(ByVal Obj As Object)
If Not Obj Is Nothing AndAlso TypeOf Obj Is UserExchangeOptions Then
With DirectCast(Obj, UserExchangeOptions)
.ApplyBase(Me)
.Apply(Me)
MediaDownloadTimeline = .DownloadTimeline
MediaDownloadStories = .DownloadStories
MediaDownloadHighlights = .DownloadHighlights
@@ -88,6 +94,7 @@ Namespace API.OnlyFans
Private _DownloadedPostsSession As Integer = 0
Private FunctionErr As Integer = FunctionErrDef
Private Const FunctionErrDef As Integer = -100
Private _TimelineDownloading As Boolean = False
Private Sub ValidateOFScraper()
_OFScraperExists = ACheck(MySettings.OFScraperPath.Value) AndAlso CStr(MySettings.OFScraperPath.Value).CSFile.Exists
End Sub
@@ -110,7 +117,9 @@ Namespace API.OnlyFans
If ID.IsEmptyString Then Throw New ArgumentNullException("ID", "Unable to get user ID")
End If
_TimelineDownloading = True
If MediaDownloadTimeline Then DownloadTimeline(IIf(IsSavedPosts, 0, String.Empty), Token)
_TimelineDownloading = False
If Not IsSavedPosts Then
If MediaDownloadStories And FunctionErr = FunctionErrDef Then DownloadStories(Token)
If MediaDownloadHighlights And FunctionErr = FunctionErrDef Then DownloadHighlights(Token)
@@ -155,8 +164,12 @@ Namespace API.OnlyFans
If IsSavedPosts Then
path = $"/api2/v2/posts/bookmarks/all/?format=infinite&limit=10&offset={Cursor}"
Else
If DownloadTextPosts And DownloadText Then
path = $"/api2/v2/users/{ID}/posts?limit=10&order=publish_date_desc&skip_users=all&format=infinite&pinned=0"
Else
path = $"/api2/v2/users/{ID}/posts/medias?limit=50&order=publish_date_desc&skip_users=all&format=infinite&counters=1"
End If
If Not Cursor.IsEmptyString Then path &= $"&counters=0&beforePublishTime={Cursor}" Else path &= "&counters=1"
End If
@@ -491,7 +504,7 @@ Namespace API.OnlyFans
ID = j.Value("id")
UserSiteNameUpdate(j.Value("name"))
Dim descr$ = j.Value("about")
If Not descr.IsEmptyString Then descr = descr.Replace(brTag, String.Empty)
If Not descr.IsEmptyString Then descr = descr.Replace(brTag, vbCrLf)
UserDescriptionUpdate(descr)
SimpleDownloadAvatar(j.Value("avatar"))
SimpleDownloadAvatar(j.Value("header"))
@@ -623,6 +636,7 @@ Namespace API.OnlyFans
#Region "OFScraper support"
Private Function OFS_DownloadFile(ByVal URL As String, ByVal Token As CancellationToken) As List(Of SFile)
Try
If Labels.Count = 0 OrElse Not Labels.Contains(LabelDRM) Then Labels.Add(LabelDRM) : _ForceSaveUserInfo = True
Const requestPattern$ = """{0}"" manual --config ""{1}"" --url {2}"
Dim conf As SFile = OFS_CreateConfig()
If conf.Exists Then
@@ -787,6 +801,7 @@ Namespace API.OnlyFans
End If
End If
End If
If Not f.Exists Then f = Nothing
Return f
End If
Return Nothing
@@ -827,6 +842,8 @@ Namespace API.OnlyFans
Return 3
ElseIf Responser.StatusCode = Net.HttpStatusCode.InternalServerError Then '500
Return 3
ElseIf Not _TimelineDownloading And Responser.StatusCode = Net.HttpStatusCode.BadGateway Then '502
Return 3
Else
Return 0
End If

View File

@@ -6,15 +6,21 @@
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports SCrawler.API.Base
Imports SCrawler.Plugin.Attributes
Namespace API.Pinterest
Friend Class EditorExchangeOptions
Friend Class EditorExchangeOptions : Inherits EditorExchangeOptionsBase
<PSetting(Caption:="Get Sub-Boards", ToolTip:="Extract the Sub-Boards from the boards and download them")>
Friend Property ExtractSubBoards As Boolean = True
Friend Sub New(ByVal u As UserData)
MyBase.New(u)
ExtractSubBoards = u.ExtractSubBoards
End Sub
Friend Sub New()
End Sub
Friend Overrides Sub Apply(ByRef u As UserDataBase)
MyBase.Apply(u)
DirectCast(u, UserData).ExtractSubBoards = ExtractSubBoards
End Sub
End Class
End Namespace

View File

@@ -97,7 +97,7 @@ Namespace API.Pinterest
Return New EditorExchangeOptions(Me)
End Function
Friend Overrides Sub ExchangeOptionsSet(ByVal Obj As Object)
If Not Obj Is Nothing AndAlso TypeOf Obj Is EditorExchangeOptions Then ExtractSubBoards = DirectCast(Obj, EditorExchangeOptions).ExtractSubBoards
If Not Obj Is Nothing AndAlso TypeOf Obj Is EditorExchangeOptions Then DirectCast(Obj, EditorExchangeOptions).Apply(Me)
End Sub
#End Region
#Region "Download overrides"

View File

@@ -20,11 +20,16 @@ Namespace API.PornHub
Friend ReadOnly RegexVideo_FlashVars_Vars As RParams = RParams.DM("var ([\w\d]{10,})=("".+?)(?=(;|\Z))", 0, RegexReturn.List)
Friend ReadOnly RegexVideo_FlashVars_Compiler As RParams = RParams.DM("(?<=\*/)([\w\d\S]{10,})", 0, RegexReturn.List)
Friend ReadOnly RegexVideo_FlashVars_UrlResolution As RParams = RParams.DMS("/(\d+)[^/]+\.mp4", 1, EDP.ReturnValue)
Friend ReadOnly RegexUserVideos As RParams = RParams.DM("(\<li class=""pcVideoListItem)((?:(?!/li\>).)*?)(\<div.class=.private-vid-title((?:(?!/li\>).)*?)|)(\<a.href=.([^""]+?)"".title=.([^""]*?)"")(((?:(?!/li\>).)+?)(\<div class=.videoUploaderBlock)|)((?:(?!/li\>).)*?)(\</li\>)",
Friend ReadOnly RegexUserVideos As RParams = RParams.DM("(\<li class=""pcVideoListItem)((?:(?!/li\>).)*?)(\<div.class=.private-vid-title((?:(?!/li\>).)*?)|)(\<a.href=.([^""]+?)"".title=.([^""]*?)"")(((?:(?!/li\>).)+?)(\<div class=.videoUploaderBlock.*?href=""([^""]+)"")|)((?:(?!/li\>).)*?)(\</li\>)",
0, RegexOptions.Singleline, RegexReturn.List, EDP.ReturnValue, UnicodeHexConverter)
Friend ReadOnly RegexVideo_Video_VideoKey As RParams = RParams.DMS("viewkey=([\w\d]+)", 1, EDP.ReturnValue)
Friend ReadOnly RegexVideoPageTitle As RParams = RParams.DMS("meta (property|name)=""[^:]+?:title"" content=""([^""]+)""", 2, EDP.ReturnValue)
Friend ReadOnly RegexVideoPageTitle2 As RParams = RParams.DMS("\<title\>([^\<]+)\</title>", 1, EDP.ReturnValue)
Friend ReadOnly RegexVideoPageTitle3 As RParams = RParams.DMS("videoTitle...([^""]+)", 1, EDP.ReturnValue)
Friend ReadOnly RegexVideoPageTitle_NoTitle As RParams = RParams.DMS("(?<=(\=|/))([\w\d]+)(?=(\?|\&|\Z))", 2, EDP.ReturnValue)
Friend ReadOnly RegexDataToken As RParams = RParams.DMS("data-token=""([^""]+)", 1, EDP.ReturnValue)
Friend ReadOnly RegexVideoAdditImg As RParams = RParams.DMS("twitter.image..content=""([^""]+)""", 1, EDP.ReturnValue)
Friend ReadOnly RegexVideoAdditImg2 As RParams = RParams.DMS("thumbnailUrl""[^""]*?""([^""]+)""", 1, EDP.ReturnValue)
#End Region
#Region "Declarations M3U8"
Friend ReadOnly Regex_M3U8_FilesList As RParams = RParams.DM("RESOLUTION=\d+x(\d+).*?[\r\n]*?(.+?m3u8.*)", 0, RegexReturn.List, EDP.ReturnValue)
@@ -42,6 +47,7 @@ Namespace API.PornHub
CType(Function(Input$) If(Input.IsEmptyString, String.Empty, $"https://www.pornhub.com{Input.Trim}"), Func(Of String, String)))
Friend ReadOnly Regex_Photo_PornHub_SinglePhoto As RParams = RParams.DM("data-image=""([^""]+)""\s*src=""([^""]+)""", 0, RegexReturn.ListByMatch, EDP.ReturnValue)
Friend ReadOnly Regex_Photo_PornHub_SinglePhoto2 As RParams = RParams.DMS("image:src"" content=""([^""]+)""", 1, EDP.ReturnValue)
Friend ReadOnly Regex_Photo_PornHub_SinglePhoto3 As RParams = RParams.DMS("div id=""photoImageSection"".*?a href=""[^""\d]+\d+""\>[\r\n\s\t]*\<img src=""([^""]+)""", 1, RegexOptions.Singleline, EDP.ReturnValue)
Friend ReadOnly Regex_Photo_File As RParams = RParams.DM("\d+\.[\w]{3,4}", 0, EDP.ReturnValue)
#End Region
End Module

View File

@@ -22,7 +22,7 @@ Namespace API.PornHub
If Not r.IsEmptyString Then
Dim files As List(Of Sizes) = RegexFields(Of Sizes)(r, {Regex_M3U8_FilesList}, {1, 2}, EDP.ReturnValue)
Dim file$
If files.ListExists Then files.RemoveAll(Function(f) f.Value = 0 Or (Not DownloadUHD And f.Value > 1080))
If files.ListExists Then files.RemoveAll(Function(f) f.Value = 0 Or (Not DownloadUHD And f.Value > 1080) Or (f.Data.IsEmptyString OrElse f.Data.Contains("""")))
If files.ListExists Then
files.Sort()
file = files(0).Data

View File

@@ -14,7 +14,14 @@ Imports PersonalUtilities.Tools.Web.Clients
Namespace API.PornHub
<Manifest("AndyProgram_PornHub"), SavedPosts, SpecialForm(False), SeparatedTasks(1)>
Friend Class SiteSettings : Inherits SiteSettingsBase
#Region "Categories"
Private Const CAT_YTDLP As String = "yt-dlp support"
#End Region
#Region "Declarations"
#Region "Auth"
<PropertyOption(ControlText:="Use cookies", ControlToolTip:="Use cookies to download", IsAuth:=True), PXML, PClonable>
Friend Property CookiesUse As PropertyValue
#End Region
<PropertyOption(ControlText:="Download UHD", ControlToolTip:="Download UHD (4K) content"), PXML, PClonable>
Friend Property DownloadUHD As PropertyValue
<PropertyOption(ControlText:="Download uploaded", ControlToolTip:="Download uploaded videos"), PXML, PClonable>
@@ -34,12 +41,19 @@ Namespace API.PornHub
<DoNotUse> Friend Overrides Property DownloadText As PropertyValue
<DoNotUse> Friend Overrides Property DownloadTextPosts As PropertyValue
<DoNotUse> Friend Overrides Property DownloadTextSpecialFolder As PropertyValue
#Region "YT-DLP"
<PropertyOption(ControlText:="Use yt-dlp", ControlToolTip:="Use yt-dlp to download videos", Category:=CAT_YTDLP), PXML, PClonable>
Friend Property YTDLP_Use As PropertyValue
<PropertyOption(ControlText:="yt-dlp use cookies", ControlToolTip:="Using cookies in yt-dlp commands", Category:=CAT_YTDLP), PXML, PClonable>
Friend Property YTDLP_UseCookies As PropertyValue
#End Region
#End Region
#Region "Initializer"
Friend Sub New(ByVal AccName As String, ByVal Temp As Boolean)
MyBase.New("PornHub", "pornhub.com", AccName, Temp, My.Resources.SiteResources.PornHubIcon_16, My.Resources.SiteResources.PornHubPic_16)
With Responser : .CurlSslNoRevoke = True : .CurlInsecure = True : End With
CookiesUse = New PropertyValue(False)
DownloadUHD = New PropertyValue(False)
DownloadUploaded = New PropertyValue(True)
DownloadTagged = New PropertyValue(False)
@@ -49,10 +63,14 @@ Namespace API.PornHub
DownloadGifs = New PropertyValue(CInt(CheckState.Indeterminate), GetType(Integer))
SavedPostsUserName = New PropertyValue(String.Empty, GetType(String))
YTDLP_Use = New PropertyValue(True)
YTDLP_UseCookies = New PropertyValue(False)
_SubscriptionsAllowed = True
UrlPatternUser = "https://www.pornhub.com/{0}/{1}"
UserRegex = RParams.DMS("pornhub.com/(model|user[s]?|pornstar|channel[s]?)/([^/]+).*?", 0, RegexReturn.ListByMatch)
ImageVideoContains = "pornhub.com"
UseNetscapeCookies = True
End Sub
#End Region
#Region "GetInstance"

View File

@@ -6,13 +6,17 @@
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports System.IO
Imports System.Security.Policy
Imports System.Threading
Imports SCrawler.API.Base
Imports SCrawler.API.YouTube.Objects
Imports PersonalUtilities.Functions.XML
Imports PersonalUtilities.Functions.RegularExpressions
Imports PersonalUtilities.Functions.XML
Imports PersonalUtilities.Tools
Imports PersonalUtilities.Tools.Web.Clients
Imports PersonalUtilities.Tools.Web.Documents.JSON
Imports SCrawler.API.Base
Imports SCrawler.API.Base.YTDLP
Imports SCrawler.API.YouTube.Objects
Imports UTypes = SCrawler.API.Base.UserMedia.Types
Namespace API.PornHub
Friend Class UserData : Inherits UserDataBase : Implements IPSite
@@ -50,12 +54,14 @@ Namespace API.PornHub
Friend URL As String
Friend ID As String
Friend Title As String
Friend UserRef As String
Friend Type As VideoTypes
Friend Function ToUserMedia(Optional ByVal SpecialFolder As String = Nothing) As UserMedia
Return New UserMedia(URL, UTypes.VideoPre) With {
.File = If(Title.IsEmptyString, .File, New SFile($"{Title}.mp4")),
Friend Function ToUserMedia(Optional ByVal SpecialFolder As String = Nothing, Optional ByVal UseYTDLP As Boolean = False) As UserMedia
Return New UserMedia(URL, If(UseYTDLP, UTypes.Video, UTypes.VideoPre)) With {
.File = If(Title.IsEmptyString, .File, New SFile($"{TitleHtmlConverter(Title)}.mp4")),
.Post = ID,
.SpecialFolder = SpecialFolder
.SpecialFolder = SpecialFolder,
.Type = If(UseYTDLP And Not Title.IsEmptyString, UTypes.Video, UTypes.VideoPre)
}
End Function
Private Function CreateFromArray(ByVal ParamsArray() As String) As Object Implements IRegExCreator.CreateFromArray
@@ -66,14 +72,16 @@ Namespace API.PornHub
URL = String.Empty
Else
URL = String.Format(UrlPattern, URL.TrimStart("/"))
Title = TitleHtmlConverter(ParamsArray(1))
If Not ParamsArray(2).IsEmptyString Then
Type = VideoTypes.Private
ElseIf Not ParamsArray(3).IsEmptyString Then
Type = VideoTypes.Tagged
'ElseIf Not ParamsArray(3).IsEmptyString Then
' Type = VideoTypes.Tagged
Else
Type = VideoTypes.Uploaded
End If
If Not ParamsArray(3).IsEmptyString Then UserRef = ParamsArray(3).StringTrim
End If
End If
Return Me
@@ -93,6 +101,9 @@ Namespace API.PornHub
Return Me
End Function
End Structure
Private Structure PHObj : Implements IThumbList
Friend Property Thumbs As List(Of String) Implements IThumbList.Thumbs
End Structure
#End Region
#Region "Enums"
Private Enum VideoTypes
@@ -171,6 +182,7 @@ Namespace API.PornHub
Return DirectCast(HOST.Source, SiteSettings)
End Get
End Property
Private MyCache As CacheKeeper = Nothing
#End Region
#Region "Initializer"
Friend Sub New()
@@ -255,11 +267,12 @@ Namespace API.PornHub
Private _PageVideosRepeat As Integer = 0
Protected Overrides Sub DownloadDataF(ByVal Token As CancellationToken)
Try
UpdateM3U8URLS = False
PlaylistToken = String.Empty
Responser.ResetStatus()
If Not CBool(MySettings.CookiesUse.Value) Then Responser.Cookies.Clear()
_PageVideosRepeat = 0
SessionPosts.Clear()
UseInternalDownloadFileFunction = MySettings.YTDLP_Use.Value
If IsSavedPosts Then
PersonType = PersonTypeUser
@@ -298,7 +311,7 @@ Namespace API.PornHub
End If
End If
If _TempMediaList.Count > 0 Then
If Not CBool(MySettings.YTDLP_Use.Value) And _TempMediaList.Count > 0 Then
_TempMediaList.RemoveAll(Function(m) Not m.Type = UTypes.m3u8 And Not m.Type = UTypes.VideoPre)
If limit > 0 And _TempMediaList.Count > limit Then _TempMediaList.ListAddList(_TempMediaList.ListTake(-1, limit), LAP.ClearBeforeAdd)
End If
@@ -335,13 +348,17 @@ Namespace API.PornHub
ProgressPre.ChangeMax(1)
Try
Dim specFolder$ = String.Empty
Dim useYtdlp As Boolean = MySettings.YTDLP_Use.Value
Dim tryNextPage As Boolean = False
Dim limit% = If(DownloadTopCount, -1)
Dim cBefore% = _TempMediaList.Count
Dim usrRef$ = String.Empty
Dim npd$ = "?"
If IsUser Then
URL = $"https://www.pornhub.com/{PersonType}/{NameTrue}"
usrRef = $"/{PersonType}/{NameTrue}"
If Type = VideoTypes.Uploaded Then
URL &= "/videos/upload"
If Not PersonType = PersonTypeCannel Then URL &= "/videos/upload?o=mr" : npd = "&"
ElseIf Type = VideoTypes.Tagged Then
If Not SecondMode Then URL &= "/videos"
specFolder = "Tagged"
@@ -354,7 +371,7 @@ Namespace API.PornHub
Else
Throw New ArgumentException($"Type '{Type}' is not implemented in the video download function", "Type")
End If
If Page > 1 Then URL &= $"?page={Page}"
If Page > 1 Then URL &= $"{npd}page={Page}"
ElseIf SiteMode = SiteModes.Playlists Then
If PlaylistToken.IsEmptyString Then Throw New ArgumentNullException("PlaylistToken", "Unable to get 'PlaylistToken'")
URL = String.Format(PlayListUrlPattern, NameTrue, PlaylistToken, Page)
@@ -367,12 +384,21 @@ Namespace API.PornHub
'Debug.WriteLine(URL)
Dim r$ = Responser.GetResponse(URL)
If Not r.IsEmptyString Then
Dim l As List(Of UserVideo) = RegexFields(Of UserVideo)(r, {RegexUserVideos}, {6, 7, 3, 10})
Dim l As List(Of UserVideo) = RegexFields(Of UserVideo)(r, {RegexUserVideos}, {6, 7, 3, 11})
'If l.ListExists And Not SiteMode = SiteModes.Playlists Then l = l.ListTake(3, l.Count).ToList
If l.ListExists And Not SiteMode = SiteModes.Playlists Then l = l.ListTake(1, l.Count).ToList
If l.ListExists And Not SiteMode = SiteModes.Playlists And Not IsUser Then l = l.ListTake(1, l.Count).ToList
If l.ListExists Then
If IsUser Then
If Type = VideoTypes.Favorite Then
If Type = VideoTypes.Tagged Then
l = l.ListTake(4, l.Count)
If l.ListExists Then l.RemoveAll(Function(uv) Not uv.UserRef.IsEmptyString AndAlso uv.UserRef = usrRef)
ElseIf Type = VideoTypes.Uploaded Then
If PersonType = PersonTypeCannel Then
l = l.ListTake(4, l.Count)
Else
l.RemoveAll(Function(uv) Not uv.UserRef.IsEmptyString AndAlso Not uv.UserRef = usrRef)
End If
ElseIf Type = VideoTypes.Favorite Then
l.RemoveAll(Function(uv) uv.Type = VideoTypes.Private)
ElseIf Not PersonType = PersonTypeCannel Then
l.RemoveAll(Function(uv) Not uv.Type = Type)
@@ -390,7 +416,7 @@ Namespace API.PornHub
_TempPostsList.Add(uv.ID)
newPostsFound = True
Return False
ElseIf SessionPosts.Count > 0 AndAlso SessionPosts.Contains(uv.id) Then
ElseIf SessionPosts.Count > 0 AndAlso SessionPosts.Contains(uv.ID) Then
prevPostsFound = True
Return True
Else
@@ -402,7 +428,7 @@ Namespace API.PornHub
'Debug.WriteLineIf(l.Count > 0, l.Select(Function(ll) ll.Title).ListToString(vbNewLine))
If prevPostsFound And Not pageRepeatSet And Not newPostsFound Then pageRepeatSet = True : _PageVideosRepeat += 1
If prevPostsFound And newPostsFound And pageRepeatSet Then _PageVideosRepeat -= 1
If l.Count > 0 Then _TempMediaList.ListAddList(l.Select(Function(uv) uv.ToUserMedia(specFolder)))
If l.Count > 0 Then _TempMediaList.ListAddList(l.Select(Function(uv) uv.ToUserMedia(specFolder, useYtdlp)))
SessionPosts.ListAddList(newLastPageIDs, LNC)
newLastPageIDs.Clear()
@@ -542,6 +568,7 @@ Namespace API.PornHub
If .ListExists(3) Then url = .Item(2).IfNullOrEmpty(.Item(1)).StringTrim
End With
If url.IsEmptyString Then url = RegexReplace(r, Regex_Photo_PornHub_SinglePhoto2)
If url.IsEmptyString Then url = RegexReplace(r, Regex_Photo_PornHub_SinglePhoto3)
Return url
End Function
Private Overloads Function DownloadUserPhotos_PornHub(ByVal Page As Integer, ByVal AlbumID As String, ByVal AlbumName As String,
@@ -633,6 +660,21 @@ Namespace API.PornHub
#End Region
#End Region
#Region "ReparseVideo"
Private Function GetVideoTitle(ByVal r As String, ByVal URL As String) As String
Dim tmpName$ = String.Empty
Dim rr As RParams
For i As Byte = 0 To 3
Select Case i
Case 0 : rr = RegexVideoPageTitle
Case 1 : rr = RegexVideoPageTitle2
Case 2 : rr = RegexVideoPageTitle3
Case Else : rr = RegexVideoPageTitle_NoTitle
End Select
tmpName = RegexReplace(IIf(i = 3, URL, r), rr)
If Not tmpName.IsEmptyString Then Exit For
Next
Return tmpName
End Function
Protected Overloads Overrides Sub ReparseVideo(ByVal Token As CancellationToken)
If IsSubscription Then
ReparseVideoSubscriptions(Token)
@@ -644,10 +686,12 @@ Namespace API.PornHub
Optional ByRef Data As IYouTubeMediaContainer = Nothing)
Const ERR_NEW_URL$ = "ERR_NEW_URL"
Dim URL$ = String.Empty
Dim useYtdlp As Boolean = MySettings.YTDLP_Use.Value
Try
If _TempMediaList.Count > 0 AndAlso _TempMediaList.Exists(Function(tm) tm.Type = UTypes.VideoPre) Then
Dim m As UserMedia
Dim r$, NewUrl$, tmpName$
Dim isCurl%
ProgressPre.ChangeMax(_TempMediaList.Count)
For i% = _TempMediaList.Count - 1 To 0 Step -1
ProgressPre.Perform()
@@ -656,16 +700,22 @@ Namespace API.PornHub
ThrowAny(Token)
Try
URL = m.URL
r = Responser.Curl(URL)
For isCurl = 1 To 0 Step -1
If CBool(isCurl) Then r = Responser.Curl(URL) Else r = Responser.GetResponse(URL)
If Not r.IsEmptyString Then
NewUrl = CreateVideoURL(r)
If NewUrl.IsEmptyString Then
NewUrl = String.Empty
If Not useYtdlp Then NewUrl = CreateVideoURL(r)
If Not useYtdlp And NewUrl.IsEmptyString Then
Throw New Exception With {.HelpLink = ERR_NEW_URL}
Else
If useYtdlp Then
m.Type = UTypes.Video
Else
m.URL = NewUrl
m.Type = UTypes.m3u8
If CreateFileName Then
tmpName = RegexReplace(r, RegexVideoPageTitle)
End If
If CreateFileName Or useYtdlp Then
tmpName = GetVideoTitle(r, URL)
If Not tmpName.IsEmptyString Then
If Not Data Is Nothing Then Data.Title = tmpName
m.File.Name = TitleHtmlConverter(tmpName)
@@ -674,9 +724,11 @@ Namespace API.PornHub
End If
_TempMediaList(i) = m
End If
Else
Exit For
ElseIf Not CBool(isCurl) Then
_TempMediaList.RemoveAt(i)
End If
Next
Catch mid_ex As Exception
If mid_ex.HelpLink = ERR_NEW_URL OrElse DownloadingException(mid_ex, "") = 1 Then
m.State = UserMedia.States.Missing
@@ -698,6 +750,10 @@ Namespace API.PornHub
Dim m As UserMedia
Dim r$, URL$, tmpName$, thumb$
Dim c% = 0
Dim thumbObj As PHObj
Dim thumbAdded As Boolean
Dim rp As RParams
Dim rpa() As RParams = {RegexVideoAdditImg, RegexVideoAdditImg2}
Dim rErr As New ErrorsDescriber(EDP.ReturnValue)
Progress.Maximum += _TempMediaList.Count
For i% = _TempMediaList.Count - 1 To 0 Step -1
@@ -712,10 +768,24 @@ Namespace API.PornHub
If Not r.IsEmptyString Then
m.Type = UTypes.m3u8
thumbObj = New PHObj With {.Thumbs = New List(Of String)}
thumbAdded = False
thumb = RegexReplace(r, Regex_VideosThumb_OG_IMAGE)
If Not thumb.IsEmptyString Then m.URL = thumb
If Not thumb.IsEmptyString Then m.URL = thumb : thumbAdded = True
For Each rp In rpa
thumb = RegexReplace(r, rp)
If Not thumb.IsEmptyString Then
If Not thumbAdded Then
m.URL = thumb
thumbAdded = True
Else
thumbObj.Thumbs.Add(thumb)
End If
End If
Next
If thumbObj.Thumbs.Count > 0 Then m.Object = thumbObj
tmpName = RegexReplace(r, RegexVideoPageTitle)
tmpName = GetVideoTitle(r, URL)
If Not tmpName.IsEmptyString Then
m.File.Name = TitleHtmlConverter(tmpName)
m.File.Extension = "mp4"
@@ -744,6 +814,7 @@ Namespace API.PornHub
#Region "ReparseMissing"
Protected Overrides Sub ReparseMissing(ByVal Token As CancellationToken)
Dim rList As New List(Of Integer)
If CBool(MySettings.YTDLP_Use.Value) Then UseInternalDownloadFileFunction = True
Try
If ContentMissingExists Then
Dim m As UserMedia
@@ -755,6 +826,12 @@ Namespace API.PornHub
m = _ContentList(i)
If m.State = UserMedia.States.Missing AndAlso Not m.URL_BASE.IsEmptyString Then
ThrowAny(Token)
If CBool(MySettings.YTDLP_Use.Value) Then
m.URL = m.URL_BASE
m.Type = UTypes.Video
_TempMediaList.ListAddValue(m, LNC)
rList.Add(i)
Else
r = Responser.Curl(m.URL_BASE,, eCurl)
If Not r.IsEmptyString Then
Dim NewUrl$ = CreateVideoURL(r)
@@ -765,48 +842,72 @@ Namespace API.PornHub
End If
End If
End If
End If
Next
End If
Catch ex As Exception
ProcessException(ex, Token, "missing data downloading error")
Finally
If rList.Count > 0 Then
For i% = rList.Count - 1 To 0 Step -1 : _ContentList.RemoveAt(rList(i)) : Next
rList.Clear()
End If
ReparseMissing_ClearList(rList)
End Try
End Sub
#End Region
#Region "Download content"
Private UpdateM3U8URLS As Boolean = False
Private UpdateM3U8URLS_Error As Boolean = False
Protected Overrides Sub DownloadContent(ByVal Token As CancellationToken)
Try : DownloadContentDefault(Token) : Finally : UpdateM3U8URLS = False : End Try
DownloadContentDefault(Token)
End Sub
Protected Overloads Overrides Function DownloadM3U8(ByVal URL As String, ByVal Media As UserMedia, ByVal DestinationFile As SFile,
ByVal Token As CancellationToken) As SFile
UpdateM3U8URLS_Error = False
Return DownloadM3U8(URL, Media, DestinationFile, Token, UpdateM3U8URLS)
Return DownloadM3U8(URL, Media, DestinationFile, Token, 0)
End Function
Private Overloads Function DownloadM3U8(ByVal URL As String, ByVal Media As UserMedia, ByVal DestinationFile As SFile,
ByVal Token As CancellationToken, ByVal Second As Boolean) As SFile
ByVal Token As CancellationToken, ByVal Round As Integer) As SFile
Const MaxRound% = 2
Try
If Second Then
If Round > 0 Then
Dim r$ = Responser.Curl(Media.URL_BASE,, EDP.ReturnValue)
If Not r.IsEmptyString Then Media.URL = CreateVideoURL(r).IfNullOrEmpty(URL) : URL = Media.URL
End If
Dim f As SFile = M3U8.Download(URL, Responser, DestinationFile, DownloadUHD, Token, Progress, Not IsSingleObjectDownload)
If Not f.Exists And Not Second Then UpdateM3U8URLS = True : f = DownloadM3U8(URL, Media, DestinationFile, Token, True)
If Not f.Exists Then f = Nothing
If f.IsEmptyString And Round < MaxRound Then f = DownloadM3U8(URL, Media, DestinationFile, Token, Round + 1)
Return f
Catch ex As Exception
If Not UpdateM3U8URLS_Error Then
UpdateM3U8URLS_Error = True
If Round < MaxRound Then
Thread.Sleep(1000)
Return DownloadM3U8(URL, Media, DestinationFile, Token, True)
Return DownloadM3U8(URL, Media, DestinationFile, Token, Round + 1)
End If
Return Nothing
End Try
End Function
Protected Overrides Function ValidateDownloadFile(ByVal URL As String, ByVal Media As UserMedia, ByRef Interrupt As Boolean) As Boolean
Return Media.Type = UTypes.Video
End Function
Protected Overrides Function DownloadFile(ByVal URL As String, ByVal Media As UserMedia, ByVal DestinationFile As SFile, ByVal Token As CancellationToken) As SFile
Dim cc As CacheKeeper
If IsSingleObjectDownload Then
cc = Settings.Cache
Else
If MyCache Is Nothing Then MyCache = CreateCache()
cc = MyCache
End If
cc.Validate()
Dim cmd$ = YTDLP_CreateCommand(URL, cc)
Dim f As SFile = Nothing
If Not cmd.IsEmptyString Then
Dim path As SFile = cc.NewPath
path.Exists()
cmd &= $" -o ""{DestinationFile}"""
Using b As New YTDLPBatch(Token)
b.Encoding = Settings.CMDEncoding
b.CreateFileExchanger(cc)
If IsSingleObjectDownload Then b.SetProgress(Progress)
b.Execute(cmd)
End Using
If DestinationFile.Exists Then f = DestinationFile
End If
Return f
End Function
#End Region
#Region "CreateVideoURL"
Private Function CreateVideoURL(ByVal r As String) As String
@@ -900,9 +1001,43 @@ Namespace API.PornHub
End Try
End Function
#End Region
#Region "YT-DLP support"
Private Function YTDLP_CreateCommand(ByVal URL As String, ByRef Cache As CacheKeeper) As String
Dim path As SFile = Cache.NewPath
Dim c$ = If(CBool(MySettings.YTDLP_UseCookies.Value) And MySettings.CookiesNetscapeFile.Exists,
$" --no-cookies-from-browser --cookies ""{MySettings.CookiesNetscapeFile}""", String.Empty)
Dim cmd$ = $"""{Settings.YtdlpFile}"" --write-info-json --skip-download{c} {URL} -o ""{path.PathWithSeparator}file"""
path.Exists()
Using ytdlp As New YTDLPBatch(TokenPersonal,, path) : ytdlp.Encoding = Settings.CMDEncoding : ytdlp.Execute(cmd) : End Using
cmd = String.Empty
Dim f As SFile = SFile.GetFiles(path, "*.json",, EDP.ReturnValue).FirstOrDefault
If f.Exists Then
Using j As EContainer = JsonDocument.Parse(f.GetText(EDP.ReturnValue), EDP.ReturnValue)
If j.ListExists Then
With j("formats")
If .ListExists Then
Dim formats As List(Of Sizes) = Nothing
Try : formats = .Select(Function(ee) New Sizes(CInt(ee.Value("height")), ee.Value("format_id"))).ListIfNothing : Catch : End Try
If formats.ListExists Then
formats.RemoveAll(Function(ff) ff.Value <= 0 Or (Not CBool(MySettings.DownloadUHD.Value) AndAlso ff.Value > 1080) Or ff.Data.IsEmptyString)
If formats.Count > 0 Then
formats.Sort()
cmd = $"-f {formats(0).Data} "
formats.Clear()
End If
End If
End If
End With
End If
End Using
End If
Return $"""{Settings.YtdlpFile}"" {cmd}{URL}"
End Function
#End Region
#Region "DownloadSingleObject"
Protected Overrides Sub DownloadSingleObject_GetPosts(ByVal Data As IYouTubeMediaContainer, ByVal Token As CancellationToken)
UpdateM3U8URLS = False
If CBool(MySettings.YTDLP_Use.Value) Then UseInternalDownloadFileFunction = True
If Not CBool(MySettings.CookiesUse.Value) Then Responser.Cookies.Clear()
_TempMediaList.Add(New UserMedia(Data.URL, UTypes.VideoPre))
ReparseVideo(Token, True, Data)
End Sub
@@ -924,7 +1059,7 @@ Namespace API.PornHub
#End Region
#Region "IDisposable Support"
Protected Overrides Sub Dispose(ByVal disposing As Boolean)
If Not disposedValue And disposing Then SessionPosts.Clear()
If Not disposedValue And disposing Then SessionPosts.Clear() : MyCache.DisposeIfReady
MyBase.Dispose(disposing)
End Sub
#End Region

View File

@@ -44,7 +44,7 @@ Namespace API.PornHub
DownloadGifs = Not v = CheckState.Unchecked
MySettings = s
End Sub
Friend Overrides Sub Apply(ByRef u As IPSite)
Friend Overrides Sub Apply(ByRef u As UserDataBase)
MyBase.Apply(u)
With DirectCast(u, UserData)
.DownloadUHD = DownloadUHD

View File

@@ -23,24 +23,14 @@ Namespace API.Reddit
Friend Class SiteSettings : Inherits SiteSettingsBase : Implements DownDetector.IDownDetector
#Region "Declarations"
#Region "Authorization"
Private Const ApiClientID_Default As String = "dYctRA-SIJxyykHe27lGZg"
Private Const ApiClientSecret_Default As String = "_5D6KzplRPDga-es1YlpzDIe9hiFlg"
<PropertyOption(ControlText:="Login", ControlToolTip:="Your authorization username", IsAuth:=True), PXML, PClonable(Clone:=False)>
Friend ReadOnly Property AuthUserName As PropertyValue
<PropertyOption(ControlText:="Password", ControlToolTip:="Your authorization password", IsAuth:=True), PXML, PClonable(Clone:=False)>
Friend ReadOnly Property AuthPassword As PropertyValue
<PropertyOption(ControlText:="Client ID", ControlToolTip:="Your registered app client ID", IsAuth:=True), PXML, PClonable(Clone:=False)>
Friend ReadOnly Property ApiClientID As PropertyValue
<PropertyUpdater(NameOf(ApiClientID))> Private Function ApiClientID_SetDefault() As Boolean
ApiClientID.Value = ApiClientID_Default
Return True
End Function
<PropertyOption(ControlText:="Client Secret", ControlToolTip:="Your registered app client secret", IsAuth:=True), PXML, PClonable(Clone:=False)>
Friend ReadOnly Property ApiClientSecret As PropertyValue
<PropertyUpdater(NameOf(ApiClientSecret))> Private Function ApiClientSecret_SetDefault() As Boolean
ApiClientSecret.Value = ApiClientSecret_Default
Return True
End Function
<PropertyOption(ControlText:="Bearer token",
ControlToolTip:="Bearer token (can be null)." & vbCr &
"If you are using cookies to download the timeline, it is highly recommended that you add a token." & vbCr &
@@ -238,7 +228,14 @@ Namespace API.Reddit
Return AvailableTrueValue(What) AndAlso UpdateTokenIfRequired()
End Function
Private Function AvailableTrueValue(ByVal What As Download) As Boolean
Return Not What = Download.SavedPosts OrElse (Responser.CookiesExists And ACheck(SavedPostsUserName.Value))
'Return Not What = Download.SavedPosts OrElse (Responser.CookiesExists And ACheck(SavedPostsUserName.Value))
If What = Download.SavedPosts Then
Return Responser.CookiesExists And ACheck(SavedPostsUserName.Value)
ElseIf CredentialsExists Then
Return Not CBool(UseCookiesForTimelines.Value) OrElse Responser.CookiesExists
Else
Return Responser.CookiesExists
End If
End Function
Friend Overrides Sub DownloadDone(ByVal What As Download)
SessionInterrupted = False

View File

@@ -136,7 +136,7 @@ Namespace API.Reddit
DownloadTextSpecialFolder = .DownloadTextSpecialFolder
RedGifsAccount = .RedGifsAccount
RedditAccount = .RedditAccount
If TypeOf Options Is RedditViewExchange Then DirectCast(Options, RedditViewExchange).ApplyBase(Me)
If TypeOf Options Is RedditViewExchange Then DirectCast(Options, RedditViewExchange).Apply(Me)
End With
End If
End Sub
@@ -355,7 +355,11 @@ Namespace API.Reddit
Dim _PostID As Func(Of String) = Function() PostTmp.IfNullOrEmpty(PostID)
'URL = $"https://gateway.reddit.com/desktopapi/v1/user/{NameTrue}/posts?rtj=only&allow_quarantined=true&allow_over18=1&include=identity&after={POST}&dist=25&sort={View}&t={Period}&layout=classic"
If MySiteSettings.CredentialsExists Then
URL = $"https://oauth.reddit.com/user/{NameTrue}/submitted.json?rtj=only&allow_quarantined=true&allow_over18=1&include=identity&after={POST}&dist=25&sort={View}&t={Period}&layout=classic"
Else
URL = $"https://www.reddit.com/user/{NameTrue}/.json?raw_json=1&rtj=only&allow_quarantined=true&allow_over18=1&include=identity&after={POST}&dist=25&sort={View}&t={Period}&layout=classic"
End If
ThrowAny(Token)
Wait429()
Dim r$ = Responser.GetResponse(URL)
@@ -583,8 +587,6 @@ Namespace API.Reddit
_TempMediaList.ListAddValue(MediaFromData(UTypes.VideoPre, tmpUrl, PostID, PostDate, UserID,, PostText), LNC)
_TotalPostsDownloaded += 1
End If
ElseIf CreateImgurMedia(tmpUrl, PostID, PostDate, UserID, IsChannel, PostText) Then
_TotalPostsDownloaded += 1
ElseIf DownloadGallery(e, PostID, PostDate, UserID, SaveToCache, PostText) Then
_TotalPostsDownloaded += 1
ElseIf Not If(e({"media"}, "type")?.Value, String.Empty).IsEmptyString Then
@@ -778,62 +780,15 @@ Namespace API.Reddit
End Function
#End Region
#Region "Download Base Functions"
Private Function CreateImgurMedia(ByVal _URL As String, ByVal PostID As String, ByVal PostDate As String,
Optional ByVal _UserID As String = "", Optional ByVal IsChannel As Boolean = False,
Optional ByVal PostText As String = Nothing) As Boolean
If Not _URL.IsEmptyString AndAlso _URL.Contains("imgur") Then
If _URL.StringContains({".jpg", ".png", ".jpeg"}) Then
_TempMediaList.ListAddValue(MediaFromData(UTypes.Picture, _URL, PostID, PostDate, _UserID,, PostText), LNC)
ElseIf _URL.Contains(".gifv") Then
If SaveToCache Then
_TempMediaList.ListAddValue(MediaFromData(UTypes.Picture, _URL.Replace(".gifv", ".gif"), PostID, PostDate, _UserID,, PostText), LNC)
Else
_TempMediaList.ListAddValue(MediaFromData(UTypes.Video, _URL.Replace(".gifv", ".mp4"), PostID, PostDate, _UserID,, PostText), LNC)
End If
ElseIf _URL.Contains(".mp4") Then
_TempMediaList.ListAddValue(MediaFromData(UTypes.Video, _URL, PostID, PostDate, _UserID,, PostText), LNC)
ElseIf _URL.Contains(".gif") Then
_TempMediaList.ListAddValue(MediaFromData(UTypes.GIF, _URL, PostID, PostDate, _UserID,, PostText), LNC)
Else
Dim obj As IEnumerable(Of UserMedia) = Imgur.Envir.GetVideoInfo(_URL, EDP.ReturnValue)
If Not obj.ListExists Then
If Not TryFile(_URL) Then _URL &= ".jpg"
_TempMediaList.ListAddValue(MediaFromData(UTypes.Picture, _URL, PostID, PostDate, _UserID,, PostText), LNC)
Else
Dim ut As UTypes
Dim m As UserMedia
For Each data As UserMedia In obj
With data
If Not .URL.IsEmptyString Then
If Not .File.IsEmptyString Then
Select Case .File.Extension
Case "jpg", "png", "jpeg" : ut = UTypes.Picture
Case "gifv" : ut = IIf(SaveToCache, UTypes.Picture, UTypes.Video)
Case "mp4" : ut = UTypes.Video
Case "gif" : ut = UTypes.GIF
Case Else : ut = UTypes.Picture : .File.Extension = "jpg"
End Select
m = MediaFromData(ut, _URL, PostID, PostDate, _UserID,, PostText)
m.URL = .URL
m.File = .File.File
_TempMediaList.ListAddValue(m, LNC)
End If
End If
End With
Next
End If
End If
Return True
Else
Return False
End If
End Function
Private Function DownloadGallery(ByVal e As EContainer, ByVal PostID As String, ByVal PostDate As String,
Optional ByVal _UserID As String = Nothing, Optional ByVal FirstOnly As Boolean = False,
Optional ByVal PostText As String = Nothing) As Boolean
Try
Dim added As Boolean = False
Dim node As EContainer = Nothing
Dim m As UserMedia
Dim isGif As Boolean
Dim i%
If e.Contains("media_metadata") Then
node = e("media_metadata")
ElseIf e.Contains("mediaMetadata") Then
@@ -842,13 +797,26 @@ Namespace API.Reddit
If If(node?.Count, 0) > 0 Then
Dim t As EContainer
For Each n As EContainer In node
t = n.ItemF({"s", "u"})
isGif = False
Select Case n.Value("e")
Case "AnimatedImage" : isGif = True : t = Nothing
Case Else : t = n.ItemF({"s", "u"})
End Select
For i = 0 To IIf(isGif, 1, 0)
If isGif Then t = If(i = 0, n.ItemF({"s", "gif"}), n.ItemF({"s", "mp4"}))
If Not t Is Nothing AndAlso Not t.Value.IsEmptyString Then
_TempMediaList.ListAddValue(MediaFromData(UTypes.Picture, t.Value, PostID, PostDate, _UserID,, PostText), LNC)
m = MediaFromData(IIf(i = 0, IIf(isGif, UTypes.GIF, UTypes.Picture), UTypes.GIF), t.Value, PostID, PostDate, _UserID,, PostText)
If isGif And i = 1 Then
m.File = CreateFileFromUrl(t.Value)
m.File.Extension = "mp4"
m.URL = t.Value
End If
_TempMediaList.ListAddValue(m, LNC)
added = True
If FirstOnly Then Exit For
End If
Next
Next
End If
Return added
Catch ex As Exception
@@ -1022,11 +990,11 @@ Namespace API.Reddit
If .ListExists AndAlso ParseContainer(.Self, m.Post.ID, String.Empty,,, GetTextDocument(.Self)) Then
If lastCount <> _TempMediaList.Count Then
For li = IIf(lastCount < 0, 0, lastCount) To _TempMediaList.Count - 1
m2 = _TempMediaList(i)
m2 = _TempMediaList(li)
m2.Post.Date = m.Post.Date
m2.State = UStates.Missing
m2.Attempts = m.Attempts
_TempMediaList(i) = m2
_TempMediaList(li) = m2
Next
End If
rList.Add(i)

View File

@@ -7,6 +7,8 @@
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports PersonalUtilities.Functions.RegularExpressions
Imports PersonalUtilities.Tools.Web.Cookies
Imports PersonalUtilities.Tools.Web.Clients
Namespace API.ThisVid
Friend Module Declarations
Friend Const ThisVidSiteKey As String = "AndyProgram_ThisVid"
@@ -22,5 +24,27 @@ Namespace API.ThisVid
Friend ReadOnly RegExVideosThumb1 As RParams = RParams.DMS("preview_url:\s*'([^""']+)'", 1, EDP.ReturnValue)
Friend ReadOnly RegExVideosThumb2 As RParams = RParams.DMS("preview_url1:\s*'([^""']+)'", 1, EDP.ReturnValue)
Friend ReadOnly RegExVideoTitle As RParams = RParams.DMS("meta property=.og:title..content=""([^""]*)""", 1, EDP.ReturnValue)
Friend Class CookieKeeper2 : Inherits CookieKeeper
Public Overrides Function Update(Optional ByVal e As ErrorsDescriber = Nothing) As Boolean
If Count > 0 Then
If Not ConvertToContainer(_Container, CookieList, EDP.ReturnValue) Then CookieList.RemoveAt(CookieList.Count - 1) Else Return True
End If
Return MyBase.Update(e)
End Function
End Class
Friend Class Responser2 : Inherits Responser
Friend Sub New()
MyBase.New
ChangeCookieKeeper()
End Sub
Friend Sub New(ByVal f As SFile)
MyBase.New(f)
ChangeCookieKeeper()
End Sub
Private Sub ChangeCookieKeeper()
_Cookies = New CookieKeeper2
Reset()
End Sub
End Class
End Module
End Namespace

View File

@@ -50,6 +50,14 @@ Namespace API.ThisVid
UrlPatternUser = "https://thisvid.com/members/{0}/"
ImageVideoContains = "https://thisvid.com/videos/"
End Sub
Protected Overrides Sub ChangeResponserOnInit()
_Responser.DisposeIfReady(False)
_Responser = Nothing
_Responser = New Responser2 With {.DeclaredError = EDP.ThrowException}
End Sub
Friend Overrides Function GetCookieKeeperInstance() As CookieKeeper
Return New CookieKeeper2
End Function
#End Region
#Region "GetInstance"
Friend Overrides Function GetInstance(ByVal What As ISiteSettings.Download) As IPluginContentProvider

View File

@@ -179,7 +179,7 @@ Namespace API.ThisVid
If Not IsSavedPosts Then
Dim r$ = Responser.GetResponse($"https://thisvid.com/members/{ID}/")
If Not r.IsEmptyString Then
Dim rr As New RParams("", Nothing, 1, EDP.ReturnValue)
Dim rr As RParams = RParams.DMS("", 1, EDP.ReturnValue)
Dim __getValue As Func(Of String, Boolean, String) = Function(ByVal member As String, ByVal appendMember As Boolean) As String
rr.Pattern = String.Format(ProfileDataPattern, member)
Dim v$ = CStr(RegexReplace(r, rr)).StringTrim
@@ -190,13 +190,14 @@ Namespace API.ThisVid
If Not UserSiteName.IsEmptyString And FriendlyName.IsEmptyString Then FriendlyName = UserSiteName : _ForceSaveUserData = True
Dim descr$ = String.Empty
descr.StringAppendLine(__getValue("Birth date", True))
descr.StringAppendLine(__getValue("Country", True))
descr.StringAppendLine(__getValue("City", True))
descr.StringAppendLine(__getValue("Location", True))
'descr.StringAppendLine(__getValue("City", True))
descr.StringAppendLine(__getValue("Gender", True))
descr.StringAppendLine(__getValue("Orientation", True))
descr.StringAppendLine(__getValue("Relationship status", True))
descr.StringAppendLine(__getValue("Favourite category", True))
descr.StringAppendLine(__getValue("My interests", True))
descr.StringAppendLine(__getValue("Favorite niche", True))
rr.Pattern = DescriptionPattern
descr.StringAppendLine(CStr(RegexReplace(r, rr)).StringTrim)
UserDescriptionUpdate(descr)
@@ -403,6 +404,30 @@ Namespace API.ThisVid
End Sub
#End Region
#Region "ReparseVideo"
Protected Overrides Sub ReparseMissing(ByVal Token As CancellationToken)
Dim rList As New List(Of Integer)
Try
If Not IsSubscription And ContentMissingExists Then
Dim m As UserMedia
ProgressPre.ChangeMax(_ContentList.Count)
For i% = 0 To _ContentList.Count - 1
ProgressPre.Perform()
m = _ContentList(i)
If m.State = UserMedia.States.Missing AndAlso Not m.URL_BASE.IsEmptyString Then
ThrowAny(Token)
m.URL = m.URL_BASE
m.Type = UserMedia.Types.VideoPre
_TempMediaList.ListAddValue(m, LNC)
rList.Add(i)
End If
Next
End If
Catch ex As Exception
ProcessException(ex, Token, "missing data downloading error")
Finally
ReparseMissing_ClearList(rList)
End Try
End Sub
Protected Overrides Sub ReparseVideo(ByVal Token As CancellationToken)
If IsSubscription Then
ReparseVideoSubscriptions(Token)
@@ -440,11 +465,12 @@ Namespace API.ThisVid
If n.IsEmptyString Then n = u.Post.ID
If n.IsEmptyString Then n = "VideoFile"
u.File = $"{n}.mp4"
If u.URL.IsEmptyString OrElse (Not u.Post.ID.IsEmptyString AndAlso _TempPostsList.Contains(u.Post.ID)) Then
If Not u.State = UserMedia.States.Missing AndAlso
(u.URL.IsEmptyString OrElse (Not u.Post.ID.IsEmptyString AndAlso _TempPostsList.Contains(u.Post.ID))) Then
_TempMediaList.RemoveAt(i)
Else
u.Type = UserMedia.Types.Video
_TempPostsList.Add(u.Post.ID)
_TempPostsList.ListAddValue(u.Post.ID, LNC)
_TempMediaList(i) = u
End If
e.Dispose()

View File

@@ -35,7 +35,7 @@ Namespace API.ThisVid
DifferentFolders = u.DifferentFolders
MySettings = u.HOST.Source
End Sub
Friend Overrides Sub Apply(ByRef u As IPSite)
Friend Overrides Sub Apply(ByRef u As UserDataBase)
MyBase.Apply(u)
With DirectCast(u, UserData)
.DownloadPublic = DownloadPublic

View File

@@ -0,0 +1,17 @@
' Copyright (C) Andy https://github.com/AAndyProgram
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation, either version 3 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports SCrawler.API.Base
Imports PersonalUtilities.Functions.RegularExpressions
Namespace API.ThreadsNet
Friend Module Declarations
Friend ReadOnly RegexUserID As RParams = RParams.DMS("""props"":\{[^\{\}]*?""user_id"":""(\d+)""", 1, EDP.ReturnValue)
Friend ReadOnly RegexUserName As RParams = RParams.DMS("\<meta property=""og:title"" content=""([^\>]+)""\s*/\>", 1, TitleHtmlConverter, EDP.ReturnValue)
Friend ReadOnly RegexUserDescr As RParams = RParams.DMS("\<meta property=""og:description"" content=""([^\>]+)""\s*/\>", 1, HtmlConverter, EDP.ReturnValue)
End Module
End Namespace

View File

@@ -55,7 +55,7 @@ Namespace API.ThreadsNet
Return New EditorExchangeOptionsBase(Me)
End Function
Friend Overrides Sub ExchangeOptionsSet(ByVal Obj As Object)
If Not Obj Is Nothing AndAlso TypeOf Obj Is EditorExchangeOptionsBase Then DirectCast(Obj, EditorExchangeOptionsBase).ApplyBase(Me)
If Not Obj Is Nothing AndAlso TypeOf Obj Is EditorExchangeOptionsBase Then DirectCast(Obj, EditorExchangeOptionsBase).Apply(Me)
End Sub
#End Region
#Region "Initializer"
@@ -184,7 +184,6 @@ Namespace API.ThreadsNet
If uex.UserNotFound Then
UserExists = False
_ForceSaveUserInfo = True
_ForceSaveUserInfoOnException = True
ElseIf ThrowEx Then
Throw New ExitException(uex.ErrMessage) With {.SimpleLogLine = True}
Else
@@ -388,8 +387,10 @@ Namespace API.ThreadsNet
Dim newID$
Dim idStr$ = String.Empty
If Not r.IsEmptyString Then
UserSiteNameUpdate(RegexReplace(r, RegexUserName))
UserDescriptionUpdate(RegexReplace(r, RegexUserDescr))
ParseTokens(r, 0)
newID = RegexReplace(r, RParams.DMS("""props"":\{[^\{\}]*?""user_id"":""(\d+)""", 1, EDP.ReturnValue))
newID = RegexReplace(r, RegexUserID)
If ID.IsEmptyString OrElse ID = newID Then
_IdChanged = ID.IsEmptyString
ID = newID
@@ -402,7 +403,6 @@ Namespace API.ThreadsNet
If _IdChanged Then
If Not idStr.IsEmptyString Then UserDescriptionUpdate(idStr, True, True, True)
_ForceSaveUserInfo = True
_ForceSaveUserInfoOnException = True
End If
End If
Return Valid

View File

@@ -11,6 +11,7 @@ Imports PersonalUtilities.Functions.RegularExpressions
Namespace API.TikTok
Friend Module Declarations
Friend ReadOnly SimpleDateConverter As New ADateTime("yyyyMMdd")
Friend ReadOnly SimpleDateConverterWithTime As New ADateTime("yyyyMMdd_HHmmss")
Friend ReadOnly RegexTagsReplacer As RParams = RParams.DM("#\w+\s?", -1, RegexReturn.Replace,
CType(Function(input$) String.Empty, Func(Of String, String)), EDP.ReturnValue)
Friend ReadOnly RegexPhotoJson As RParams = RParams.DMS("UNIVERSAL_DATA_FOR_REHYDRATION__"" type=""application/json""\>([^\<]+)\<", 1,

View File

@@ -10,11 +10,13 @@ Imports SCrawler.API.Base
Imports SCrawler.Plugin
Imports SCrawler.Plugin.Attributes
Imports PersonalUtilities.Functions.RegularExpressions
Imports DN = SCrawler.API.Base.DeclaredNames
Namespace API.TikTok
<Manifest("AndyProgram_TikTok"), SpecialForm(False), SeparatedTasks(1)>
Friend Class SiteSettings : Inherits SiteSettingsBase
#Region "Categories"
Private Const CAT_DOWN As String = "Download"
Private Const CAT_UserDefs_Title As String = DN.CAT_UserDefs & " (Title)"
#End Region
#Region "Download"
<PropertyOption(ControlText:="Download videos", Category:=CAT_DOWN), PXML, PClonable>
@@ -22,33 +24,47 @@ Namespace API.TikTok
<PropertyOption(ControlText:="Download photos", Category:=CAT_DOWN), PXML, PClonable>
Friend ReadOnly Property DownloadTTPhotos As PropertyValue
#End Region
<PropertyOption(ControlText:="Remove tags from title"), PXML, PClonable>
#Region "User defaults"
#Region "Sections"
<PropertyOption(ControlText:="Get Timeline", Category:=DN.CAT_UserDefs), PXML, PClonable>
Friend ReadOnly Property GetTimeline As PropertyValue
<PropertyOption(ControlText:="Get User Stories", Category:=DN.CAT_UserDefs), PXML, PClonable>
Friend ReadOnly Property GetStoriesUser As PropertyValue
<PropertyOption(ControlText:="Get Reposts", Category:=DN.CAT_UserDefs), PXML, PClonable>
Friend ReadOnly Property GetReposts As PropertyValue
#End Region
#Region "Title"
<PropertyOption(ControlText:="Remove tags from title", Category:=CAT_UserDefs_Title), PXML, PClonable>
Friend ReadOnly Property RemoveTagsFromTitle As PropertyValue
<PropertyOption(ControlText:="Use native title", ControlToolTip:="Use a user-created video title for the filename instead of the video ID."), PXML, PClonable>
<PropertyOption(ControlText:="Use native title", ControlToolTip:="Use a user-created video title for the filename instead of the video ID.",
Category:=CAT_UserDefs_Title), PXML, PClonable>
Friend ReadOnly Property TitleUseNative As PropertyValue
<PropertyOption(ControlText:="Use native title (standalone downloader)",
ControlToolTip:="Use a user-created video title for the filename instead of the video ID."), PXML, PClonable>
ControlToolTip:="Use a user-created video title for the filename instead of the video ID.", Category:=CAT_UserDefs_Title), PXML, PClonable>
Friend ReadOnly Property TitleUseNativeSTD As PropertyValue
<PropertyOption(ControlText:="Add video ID to video title"), PXML, PClonable>
<PropertyOption(ControlText:="Add video ID to video title", Category:=CAT_UserDefs_Title), PXML, PClonable>
Friend ReadOnly Property TitleAddVideoID As PropertyValue
<PropertyOption(ControlText:="Add video ID to video title (standalone downloader)"), PXML, PClonable>
<PropertyOption(ControlText:="Add video ID to video title (standalone downloader)", Category:=CAT_UserDefs_Title), PXML, PClonable>
Friend ReadOnly Property TitleAddVideoIDSTD As PropertyValue
<PropertyOption(ControlText:="Use regex to clean video title"), PXML, PClonable>
<PropertyOption(ControlText:="Use regex to clean video title", Category:=CAT_UserDefs_Title), PXML, PClonable>
Friend ReadOnly Property TitleUseRegexForTitle As PropertyValue
<PropertyOption(ControlText:="Title regex", ControlToolTip:="Regex to clean video title"), PXML, PClonable>
<PropertyOption(ControlText:="Title regex", ControlToolTip:="Regex to clean video title", Category:=CAT_UserDefs_Title), PXML, PClonable>
Friend ReadOnly Property TitleUseRegexForTitle_Value As PropertyValue
#End Region
#End Region
<PropertyOption(ControlText:="Use video date as file date",
ControlToolTip:="Set the file date to the date the video was added (website) (if available)."), PXML, PClonable>
Friend ReadOnly Property UseParsedVideoDate As PropertyValue
<PropertyOption(ControlText:="Use video date as file date (standalone downloader)",
ControlToolTip:="Set the file date to the date the video was added (website) (if available)."), PXML, PClonable>
Friend ReadOnly Property UseParsedVideoDateSTD As PropertyValue
<DoNotUse> Friend Overrides Property DownloadText As PropertyValue
<DoNotUse> Friend Overrides Property DownloadTextPosts As PropertyValue
<DoNotUse> Friend Overrides Property DownloadTextSpecialFolder As PropertyValue
Friend Sub New(ByVal AccName As String, ByVal Temp As Boolean)
MyBase.New("TikTok", "www.tiktok.com", AccName, Temp, My.Resources.SiteResources.TikTokIcon_32, My.Resources.SiteResources.TikTokPic_192)
GetTimeline = New PropertyValue(True)
GetStoriesUser = New PropertyValue(False)
GetReposts = New PropertyValue(False)
DownloadTTVideos = New PropertyValue(True)
DownloadTTPhotos = New PropertyValue(True)
@@ -79,5 +95,10 @@ Namespace API.TikTok
Using f As New InternalSettingsForm(Options, Me, False) : f.ShowDialog() : End Using
End If
End Sub
Friend Overrides Function GetUserPostUrl(ByVal User As UserDataBase, ByVal Media As UserMedia) As String
Dim url$ = MyBase.GetUserPostUrl(User, Media)
If Not url.IsEmptyString AndAlso url.EndsWith(UserData.GDL_POSTFIX) Then url = url.Replace(UserData.GDL_POSTFIX, String.Empty)
Return url
End Function
End Class
End Namespace

View File

@@ -7,16 +7,21 @@
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports System.Threading
Imports SCrawler.API.Base
Imports SCrawler.API.YouTube.Objects
Imports PersonalUtilities.Functions.XML
Imports PersonalUtilities.Functions.RegularExpressions
Imports PersonalUtilities.Functions.XML
Imports PersonalUtilities.Tools
Imports PersonalUtilities.Tools.Web.Documents.JSON
Imports SCrawler.API.Base
Imports SCrawler.API.YouTube.Objects
Imports SCrawler.Plugin.Attributes
Imports Sections = SCrawler.API.Instagram.UserData.Sections
Imports UTypes = SCrawler.API.Base.UserMedia.Types
Namespace API.TikTok
Friend Class UserData : Inherits UserDataBase
#Region "XML names"
Private Const Name_GetTimeline As String = "GetTimeline"
Private Const Name_GetStoriesUser As String = "GetStoriesUser"
Private Const Name_GetReposts As String = "GetReposts"
Private Const Name_RemoveTagsFromTitle As String = "RemoveTagsFromTitle"
Private Const Name_TitleUseNative As String = "TitleUseNative"
Private Const Name_TitleAddVideoID As String = "TitleAddVideoID"
@@ -27,6 +32,7 @@ Namespace API.TikTok
Private Const Name_PhotosDownloaded As String = "PhotosDownloaded"
#End Region
#Region "Declarations"
Friend Const GDL_POSTFIX As String = "--GDL"
Private ReadOnly Property MySettings As SiteSettings
Get
Return HOST.Source
@@ -57,6 +63,9 @@ Namespace API.TikTok
End If
End Get
End Property
Friend Property GetTimeline As Boolean = True
Friend Property GetStoriesUser As Boolean = False
Friend Property GetReposts As Boolean = False
Friend Property RemoveTagsFromTitle As Boolean = False
Friend Property TitleUseNative As Boolean = True
Friend Property TitleAddVideoID As Boolean = True
@@ -71,22 +80,16 @@ Namespace API.TikTok
Return New UserExchangeOptions(Me)
End Function
Friend Overrides Sub ExchangeOptionsSet(ByVal Obj As Object)
If Not Obj Is Nothing AndAlso TypeOf Obj Is UserExchangeOptions Then
With DirectCast(Obj, UserExchangeOptions)
RemoveTagsFromTitle = .RemoveTagsFromTitle
TitleUseNative = .TitleUseNative
TitleAddVideoID = .TitleAddVideoID
TitleUseRegexForTitle = .TitleUseRegexForTitle
TitleUseRegexForTitle_Value = .TitleUseRegexForTitle_Value
TitleUseGlobalRegexOptions = .TitleUseGlobalRegexOptions
End With
End If
If Not Obj Is Nothing AndAlso TypeOf Obj Is UserExchangeOptions Then DirectCast(Obj, UserExchangeOptions).Apply(Me)
End Sub
#End Region
#Region "Loader"
Protected Overrides Sub LoadUserInformation_OptionalFields(ByRef Container As XmlFile, ByVal Loading As Boolean)
With Container
If Loading Then
GetTimeline = .Value(Name_GetTimeline).FromXML(Of Boolean)(True)
GetStoriesUser = .Value(Name_GetStoriesUser).FromXML(Of Boolean)(False)
GetReposts = .Value(Name_GetReposts).FromXML(Of Boolean)(False)
RemoveTagsFromTitle = .Value(Name_RemoveTagsFromTitle).FromXML(Of Boolean)(False)
TitleUseNative = .Value(Name_TitleUseNative).FromXML(Of Boolean)(True)
TitleAddVideoID = .Value(Name_TitleAddVideoID).FromXML(Of Boolean)(True)
@@ -97,6 +100,9 @@ Namespace API.TikTok
TitleUseGlobalRegexOptions = .Value(Name_TitleUseGlobalRegexOptions).FromXML(Of Boolean)(True)
PhotosDownloaded = .Value(Name_PhotosDownloaded).FromXML(Of Boolean)(False)
Else
.Add(Name_GetTimeline, GetTimeline.BoolToInteger)
.Add(Name_GetStoriesUser, GetStoriesUser.BoolToInteger)
.Add(Name_GetReposts, GetReposts.BoolToInteger)
.Add(Name_RemoveTagsFromTitle, RemoveTagsFromTitle.BoolToInteger)
.Add(Name_TitleUseNative, TitleUseNative.BoolToInteger)
.Add(Name_TitleAddVideoID, TitleAddVideoID.BoolToInteger)
@@ -165,17 +171,29 @@ Namespace API.TikTok
Private Function GetPhotoNode() As Object()
Return {"imageURL", "urlList", 0, 0}
End Function
Private Sub ValidateCache()
If If(UserCache?.Disposed, True) Then UserCache = CreateCache()
End Sub
Friend Overrides Sub DownloadData(ByVal Token As CancellationToken)
MyBase.DownloadData(Token)
UserCache.DisposeIfReady(False)
UserCache = Nothing
End Sub
Protected Overrides Sub DownloadDataF(ByVal Token As CancellationToken)
Private StoryStatus As Boolean = True
Private StoryStatusFound As Boolean = False
Protected Overloads Overrides Sub DownloadDataF(ByVal Token As CancellationToken)
ValidateCache()
StoryStatus = True
StoryStatusFound = False
If GetTimeline Then DownloadDataF(Sections.Timeline, Token)
If GetStoriesUser And StoryStatus Then DownloadDataF(Sections.UserStories, Token)
If GetReposts Then DownloadDataF(Sections.Reposts, Token)
End Sub
Protected Overloads Sub DownloadDataF(ByVal Section As Sections, ByVal Token As CancellationToken)
Dim URL$ = $"https://www.tiktok.com/@{NameTrue}"
UserCache = CreateCache()
Try
Const photoPrefix$ = "photo_"
Dim postID$, title$, postUrl$, newName$, t$, postID2$, imgUrl$
Dim postID$, title$, postUrl$, newName$, t$, tOrig$, postID2$, imgUrl$, pText$
Dim postDate As Date?
Dim dateAfterC As Date? = Nothing
Dim dateBefore As Date? = DownloadDateTo
@@ -184,12 +202,24 @@ Namespace API.TikTok
Dim titleRegex As RParams = GetTitleRegex()
Dim vPath As SFile = Nothing, pPath As SFile = Nothing
Dim file As SFile
Dim j As EContainer, photo As EContainer
Dim j As EContainer = Nothing, photo As EContainer, item As EContainer
Dim photoNode As Object() = GetPhotoNode()
Dim c%, cc%, i%
Dim errDef As New ErrorsDescriber(EDP.ReturnValue)
Dim infoParsed As Boolean = False
Dim gdlTmpIDs As New Dictionary(Of String, Integer)
Dim gdlCmd$ = String.Empty
Dim gdlIsNativeJson As Boolean
Dim __specFolder$ = String.Empty
Dim __specFolder_Cr As Func(Of String, String) = Function(_sp$) String.Empty.StringAppend(__specFolder).StringAppend(_sp, "\") &
IIf(__specFolder.IsEmptyString, String.Empty, "*")
Select Case Section
Case Sections.UserStories : URL &= "/stories" : __specFolder = "Stories (user)" : gdlCmd = "-o videos -o photos"
Case Sections.Reposts : URL &= "/reposts" : __specFolder = "Reposts"
End Select
If _ContentList.Count > 0 Then
With (From d In _ContentList Where d.Post.Date.HasValue Select d.Post.Date.Value)
If .ListExists Then dateAfterC = .Min
@@ -214,19 +244,16 @@ Namespace API.TikTok
End If
End If
If DownloadVideos And Settings.YtdlpFile.Exists And CBool(MySettings.DownloadTTVideos.Value) Then
If Section = Sections.Timeline And DownloadVideos And Settings.YtdlpFile.Exists And CBool(MySettings.DownloadTTVideos.Value) Then
With UserCache.NewInstance : .Validate() : vPath = .RootDirectory : End With
Using b As New YTDLP.YTDLPBatch(Token) With {.TempPostsList = _TempPostsList}
b.Commands.Clear()
b.ChangeDirectory(vPath)
b.Encoding = BatchExecutor.UnicodeEncoding
Using b As New YTDLP.YTDLPBatch(Token,, vPath) With {.TempPostsList = _TempPostsList}
b.Execute(CreateYTCommand(vPath, URL, False, dateBefore, dateAfter))
End Using
End If
If DownloadImages And Settings.GalleryDLFile.Exists And CBool(MySettings.DownloadTTPhotos.Value) Then
With UserCache.NewInstance : .Validate() : pPath = .RootDirectory : End With
Using b As New GDL.GDLBatch(Token)
Using b As New GDL.GDLBatch(Token,, pPath)
With b
If PhotosDownloaded And _TempPostsList.Count > 0 Then
.TempPostsList = (From p As String In _TempPostsList
@@ -235,10 +262,8 @@ Namespace API.TikTok
Else
.TempPostsList = New List(Of String)
End If
.ChangeDirectory(pPath)
.Encoding = BatchExecutor.UnicodeEncoding
.Execute(CreateGDLCommand(URL))
If Not PhotosDownloaded Then _ForceSaveUserInfo = True : _ForceSaveUserInfoOnException = True
.Execute(CreateGDLCommand(URL, gdlCmd,,,, CObj(IIf(Section = Sections.Timeline, dateAfter, Nothing))))
If Not PhotosDownloaded Then _ForceSaveUserInfo = True
PhotosDownloaded = True
End With
End Using
@@ -247,6 +272,7 @@ Namespace API.TikTok
ThrowAny(Token)
Dim files As List(Of SFile)
'YTDLP
If Not vPath.IsEmptyString AndAlso vPath.Exists(SFO.Path, False) Then
files = SFile.GetFiles(vPath, "*.json",, errDef)
If files.ListExists Then
@@ -254,7 +280,7 @@ Namespace API.TikTok
j = JsonDocument.Parse(file.GetText, errDef)
If j.ListExists Then
If j.Value("_type").StringToLower = "video" Then
If Not baseDataObtained Then
If Not baseDataObtained And Section = Sections.Timeline Then
baseDataObtained = True
If ID.IsEmptyString Then ID = j.Value("uploader_id")
newName = j.Value("uploader")
@@ -266,10 +292,13 @@ Namespace API.TikTok
If Not _TempPostsList.Contains(postID) Then
_TempPostsList.ListAddValue(postID, LNC)
Else
Exit For 'Exit Sub
'Exit For 'Exit Sub
Continue For
End If
title = GetNewFileName(j.Value("title").StringRemoveWinForbiddenSymbols,
TitleUseNative, RemoveTagsFromTitle, TitleAddVideoID, postID, titleRegex)
pText = j.Value("title")
If Not j.Value("description").IsEmptyString Then pText &= vbCr & vbCr & j.Value("description")
postDate = AConvert(Of Date)(j.Value("timestamp"), UnixDate32Provider, Nothing)
If Not postDate.HasValue Then postDate = AConvert(Of Date)(j.Value("upload_date"), SimpleDateConverter, Nothing)
Select Case CheckDatesLimit(postDate, SimpleDateConverter)
@@ -280,7 +309,13 @@ Namespace API.TikTok
postUrl = j.Value("webpage_url")
If postUrl.IsEmptyString Then postUrl = $"https://www.tiktok.com/@{Name}/video/{postID}"
_TempMediaList.Add(New UserMedia(postUrl, UTypes.Video) With {
.File = $"{title}.mp4", .Post = New UserPost(postID, postDate)})
.File = $"{title}.mp4",
.SpecialFolder = __specFolder_Cr(String.Empty),
.Post = New UserPost(postID, postDate),
.PostText = pText,
.PostTextFileSpecialFolder = DownloadTextSpecialFolder,
.PostTextFile = $"{ .File.Name}.txt"
})
End If
j.Dispose()
End If
@@ -288,25 +323,126 @@ Namespace API.TikTok
End If
End If
j.DisposeIfReady
'GDL
If Not pPath.IsEmptyString AndAlso pPath.Exists(SFO.Path, False) Then
files = SFile.GetFiles(pPath, "*.txt",, errDef)
If files.ListExists Then
If Not Section = Sections.Timeline Then
GDLResetFileNameProvider(Math.Max(files.Count.ToString.Length, 2))
For i = 0 To files.Count - 1 : files(i) = GDLRenameFile(files(i), i) : Next
End If
For Each file In files
t = file.GetText(errDef)
If Not t.IsEmptyString Then t = RegexReplace(t, RegexPhotoJson)
tOrig = t
gdlIsNativeJson = False
If Not t.IsEmptyString And Not Section = Sections.UserStories Then
t = RegexReplace(t, RegexPhotoJson)
If t.IsEmptyString Then t = tOrig : gdlIsNativeJson = True
End If
If Not t.IsEmptyString Then
j = JsonDocument.Parse(t, errDef)
If j.ListExists Then
With j.ItemF({0, "webapp.video-detail", "itemInfo", "itemStruct"})
If Section = Sections.UserStories Then
With j("itemList")
If .ListExists Then
For Each item In .Self
With item
postID = .Value("id")
postDate = AConvert(Of Date)(.Value("createTime"), UnixDate32Provider, Nothing)
If Not _TempPostsList.Contains(postID) Then
_TempPostsList.Add(postID)
postUrl = $"https://www.tiktok.com/@{Name}/video/{postID}{GDL_POSTFIX}"
If postDate.HasValue Then
title = CStr(AConvert(Of String)(postDate.Value, SimpleDateConverterWithTime, String.Empty)).StringAppend(postID, " ")
Else
title = postID
End If
_TempMediaList.Add(New UserMedia(postUrl, UTypes.Video) With {
.URL_BASE = postUrl,
.SpecialFolder = __specFolder_Cr(String.Empty),
.File = $"{title}.mp4",
.Post = New UserPost(postID, postDate)
})
With .Item("video")
If .ListExists AndAlso Not .Value("cover").IsEmptyString Then _
_TempMediaList.Add(New UserMedia(.Value("cover"), UTypes.Picture) With {
.URL_BASE = postUrl,
.SpecialFolder = __specFolder_Cr("Photo"),
.File = $"{title}.jpg"
})
End With
Else
Continue For
End If
End With
Next
End If
End With
ElseIf Section = Sections.Reposts And gdlIsNativeJson Then
With j("itemList")
If .ListExists Then
For Each item In .Self
With item
postID = .Value("id")
postID2 = $"{photoPrefix}{postID}"
If Not _TempPostsList.Contains(postID2) Then _TempPostsList.ListAddValue(postID2, LNC) Else Exit For 'Exit Sub
If Not _TempPostsList.Contains(postID) And Not _TempPostsList.Contains(postID2) Then
title = GetNewFileName(.Value("title").StringRemoveWinForbiddenSymbols,
TitleUseNative, RemoveTagsFromTitle, TitleAddVideoID, postID, titleRegex)
pText = .Value("title")
If Not .Value("desc").IsEmptyString Then
pText &= vbCr & vbCr & .Value("desc")
If title.IsEmptyString Then title = GetNewFileName(.Value("desc").StringRemoveWinForbiddenSymbols,
TitleUseNative, RemoveTagsFromTitle, TitleAddVideoID, postID, titleRegex)
End If
postDate = AConvert(Of Date)(j.Value("createTime"), UnixDate32Provider, Nothing)
If postDate.HasValue Then
Select Case CheckDatesLimit(postDate, SimpleDateConverter)
Case DateResult.Skip : Continue For
Case DateResult.Exit : Exit For 'Exit Sub
End Select
End If
postUrl = .Value({"author"}, "uniqueId")
If Not postUrl.IsEmptyString Then
postUrl = $"https://www.tiktok.com/@{postUrl}/video/{postID}"
_TempMediaList.Add(New UserMedia(postUrl, UTypes.Video) With {
.File = $"{title}.mp4",
.SpecialFolder = __specFolder_Cr(String.Empty),
.Post = New UserPost(postID, postDate),
.PostText = pText,
.PostTextFileSpecialFolder = DownloadTextSpecialFolder,
.PostTextFile = $"{ .File.Name}.txt"
})
If Not gdlTmpIDs.ContainsKey(postID) Then gdlTmpIDs.Add(postID, _TempMediaList.Count - 1)
End If
Else
Continue For
End If
End With
Next
End If
End With
Else
If Section = Sections.Timeline And Not StoryStatusFound And j.ContainsF({0, "webapp.user-detail", "userInfo", "user"}, "UserStoryStatus") Then
StoryStatusFound = True
StoryStatus = j.ItemF({0, "webapp.user-detail", "userInfo", "user"}, "UserStoryStatus").Value.FromXML(Of Boolean)(False)
End If
With j.ItemF({0, "webapp.video-detail", "itemInfo", "itemStruct"})
If .ListExists Then
postID = .Value("id")
postID2 = $"{photoPrefix}{postID}"
'If Not _TempPostsList.Contains(postID2) Then _TempPostsList.ListAddValue(postID2, LNC) Else Exit For 'Exit Sub
postDate = AConvert(Of Date)(.Value("createTime"), UnixDate32Provider, Nothing)
If Not Section = Sections.UserStories Then
Select Case CheckDatesLimit(postDate, SimpleDateConverter)
Case DateResult.Skip : Continue For
Case DateResult.Exit : Exit For 'Exit Sub
End Select
End If
If Not infoParsed Then
With .Item("author")
@@ -330,11 +466,22 @@ Namespace API.TikTok
End With
End If
title = GetNewFileName(j.Value({"imagePost"}, "title").StringRemoveWinForbiddenSymbols,
title = GetNewFileName(.Value({"imagePost"}, "title").StringRemoveWinForbiddenSymbols,
TitleUseNative, RemoveTagsFromTitle, TitleAddVideoID, postID, titleRegex)
pText = .Value({"imagePost"}, "title")
If Not .Value("desc").IsEmptyString Then pText &= vbCr & vbCr & .Value("desc")
postUrl = $"https://www.tiktok.com/@{Name}/photo/{postID}"
With .Item({"imagePost", "images"})
If .ListExists Then
If Not _TempPostsList.Contains(postID2) Then
_TempPostsList.ListAddValue(postID2, LNC)
If gdlTmpIDs.ContainsKey(postID) Then
_TempMediaList.RemoveAt(gdlTmpIDs(postID))
gdlTmpIDs.Remove(postID)
End If
Else
Continue For 'Exit Sub
End If
i = 0
c = .Count
cc = Math.Max(c.ToString.Length, 3)
@@ -344,14 +491,19 @@ Namespace API.TikTok
If Not imgUrl.IsEmptyString Then _
_TempMediaList.Add(New UserMedia(imgUrl, UTypes.Picture) With {
.URL_BASE = postUrl,
.SpecialFolder = "Photo",
.SpecialFolder = __specFolder_Cr("Photo"),
.File = $"{title}{IIf(c > 1, $"_{i.NumToString(ANumbers.Formats.NumberGroup, cc)}", String.Empty)}.jpg",
.Post = New UserPost(postID, postDate)})
.Post = New UserPost(postID, postDate),
.PostText = pText,
.PostTextFileSpecialFolder = DownloadTextSpecialFolder,
.PostTextFile = $"{ .File.Name}.txt"
})
Next
End If
End With
End If
End With
End If
j.Dispose()
End If
End If
@@ -359,6 +511,9 @@ Namespace API.TikTok
End If
End If
j.DisposeIfReady
_TempPostsList.ListAddList(gdlTmpIDs.Keys)
gdlTmpIDs.Clear()
If _TempMediaList.Count > 0 Then LastDownloadDate = Now
Catch ex As Exception
ProcessException(ex, Token, $"data downloading error [{URL}]")
@@ -443,8 +598,21 @@ Namespace API.TikTok
End Function
#End Region
#Region "GDL Support"
Private Function CreateGDLCommand(ByVal URL As String) As String
Return $"""{Settings.GalleryDLFile}"" --verbose --no-download --no-skip --write-pages {URL}"
Private Function CreateGDLCommand(ByVal URL As String, Optional ByVal SectionCommand As String = Nothing,
Optional ByVal IsDownload As Boolean = False, Optional ByVal Output As SFile = Nothing,
Optional ByVal DateBefore As Date? = Nothing, Optional ByVal DateAfter As Date? = Nothing) As String
Dim command$ = $"""{Settings.GalleryDLFile}"" "
If Not IsDownload Then
command &= "--verbose --no-download --no-skip --write-pages "
Else
command &= $"--dest ""{Output.PathNoSeparator}"" "
End If
If DateBefore.HasValue Or DateAfter.HasValue Then
With If(DateAfter, DateBefore).Value : command &= $"--filter ""date {IIf(DateAfter.HasValue, ">", "<")} datetime({ .Year}, { .Month}, { .Day}) or terminate()"" " : End With
End If
If Not CBool(If(IsSingleObjectDownload, MySettings.UseParsedVideoDateSTD, MySettings.UseParsedVideoDate).Value) Then command &= "--no-mtime "
command &= $"{SectionCommand} {URL}"
Return command
End Function
#End Region
#Region "DownloadContent, DownloadFile"
@@ -456,8 +624,16 @@ Namespace API.TikTok
End Function
Protected Overrides Function DownloadFile(ByVal URL As String, ByVal Media As UserMedia, ByVal DestinationFile As SFile, ByVal Token As CancellationToken) As SFile
Using b As New TokenBatch(Token) With {.FileExchanger = RootCacheTikTok}
b.Encoding = BatchExecutor.UnicodeEncoding
If URL.EndsWith(GDL_POSTFIX) Then
ValidateCache()
Dim tmpPath As SFile
With UserCache.NewInstance : .Validate() : tmpPath = .RootDirectory : End With
b.Execute(CreateGDLCommand(URL.Replace(GDL_POSTFIX, String.Empty),, True, tmpPath))
tmpPath = SFile.GetFiles(tmpPath, "*.mp4", IO.SearchOption.AllDirectories, EDP.ReturnValue).FirstOrDefault
If Not tmpPath.IsEmptyString Then SFile.Move(tmpPath, DestinationFile)
Else
b.Execute(CreateYTCommand(DestinationFile, URL, True))
End If
End Using
If DestinationFile.Exists Then Return DestinationFile Else Return Nothing
End Function
@@ -477,7 +653,6 @@ Namespace API.TikTok
t = UTypes.Video
If CBool(MySettings.TitleUseNativeSTD.Value) Then
Using b As New BatchExecutor(True) With {
.Encoding = BatchExecutor.UnicodeEncoding,
.CleanAutomaticallyViaRegEx = True,
.CleanAutomaticallyViaRegExRemoveAllCommands = True
}
@@ -498,11 +673,7 @@ Namespace API.TikTok
Data.Title = defName
Dim dir As SFile
With If(Cache, Settings.Cache).NewInstance() : .Validate() : dir = .RootDirectory : End With
Using b As New GDL.GDLBatch(Token)
b.ChangeDirectory(dir)
b.Encoding = BatchExecutor.UnicodeEncoding
b.Execute(CreateGDLCommand(Data.URL))
End Using
Using b As New GDL.GDLBatch(Token,, dir) : b.Execute(CreateGDLCommand(Data.URL)) : End Using
Dim file As SFile = SFile.GetFiles(dir, "*.txt",, EDP.ReturnValue).FirstOrDefault
If file.Exists Then
Dim r$ = file.GetText(EDP.ReturnValue)

View File

@@ -6,9 +6,17 @@
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports SCrawler.API.Base
Imports SCrawler.Plugin
Imports SCrawler.Plugin.Attributes
Namespace API.TikTok
Friend Class UserExchangeOptions
Friend Class UserExchangeOptions : Inherits EditorExchangeOptionsBase
<PSetting(NameOf(SiteSettings.GetTimeline), NameOf(MySettings))>
Friend Property GetTimeline As Boolean
<PSetting(NameOf(SiteSettings.GetStoriesUser), NameOf(MySettings))>
Friend Property GetStoriesUser As Boolean
<PSetting(NameOf(SiteSettings.GetReposts), NameOf(MySettings))>
Friend Property GetReposts As Boolean
<PSetting(NameOf(SiteSettings.RemoveTagsFromTitle), NameOf(MySettings))>
Friend Property RemoveTagsFromTitle As Boolean
<PSetting(NameOf(SiteSettings.TitleUseNative), NameOf(MySettings))>
@@ -21,9 +29,15 @@ Namespace API.TikTok
Friend Property TitleUseRegexForTitle_Value As String
<PSetting(Caption:="Use global regex", ToolTip:="Use the global regex from the site settings to clean the video title")>
Friend Property TitleUseGlobalRegexOptions As Boolean = True
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property UserName As String
Private ReadOnly MySettings As SiteSettings
Friend Sub New(ByVal u As UserData)
MyBase.New(u)
_ApplyBase_Name = False
MySettings = u.HOST.Source
GetTimeline = u.GetTimeline
GetStoriesUser = u.GetStoriesUser
GetReposts = u.GetReposts
RemoveTagsFromTitle = u.RemoveTagsFromTitle
TitleUseNative = u.TitleUseNative
TitleAddVideoID = u.TitleAddVideoID
@@ -32,12 +46,31 @@ Namespace API.TikTok
TitleUseGlobalRegexOptions = u.TitleUseGlobalRegexOptions
End Sub
Friend Sub New(ByVal s As SiteSettings)
MyBase.New(s)
_ApplyBase_Name = False
MySettings = s
GetTimeline = s.GetTimeline.Value
GetStoriesUser = s.GetStoriesUser.Value
GetReposts = s.GetReposts.Value
RemoveTagsFromTitle = s.RemoveTagsFromTitle.Value
TitleUseNative = s.TitleUseNative.Value
TitleAddVideoID = s.TitleAddVideoID.Value
TitleUseRegexForTitle = s.TitleUseRegexForTitle.Value
TitleUseRegexForTitle_Value = s.TitleUseRegexForTitle_Value.Value
End Sub
Friend Overrides Sub Apply(ByRef u As UserDataBase)
MyBase.Apply(u)
With DirectCast(u, UserData)
.GetTimeline = GetTimeline
.GetStoriesUser = GetStoriesUser
.GetReposts = GetReposts
.RemoveTagsFromTitle = RemoveTagsFromTitle
.TitleUseNative = TitleUseNative
.TitleAddVideoID = TitleAddVideoID
.TitleUseRegexForTitle = TitleUseRegexForTitle
.TitleUseRegexForTitle_Value = TitleUseRegexForTitle_Value
.TitleUseGlobalRegexOptions = TitleUseGlobalRegexOptions
End With
End Sub
End Class
End Namespace

View File

@@ -17,6 +17,10 @@ Namespace API.Twitter
Friend ReadOnly VideoSizeRegEx As RParams = RParams.DMS("\d+x(\d+)", 1, EDP.ReturnValue)
Friend ReadOnly StatusRegEx As RParams = RParams.DM(".*?(twitter|x)\.com/\S+/status/\d+", 0, EDP.ReturnValue)
Friend ReadOnly BroadcastsUrls As Object() = {"entities", "urls", 0, "expanded_url"}
Friend ReadOnly RichTextNode As New List(Of String()) From {
{{"content", "itemContent", "tweet_results", "result", "note_tweet", "note_tweet_results", "result", "text"}},
{{"item", "itemContent", "tweet_results", "result", "note_tweet", "note_tweet_results", "result", "text"}}
}
Friend ReadOnly GdlLimitRegEx As RParams = RParams.DM("Waiting until[\s\W\d\:]+\(rate limit\)", 0, RegexOptions.IgnoreCase, EDP.ReturnValue)
Friend ReadOnly GdlPostCoutNumberNodes As String() = {"data", "user", "result", "legacy", "statuses_count"}
Private Function GetDateProvider() As ADateTime

View File

@@ -65,13 +65,6 @@ Namespace API.Twitter
MediaModelAllowNonUserTweets = s.MediaModelAllowNonUserTweets.Value
MySettings = s
End Sub
Friend Sub New(ByVal s As Mastodon.SiteSettings)
GifsDownload = s.GifsDownload.Value
GifsSpecialFolder = s.GifsSpecialFolder.Value
GifsPrefix = s.GifsPrefix.Value
UseMD5Comparison = s.UseMD5Comparison.Value
MySettings = s
End Sub
Friend Sub New(ByVal u As UserData)
MyBase.New(u)
GifsDownload = u.GifsDownload
@@ -81,7 +74,6 @@ Namespace API.Twitter
RemoveExistingDuplicates = u.RemoveExistingDuplicates
MediaModelAllowNonUserTweets = u.MediaModelAllowNonUserTweets
LargeProfile = u.LargeProfile
If Not TypeOf u Is Mastodon.UserData Then
DownloadModelForceApply = u.DownloadModelForceApply
DownloadBroadcasts = u.DownloadBroadcasts
Dim dm As DModels() = EnumExtract(Of DModels)(u.DownloadModel)
@@ -91,7 +83,6 @@ Namespace API.Twitter
DownloadModelSearch = dm.Contains(DModels.Search)
DownloadModelLikes = dm.Contains(DModels.Likes)
End If
End If
MySettings = u.HOST.Source
End Sub
End Class

View File

@@ -112,14 +112,6 @@ Namespace API.Twitter
Return HOST.Source
End Get
End Property
Private FileNameProvider As ANumbers = Nothing
Private Sub ResetFileNameProvider(Optional ByVal GroupSize As Integer? = Nothing)
FileNameProvider = New ANumbers With {.FormatOptions = ANumbers.Options.FormatNumberGroup + ANumbers.Options.Groups}
FileNameProvider.GroupSize = If(GroupSize, 3)
End Sub
Private Function RenameGdlFile(ByVal Input As SFile, ByVal i As Integer) As SFile
Return SFile.Rename(Input, $"{Input.PathWithSeparator}{i.NumToString(FileNameProvider)}.{Input.Extension}",, EDP.ThrowException)
End Function
Friend Function GetUserUrl() As String
Return $"https://x.com{IIf(IsCommunity, SiteSettings.CommunitiesUser, String.Empty)}/{NameTrue}"
End Function
@@ -131,7 +123,7 @@ Namespace API.Twitter
Friend Overrides Sub ExchangeOptionsSet(ByVal Obj As Object)
If Not Obj Is Nothing AndAlso TypeOf Obj Is EditorExchangeOptions Then
With DirectCast(Obj, EditorExchangeOptions)
.ApplyBase(Me)
.Apply(Me)
GifsDownload = .GifsDownload
GifsSpecialFolder = .GifsSpecialFolder
GifsPrefix = .GifsPrefix
@@ -305,10 +297,17 @@ Namespace API.Twitter
Private Const DEBUG_PROFILE As Boolean = False
Private Const DEBUG_LEAVE_CACHE As Boolean = False
Private JsonNullErr As Boolean = False
Private ____UserExists As Boolean = True
Private NotUserExistsAttempts As Integer = 0
Friend Overrides Sub DownloadData(ByVal Token As CancellationToken)
____UserExists = UserExists
MyBase.DownloadData(Token)
End Sub
Protected Overrides Sub DownloadDataF(ByVal Token As CancellationToken)
Try
GDL_REQUESTS_COUNT = 0
JsonNullErr = False
NotUserExistsAttempts = 0
If MySettings.LIMIT_ABORT Then
Throw New TwitterLimitException(Me)
Else
@@ -325,6 +324,14 @@ Namespace API.Twitter
End If
LikesPosts.Clear()
If _ContentList.Count > 0 Then _DataNames.ListAddList(_ContentList.Select(Function(c) c.File.File), LAP.ClearBeforeAdd, LAP.NotContainsOnly)
If Not ____UserExists Then
For i% = 0 To 1
NotUserExistsAttempts += 1
DownloadData_Timeline(Token)
If UserExists Then ____UserExists = True : Exit For
Next
End If
If Not UserExists Then Exit Sub
DownloadData_Timeline(Token)
If _TempMediaList.Count = 0 And LikesPosts.Count = 0 And JsonNullErr Then Throw New Plugin.ExitException("No deserialized data found")
LoadSavePostsKV(False)
@@ -374,6 +381,7 @@ Namespace API.Twitter
Dim j As EContainer, rootNode As EContainer, optionalNode As EContainer, workingNode As EContainer, tmpNode As EContainer, nn As EContainer = Nothing
Dim multiMode As Boolean = IsMultiMode
Dim currentModel As DownloadModels = DownloadModels.Undefined
Dim onlyUpdateUser As Boolean = Not ____UserExists
Dim __parseContainer As Func(Of EContainer, Boolean) =
Function(ByVal ee As EContainer) As Boolean
@@ -434,7 +442,7 @@ Namespace API.Twitter
End If
End If
Else
ObtainMedia(nn, PostID, PostDate)
ObtainMedia(nn, PostID, PostDate,,,, ee)
End If
End If
End If
@@ -479,13 +487,14 @@ Namespace API.Twitter
ThrowAny(Token)
Dim timelineFiles As List(Of SFile) = SFile.GetFiles(dir, "*.txt",, EDP.ReturnValue)
If timelineFiles.ListExists Then
ResetFileNameProvider(Math.Max(timelineFiles.Count.ToString.Length, 2))
GDLResetFileNameProvider(Math.Max(timelineFiles.Count.ToString.Length, 2))
'rename files
If Not DEBUG_PROFILE Then
For i = 0 To timelineFiles.Count - 1 : timelineFiles(i) = RenameGdlFile(timelineFiles(i), i) : Next
For i = 0 To timelineFiles.Count - 1 : timelineFiles(i) = GDLRenameFile(timelineFiles(i), i) : Next
End If
'parse files
For i = 0 To timelineFiles.Count - 1
If userInfoParsed And onlyUpdateUser Then Exit Sub
j = JsonDocument.Parse(timelineFiles(i).GetText, jsonArgs)
If jsonArgs.State = WebDocumentEventArgs.States.Error Then
jsonArgs.Reset(Token)
@@ -514,7 +523,7 @@ Namespace API.Twitter
With .ItemF({0, "content", "items", 0, "item", "itemContent", "tweet_results", "result", "tweet", "community_results", "result"})
If .ListExists Then
If ID = .Value("id_str") Then
UserSiteNameUpdate(.Value("name"))
UserSiteNameUpdate(.Value("name"), True)
UserDescriptionUpdate(.Value("description"))
icon = .Value({"custom_banner_media", "media_info"}, "original_img_url").
@@ -533,16 +542,27 @@ Namespace API.Twitter
With j({"data", "user", "result"})
If .ListExists Then
If ID.IsEmptyString Then ID = .Value("rest_id")
icon = .Value({"avatar"}, "image_url")
UserSiteNameUpdate(.Value({"core"}, "name"), True)
Dim tScreenName$ = .Value({"core"}, "screen_name")
With .Item({"legacy"})
If .ListExists Then
If .Value("screen_name").StringToLower = NameTrue.ToLower Then
UserSiteNameUpdate(.Value("name"))
If onlyUpdateUser Then
If Not NameTrue = tScreenName Then
Dim uStr$ = $"username changed from '{NameTrue}' to '{tScreenName}'"
LogError(Nothing, uStr)
UserDescriptionUpdate(uStr, True, True, True)
End If
NameTrue = tScreenName
End If
If .Value("screen_name").IfNullOrEmpty(tScreenName).StringToLower = NameTrue.ToLower Then
UserSiteNameUpdate(.Value("name"), True)
UserDescriptionUpdate(.Value("description"))
icon = .Value("profile_image_url_https")
If icon.IsEmptyString Then icon = .Value("profile_image_url_https")
If Not icon.IsEmptyString Then icon = icon.Replace("_normal", String.Empty)
If DownloadIconBanner Then
SimpleDownloadAvatar(.Value("profile_banner_url"), fileCrFunc)
SimpleDownloadAvatar(.Value("profile_banner_url").IfNullOrEmpty(.Value({"legacy"}, "profile_banner_url")), fileCrFunc)
SimpleDownloadAvatar(icon, fileCrFunc)
End If
End If
@@ -675,17 +695,17 @@ nextpIndx:
End Sub
Private Sub DownloadData_SavedPosts(ByVal Token As CancellationToken)
Try
Dim f As SFile = GetDataFromGalleryDL("https://x.com/i/bookmarks", Settings.Cache, True, Token)
Dim f As SFile = GetDataFromGalleryDL("https://x.com/i/history", Settings.Cache, True, Token)
Dim files As List(Of SFile) = SFile.GetFiles(f, "*.txt")
If files.ListExists Then
ResetFileNameProvider(Math.Max(files.Count.ToString.Length, 3))
GDLResetFileNameProvider(Math.Max(files.Count.ToString.Length, 3))
Dim id$
Dim nodes As List(Of String()) = GetContainerSubnodes()
Dim node$()
Dim j As EContainer, jj As EContainer
Dim jErr As New ErrorsDescriber(EDP.ReturnValue)
For i% = 0 To files.Count - 1
f = RenameGdlFile(files(i), i)
f = GDLRenameFile(files(i), i)
j = JsonDocument.Parse(f.GetText, jErr)
If Not j Is Nothing Then
With j.ItemF({"data", 0, "timeline", "instructions", 0, "entries"})
@@ -697,7 +717,7 @@ nextpIndx:
With jj(node)
If .ListExists Then
id = .Value("id_str")
If _TempPostsList.Contains(id) Then j.Dispose() : Exit Sub Else ObtainMedia(.Self, id, .Value("created_at"))
If _TempPostsList.Contains(id) Then j.Dispose() : Exit Sub Else ObtainMedia(.Self, id, .Value("created_at"),,,, jj)
Exit For
End If
End With
@@ -718,11 +738,27 @@ nextpIndx:
#End Region
#Region "Obtain media"
Private Sub ObtainMedia(ByVal e As EContainer, ByVal PostID As String, ByVal PostDate As String, Optional ByVal State As UStates = UStates.Unknown,
Optional ByVal Attempts As Integer = 0, Optional ByVal SpecialFolder As String = Nothing)
Optional ByVal Attempts As Integer = 0, Optional ByVal SpecialFolder As String = Nothing,
Optional ByVal RootElem As EContainer = Nothing)
Dim s As EContainer = e({"extended_entities", "media"})
If If(s?.Count, 0) = 0 Then s = e({"retweeted_status", "extended_entities", "media"})
If If(s?.Count, 0) = 0 Then s = e({"retweeted_status_result", "result", "legacy", "extended_entities", "media"})
Dim txt$ = If(DownloadText, e.Value("full_text"), String.Empty)
Dim txt$ = String.Empty
If DownloadText Then
txt = e.Value("full_text")
If RootElem.ListExists Then
For Each n As String() In RichTextNode
With RootElem(n)
If Not .Self Is Nothing AndAlso Not .Value.IsEmptyString Then
If Not txt.IsEmptyString AndAlso .Value.Contains(txt) Then txt = String.Empty
If txt.IsEmptyString Then txt = .Value Else txt = $"{ .Value}{vbCr}{vbCr}----{vbCr}{vbCr}{txt}"
Exit For
End If
End With
Next
End If
End If
Dim mUrl$
Dim media As UserMedia
@@ -851,10 +887,25 @@ nextpIndx:
Private Class TwitterGDL : Inherits GDL.GDLBatch
Private ReadOnly KillOnLimit As Boolean
Friend LimitReached As Boolean = False
Private _GetOnlyUserInfo As Boolean = False
Friend Overrides Property MyWorkingDirectory As SFile
Get
Return If(MyBase.MyWorkingDirectory.IsEmptyString, If(FileExchanger?.RootDirectory, MyBase.MyWorkingDirectory), MyBase.MyWorkingDirectory)
End Get
Set(ByVal dir As SFile)
MyBase.MyWorkingDirectory = dir
End Set
End Property
Friend Property GetOnlyUserInfo As Boolean
Get
Return _GetOnlyUserInfo And Not MyWorkingDirectory.IsEmptyString
End Get
Set(ByVal __GetOnlyUserInfo As Boolean)
_GetOnlyUserInfo = __GetOnlyUserInfo
End Set
End Property
Friend Sub New(ByVal Dir As SFile, ByVal _Token As CancellationToken, ByVal _KillOnLimit As Boolean)
MyBase.New(_Token)
Commands.Clear()
If Not Dir.IsEmptyString Then ChangeDirectory(Dir)
MyBase.New(_Token,, Dir)
KillOnLimit = _KillOnLimit
End Sub
Protected Overrides Async Function Validate(ByVal Value As String) As Task
@@ -862,11 +913,15 @@ nextpIndx:
End Function
Private Function IdExists(ByVal Value As String) As Boolean
Try
If GetOnlyUserInfo Then
Return CheckForData()
Else
Value = Value.StringTrim
If Not Value.IsEmptyString AndAlso (Value.StartsWith("*") Or Value.StartsWith(".\gallery-dl\")) Then
Dim id$ = Value.Split("\").Last.Split(".").First.Split("_").First
If Not id.IsEmptyString Then Return TempPostsList.Contains(id)
End If
End If
Catch ex As Exception
End Try
Return False
@@ -874,8 +929,14 @@ nextpIndx:
Protected Overrides Async Sub ErrorDataReceiver(ByVal Sender As Object, ByVal e As DataReceivedEventArgs)
Await Task.Run(Sub() CheckForLimit(e.Data))
End Sub
Private Function CheckForData()
If GetOnlyUserInfo Then
If SFile.GetFiles(MyWorkingDirectory, "*.txt",, EDP.ReturnValue).Count > 2 Then Return True
End If
Return False
End Function
Private Sub CheckForLimit(ByVal Value As String)
If Token.IsCancellationRequested Or (KillOnLimit AndAlso Not ProcessKilled AndAlso
If CheckForData() Or Token.IsCancellationRequested Or (KillOnLimit AndAlso Not ProcessKilled AndAlso
Not Value.IsEmptyString AndAlso (Value.ToLower.Contains("for rate limit reset") OrElse
Not CStr(RegexReplace(Value, GdlLimitRegEx)).IsEmptyString)) Then
LimitReached = True
@@ -1024,11 +1085,12 @@ nextpIndx:
.AutoClear = True,
.AutoReset = True,
.CommandPermanent = $"chcp {BatchExecutor.UnicodeEncoding}",
.FileExchanger = confCache
.FileExchanger = confCache,
.GetOnlyUserInfo = NotUserExistsAttempts > 0
}
tgdl.FileExchanger.DeleteCacheOnDispose = False
tgdl.FileExchanger.DeleteRootOnDispose = False
For i As Byte = 0 To IIf(IsCommunity, 0, 3)
For i As Byte = 0 To IIf(IsCommunity Or NotUserExistsAttempts > 0, 0, 3)
dir = rootDir.NewPath
dir.Exists(SFO.Path, True, EDP.ThrowException)
outList.Add(dir)
@@ -1039,6 +1101,20 @@ nextpIndx:
Else
command &= GdlGetIdFilterString()
End If
If NotUserExistsAttempts > 0 Then
Select Case NotUserExistsAttempts
Case 1 : command &= $"{urlPrePattern}{NameTrue}/media" : currentModel = DownloadModels.Media : process = True
Case 2
If ID.IsEmptyString Then
process = False
Else
command &= $"https://x.com/intent/user?user_id={ID}"
currentModel = DownloadModels.Media
process = True
End If
Case Else : process = False
End Select
Else
Select Case i
Case 0 : command &= $"{urlPrePattern}{NameTrue}/media" : currentModel = DownloadModels.Media : process = dm.Contains(currentModel) Or IsCommunity
Case 1 : command &= $"{urlPrePattern}{NameTrue}" : currentModel = DownloadModels.Profile : process = dm.Contains(currentModel)
@@ -1046,6 +1122,7 @@ nextpIndx:
Case 3 : command &= $"{urlPrePattern}{NameTrue}/likes" : currentModel = DownloadModels.Likes : process = dm.Contains(currentModel)
Case Else : process = False
End Select
End If
'#If DEBUG Then
'Debug.WriteLine(command)
'#End If
@@ -1129,17 +1206,19 @@ nextpIndx:
Dim cache As CacheKeeper = Nothing
Try
If ContentMissingExists Or (_ReparseLikes And LikesPosts.Count > 0) Then
Const __entries$ = "entries"
Dim m As UserMedia, mTmp As UserMedia
Dim PostDate$
Dim nodes As List(Of String()) = GetContainerSubnodes()
Dim node$()
Dim entriesNode As Predicate(Of EContainer) = Function(ee) ee.Contains(__entries)
Dim j As EContainer, n As EContainer
Dim f As SFile
Dim i%, ii%
Dim files As List(Of SFile)
Dim lim%
Dim specFolder$ = IIf(_ReparseLikes, "Likes", String.Empty)
ResetFileNameProvider()
GDLResetFileNameProvider()
cache = If(IsSingleObjectDownload, Settings.Cache, CreateCache())
If _ReparseLikes Then lim = LikesPosts.Count Else lim = _ContentList.Count
ProgressPre.ChangeMax(lim)
@@ -1165,10 +1244,10 @@ nextpIndx:
files = SFile.GetFiles(f, "*.txt")
If files.ListExists Then
For ii = 0 To files.Count - 1
f = RenameGdlFile(files(ii), ii)
f = GDLRenameFile(files(ii), ii)
j = JsonDocument.Parse(f.GetText)
If Not j Is Nothing Then
With j.ItemF({"data", 0, "instructions", 0, "entries"})
With j.ItemF({"data", 0, "instructions", entriesNode, __entries})
If .ListExists Then
If IsSingleObjectDownload Or DownloadBroadcasts Then
mTmp = ExtractBroadcast(.Self, m.Post.ID, String.Empty, nodes)
@@ -1183,7 +1262,7 @@ nextpIndx:
If .ListExists Then
PostDate = String.Empty
If .Contains("created_at") Then PostDate = .Value("created_at") Else PostDate = String.Empty
ObtainMedia(.Self, m.Post.ID, PostDate, UStates.Missing, m.Attempts, specFolder)
ObtainMedia(.Self, m.Post.ID, PostDate, UStates.Missing, m.Attempts, specFolder, n)
rList.ListAddValue(i, LNC)
End If
End With

View File

@@ -14,7 +14,11 @@ Imports PersonalUtilities.Functions.RegularExpressions
Namespace API.Xhamster
<Manifest(XhamsterSiteKey), SavedPosts, SpecialForm(True), SpecialForm(False), TaskGroup(SettingsCLS.TaskStackNamePornSite)>
Friend Class SiteSettings : Inherits SiteSettingsBase
#Region "Consts"
Friend Const GetMomentsCaption As String = "Get moments (short videos)"
#End Region
#Region "Declarations"
Private Const CAT_YTDLP As String = "yt-dlp support"
<PXML("Domains"), PClonable> Private ReadOnly Property SiteDomains As PropertyValue
Private Shadows ReadOnly Property DefaultInstance As SiteSettings
Get
@@ -33,6 +37,19 @@ Namespace API.Xhamster
ControlToolTip:="If enabled and the video is downloaded in a non-native format, the video will be re-encoded." & vbCr &
"Attention! Enabling this setting results in maximum CPU usage."), PXML, PClonable>
Friend ReadOnly Property ReencodeVideos As PropertyValue
<PropertyOption(ControlText:="Use yt-dlp to get file info", ControlToolTip:="If checked, yt-dlp will be used to get information about the file", Category:=CAT_YTDLP), PXML, PClonable, HiddenControl>
Friend ReadOnly Property UseYTDLPJSON As PropertyValue
<PropertyOption(ControlText:="Use yt-dlp to download the file", ControlToolTip:="If checked, yt-dlp will be used to download the file instead of the internal algorithm", Category:=CAT_YTDLP), PXML, PClonable, HiddenControl>
Friend ReadOnly Property UseYTDLPDownload As PropertyValue
Private ReadOnly Property UseYtDlp As Boolean
Get
Return CBool(UseYTDLPJSON.Value) Or CBool(UseYTDLPDownload.Value)
End Get
End Property
<PropertyOption(ControlText:="Disable internal algorithm", ControlToolTip:="If checked, the internal algorithm will be forcibly disabled and replaced with yt-dlp", Category:=CAT_YTDLP), PXML, PClonable, HiddenControl>
Friend ReadOnly Property UseYTDLPForceDisableInternal As PropertyValue
<PropertyOption(ControlText:=GetMomentsCaption, Category:=DeclaredNames.CAT_UserDefs), PXML, PClonable>
Friend ReadOnly Property GetMoments As PropertyValue
<DoNotUse> Friend Overrides Property DownloadText As PropertyValue
<DoNotUse> Friend Overrides Property DownloadTextPosts As PropertyValue
<DoNotUse> Friend Overrides Property DownloadTextSpecialFolder As PropertyValue
@@ -46,12 +63,17 @@ Namespace API.Xhamster
Domains.DestinationProp = SiteDomains
DownloadUHD = New PropertyValue(False)
ReencodeVideos = New PropertyValue(False)
UseYTDLPJSON = New PropertyValue(True)
UseYTDLPDownload = New PropertyValue(True)
UseYTDLPForceDisableInternal = New PropertyValue(False)
GetMoments = New PropertyValue(True)
_SubscriptionsAllowed = True
UrlPatternUser = "https://xhamster.com/{0}/{1}"
UserRegex = RParams.DMS($"/({UserOption}|{ChannelOption}|{P_Creators})/([^/]+)(\Z|.*)", 0, RegexReturn.ListByMatch)
UserRegex = RParams.DMS($"/({UserOption}|{UserOption2}|{ChannelOption}|{P_Creators})/([^/]+)(\Z|.*)", 0, RegexReturn.ListByMatch)
ImageVideoContains = "xhamster"
UserOptionsType = GetType(UserExchangeOptions)
UseNetscapeCookies = True
End Sub
Friend Overrides Sub EndInit()
Domains.PopulateInitialDomains(SiteDomains.Value)
@@ -75,7 +97,7 @@ Namespace API.Xhamster
Return New UserData
End Function
Friend Overrides Function Available(ByVal What As ISiteSettings.Download, ByVal Silent As Boolean) As Boolean
If Settings.UseM3U8 AndAlso MyBase.Available(What, Silent) Then
If (Not UseYtDlp Or (UseYtDlp And Settings.YtdlpFile.Exists)) AndAlso Settings.UseM3U8 AndAlso MyBase.Available(What, Silent) Then
If What = ISiteSettings.Download.SavedPosts Then
Return Responser.CookiesExists
Else
@@ -87,7 +109,7 @@ Namespace API.Xhamster
End Function
Friend Overrides Function GetUserUrl(ByVal User As IPluginContentProvider) As String
With DirectCast(User, UserData)
If Not .SiteMode = SiteModes.User Then
If Not .SiteMode = SiteModes.User OrElse .IsCreator Then
Return .GetNonUserUrl(0)
Else
Return String.Format(UrlPatternUser, IIf(.IsChannel, ChannelOption, UserOption), .NameTrue)
@@ -96,7 +118,8 @@ Namespace API.Xhamster
End Function
#Region "IsMyUser, IsMyImageVideo"
Friend Const ChannelOption As String = "channels"
Private Const UserOption As String = "users"
Friend Const UserOption As String = "users/profiles"
Private Const UserOption2 As String = "users"
Friend Const P_Search As String = "search"
Friend Const P_Tags As String = "tags"
Friend Const P_Categories As String = "categories"

View File

@@ -6,14 +6,16 @@
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports System.Text
Imports System.Threading
Imports SCrawler.API.Base
Imports SCrawler.API.YouTube.Objects
Imports PersonalUtilities.Functions.RegularExpressions
Imports PersonalUtilities.Functions.XML
Imports PersonalUtilities.Functions.XML.Base
Imports PersonalUtilities.Functions.RegularExpressions
Imports PersonalUtilities.Tools
Imports PersonalUtilities.Tools.Web.Clients
Imports PersonalUtilities.Tools.Web.Documents.JSON
Imports SCrawler.API.Base
Imports SCrawler.API.YouTube.Objects
Imports UTypes = SCrawler.API.Base.UserMedia.Types
Namespace API.Xhamster
Friend Class UserData : Inherits UserDataBase : Implements IPSite
@@ -51,7 +53,7 @@ Namespace API.Xhamster
End Property
Friend Property QueryString As String Implements IPSite.QueryString
Get
If SiteMode = SiteModes.User Then
If SiteMode = SiteModes.User And Not IsCreator Then
Return String.Empty
Else
Return GetNonUserUrl(0)
@@ -71,7 +73,7 @@ Namespace API.Xhamster
End Structure
Private ReadOnly _TempPhotoData As List(Of UserMedia)
Private Function UpdateUserOptions(Optional ByVal Force As Boolean = False, Optional ByVal NewUrl As String = Nothing) As Boolean
If Not Force OrElse (Not SiteMode = SiteModes.User AndAlso Not NewUrl.IsEmptyString AndAlso MyFileSettings.Exists) Then
If Not Force OrElse (Not NewUrl.IsEmptyString AndAlso MyFileSettings.Exists) Then
Dim eObj As Plugin.ExchangeOptions = Nothing
If Force Then eObj = MySettings.IsMyUser(NewUrl)
If (Force And Not eObj.UserName.IsEmptyString) Or (Not Force And NameTrue(True).IsEmptyString) Then
@@ -175,17 +177,31 @@ Namespace API.Xhamster
Friend Overrides Sub ExchangeOptionsSet(ByVal Obj As Object)
If Not Obj Is Nothing AndAlso TypeOf Obj Is UserExchangeOptions Then DirectCast(Obj, UserExchangeOptions).Apply(Me)
End Sub
Private MyCache As CacheKeeper = Nothing
Private Sub ResetCache()
MyCache.DisposeIfReady(False)
MyCache = Nothing
End Sub
Private Function GetCache() As CacheKeeper
If IsSingleObjectDownload Then
Return Settings.Cache
Else
If MyCache Is Nothing Then MyCache = CreateCache()
Return MyCache
End If
End Function
#End Region
#Region "Initializer"
Friend Sub New()
UseInternalM3U8Function = True
UseInternalDownloadFileFunction = True
UseClientTokens = True
_TempPhotoData = New List(Of UserMedia)
SessionPosts = New List(Of String)
End Sub
#End Region
#Region "Download functions"
Friend Function GetNonUserUrl(ByVal Page As Integer) As String
Friend Function GetNonUserUrl(ByVal Page As Integer, Optional ByVal GetShorts As Boolean = False) As String
Const newest$ = "/newest"
If SiteMode = SiteModes.User And Not IsCreator Then
Return String.Empty
@@ -202,8 +218,10 @@ Namespace API.Xhamster
End Select
url &= $"/{NameTrue}"
If GetShorts And (SiteMode = SiteModes.User Or IsCreator) Then url &= "/shorts"
Dim args$ = Arguments
If (args.IsEmptyString OrElse Not args.Contains(newest)) And Not SiteMode = SiteModes.Search Then url &= newest
If (args.IsEmptyString OrElse Not args.Contains(newest)) And Not SiteMode = SiteModes.Search And Not IsCreator Then url &= newest
If Page > 1 Then
If args.IsEmptyString Then
If SiteMode = SiteModes.Search Then
@@ -234,6 +252,9 @@ Namespace API.Xhamster
Private SearchPostsCount As Integer = 0
Private ReadOnly SessionPosts As List(Of String)
Private _PageVideosRepeat As Integer = 0
Friend Overrides Sub DownloadData(Token As CancellationToken)
Try : MyBase.DownloadData(Token) : Finally : ResetCache() : End Try
End Sub
Protected Overrides Sub DownloadDataF(ByVal Token As CancellationToken)
Try
_TempPhotoData.Clear()
@@ -242,7 +263,7 @@ Namespace API.Xhamster
SessionPosts.Clear()
Responser.CookiesAsHeader = True
If DownloadVideos Then DownloadData(1, True, False, Token)
If GetMoments Then DownloadData(1, True, True, Token)
If DownloadVideos And GetMoments Then DownloadData(1, True, True, Token)
If Not IsChannel And Not IsCreator And DownloadImages And Not IsSubscription Then
DownloadData(1, False, False, Token)
ReparsePhoto(Token)
@@ -277,7 +298,10 @@ Namespace API.Xhamster
End If
ElseIf Not SiteMode = SiteModes.Search Then
If IsVideo Then
If GetMoments Then containerNodes.Add({"momentListComponent", "videoThumbProps"})
If GetMoments Then
containerNodes.Add({"momentListComponent", "videoThumbProps"})
containerNodes.Add({"momentsComponent", "videoListProps", "videoThumbProps"})
End If
containerNodes.Add({"trendingVideoListComponent", "models"})
containerNodes.Add({"pagesCategoryComponent", "trendingVideoListProps", "models"})
containerNodes.Add({"trendingVideoSectionComponent", "videoModels"})
@@ -287,6 +311,7 @@ Namespace API.Xhamster
containerNodes.Add({"videoListComponent", "videoThumbProps"})
Else
containerNodes.Add({"userGalleriesCollection"})
containerNodes.Add({"contentComponent", "items"})
End If
End If
@@ -299,9 +324,9 @@ Namespace API.Xhamster
URL = GetNonUserUrl(Page)
containerNodes.Add({"searchResult", "models"})
ElseIf IsCreator Or SiteMode = SiteModes.Tags Or SiteMode = SiteModes.Categories Or SiteMode = SiteModes.Pornstars Then
URL = GetNonUserUrl(Page)
URL = GetNonUserUrl(Page, IsCreator And GetMoments)
Else
URL = $"https://xhamster.com/users/{NameTrue}/{If(GetMoments, "moments", IIf(IsVideo, "videos", "photos"))}{IIf(Page = 1, String.Empty, $"/{Page}")}"
URL = $"https://xhamster.com/{SiteSettings.UserOption}/{NameTrue}/{If(GetMoments, "moments", IIf(IsVideo, "videos", "photos"))}{IIf(Page = 1, String.Empty, $"/{Page}")}"
End If
ThrowAny(Token)
@@ -401,9 +426,9 @@ Namespace API.Xhamster
If _TempMediaList(i).Type = UTypes.VideoPre Then
m = _TempMediaList(i)
If Not m.URL_BASE.IsEmptyString Then
m2 = Nothing
m2 = m
ThrowAny(Token)
If GetM3U8(m2, m.URL_BASE, m.SpecialFolder) Then
If GetM3U8_Init(m2, m.URL_BASE, m.SpecialFolder, i) Then
m2.URL_BASE = m.URL_BASE
_TempMediaList(i) = m2
Else
@@ -431,9 +456,9 @@ Namespace API.Xhamster
If Not DownloadTopCount.HasValue OrElse c <= DownloadTopCount.Value Then
m = _TempMediaList(i)
If Not m.URL_BASE.IsEmptyString Then
m2 = Nothing
m2 = m
ThrowAny(Token)
If GetM3U8(m2, m.URL_BASE, String.Empty) Then
If GetM3U8_Init(m2, m.URL_BASE, String.Empty, i) Then
m2.URL_BASE = m.URL_BASE
_TempMediaList(i) = m2
c += 1
@@ -472,7 +497,7 @@ Namespace API.Xhamster
If Not r.IsEmptyString Then
Using j As EContainer = JsonDocument.Parse(r).XmlIfNothing
If j.Count > 0 Then
MaxPage = j.Value({"pagination"}, "maxPage").FromXML(Of Integer)(-1)
MaxPage = j.Value({"pagination"}, "maxPage").IfNullOrEmpty(j.Value({"galleryPage", "paginationProps"}, "lastPageNumber")).FromXML(Of Integer)(-1)
With j({"photosGalleryModel"}, "photos")
If .ListExists Then
For Each e In .Self
@@ -514,7 +539,7 @@ Namespace API.Xhamster
If m.State = UserMedia.States.Missing AndAlso Not m.URL_BASE.IsEmptyString Then
ThrowAny(Token)
m2 = Nothing
If GetM3U8(m2, m.URL_BASE, m.SpecialFolder) Then
If GetM3U8_Init(m2, m.URL_BASE, m.SpecialFolder, i) Then
m2.URL_BASE = m.URL_BASE
m2.State = UserMedia.States.Missing
m2.Attempts = m.Attempts
@@ -535,25 +560,85 @@ Namespace API.Xhamster
End Sub
#End Region
#Region "GetM3U8"
Private Overloads Function GetM3U8(ByRef m As UserMedia, ByVal URL As String, ByVal SpecFolder As String) As Boolean
Private Structure XMMediaInfo : Implements IComparable(Of XMMediaInfo)
Friend URL As String
Friend Type As UTypes
Friend IsInternal As Boolean
Friend Thumb As String
Friend FormatID As String
Friend Width As Integer
Friend Height As Integer
Friend Title As String
Private Function CompareTo(ByVal Other As XMMediaInfo) As Integer Implements IComparable(Of XMMediaInfo).CompareTo
Return Width.CompareTo(Other.Width) * -1
End Function
End Structure
Private Function GetM3U8_Init(ByRef m As UserMedia, ByVal URL As String, ByVal SpecFolder As String, ByVal n As Integer) As Boolean
Try
If Not URL.IsEmptyString Then
Dim r$ = Responser.GetResponse(URL)
If Not r.IsEmptyString Then r = RegexReplace(r, HtmlScript)
Dim IsInternal As Boolean = False
Dim r$ = GetMediaInfo(URL, n, IsInternal)
If Not r.IsEmptyString Then
Using j As EContainer = JsonDocument.Parse(r)
If j.ListExists Then
m = ExtractMedia(j("videoModel"), UTypes.VideoPre,,,, SpecFolder)
m.URL_BASE = URL
If IsSubscription Then
With j("videoModel")
If IsInternal AndAlso GetM3U8_Internal(m, URL, j, SpecFolder) Then
Return True
Else
Dim xmm As New XMMediaInfo
Dim __checkURL As Func(Of EContainer, XMMediaInfo, XMMediaInfo) =
Function(ByVal jj As EContainer, ByVal __xmm As XMMediaInfo) As XMMediaInfo
With jj.Value("url").StringToLower
If Not .IsEmptyString AndAlso .EndsWith(".m3u8") Or .EndsWith(".mp4") Then __xmm.URL = .Self
End With
Return __xmm
End Function
Dim __applyXMM As Func(Of EContainer, XMMediaInfo, XMMediaInfo) =
Function(ByVal jj As EContainer, ByVal __xmm As XMMediaInfo) As XMMediaInfo
With jj
__xmm.Type = IIf(__xmm.URL.ToLower.EndsWith(".m3u8"), UTypes.m3u8, UTypes.Video)
__xmm.Width = AConvert(Of Integer)(.Value("width"), 1, EDP.ReturnValue)
__xmm.Height = AConvert(Of Integer)(.Value("height"), 1, EDP.ReturnValue)
__xmm.FormatID = .Value("format_id")
End With
Return __xmm
End Function
xmm = __checkURL(j, xmm)
If Not xmm.URL.IsEmptyString Then
xmm = __applyXMM(j, xmm)
Else
With j("formats")
If .ListExists Then
m.URL = .Value("thumbURL").IfNullOrEmpty(.Value("previewThumbURL"))
Return Not m.URL.IsEmptyString
Dim l As New List(Of XMMediaInfo)
Dim tmpXMM As XMMediaInfo
For Each format As EContainer In .Self
tmpXMM = New XMMediaInfo
tmpXMM = __checkURL(format, tmpXMM)
If Not tmpXMM.URL.IsEmptyString Then
tmpXMM = __applyXMM(format, tmpXMM)
l.Add(tmpXMM)
End If
Next
If l.Count > 0 Then
If Not CBool(MySettings.DownloadUHD.Value) AndAlso l.LongCount(Function(v) v.Height <= 1080) > 0 Then _
l.RemoveAll(Function(v) v.Height > 1080)
l.Sort()
xmm = l.First
l.Clear()
End If
End If
End With
Else
Return GetM3U8(m, j, SpecFolder)
End If
If Not xmm.URL.IsEmptyString Then
xmm.IsInternal = False
xmm.Thumb = j.Value("thumbnail")
xmm.Title = TitleHtmlConverter(j.Value("title").IfNullOrEmpty(j.Value("fulltitle")))
If Not xmm.Title.IsEmptyString Then m.File.Name = xmm.Title
m.Type = xmm.Type
m.URL = IIf(IsSubscription, xmm.Thumb, xmm.URL)
m.Object = xmm
m.SpecialFolder = SpecFolder
Return True
End If
End If
End If
End Using
@@ -561,16 +646,127 @@ Namespace API.Xhamster
End If
Return False
Catch ex As Exception
Return ErrorsDescriber.Execute(EDP.ReturnValue, ex, $"[{ToStringForLog()}]: API.Xhamster.GetM3U8({URL})", False)
Return ErrorsDescriber.Execute(EDP.ReturnValue, ex, $"[{ToStringForLog()}]: API.Xhamster.GetM3U8_Init({URL})", False)
End Try
End Function
Private Overloads Function GetM3U8(ByRef m As UserMedia, ByVal j As EContainer, ByVal SpecFolder As String) As Boolean
Dim node As EContainer = j({"xplayerSettings", "sources", "hls"})
If node.ListExists Then
Dim url$ = node.GetNode({New NodeParams("url", True, True, True, True, 2)}).XmlIfNothingValue
If Not url.IsEmptyString Then m.URL = url : m.Type = UTypes.m3u8 : Return True
Private Function GetMediaInfo(ByVal URL As String, ByVal n As Integer, ByRef IsInternal As Boolean) As String
Try
If Not URL.IsEmptyString Then
Dim r$ = String.Empty
Dim f As SFile
If IsSubscription Then
Try
If Not CBool(MySettings.UseYTDLPForceDisableInternal.Value) Then r = Responser.GetResponse(URL)
Catch exr As Exception
ErrorsDescriber.Execute(EDP.SendToLog, exr, $"[{ToStringForLog()}]: API.Xhamster.GetMediaInfo({URL})", False)
End Try
If Not r.IsEmptyString Then r = RegexReplace(r, HtmlScript)
If Not r.IsEmptyString Then
IsInternal = True
Return r
Else
f = YTDLPGetInfo(URL, n)
If f.Exists Then IsInternal = False : Return f.GetText
End If
Else
f = YTDLPGetInfo(URL, n)
If f.Exists Then IsInternal = False : Return f.GetText
End If
End If
Return String.Empty
Catch ex As Exception
Return ErrorsDescriber.Execute(EDP.SendToLog + EDP.ReturnValue, ex, $"[{ToStringForLog()}]: API.Xhamster.GetMediaInfo({URL})", String.Empty)
End Try
End Function
Private Function GetM3U8_Internal(ByRef m As UserMedia, ByVal URL As String, ByVal j As EContainer, ByVal SpecFolder As String) As Boolean
Try
If j.ListExists Then
m = ExtractMedia(j("videoModel"), UTypes.VideoPre,,,, SpecFolder)
m.URL_BASE = URL
m.SpecialFolder = SpecFolder
If IsSubscription Then
With j("videoModel")
If .ListExists Then
m.URL = .Value("thumbURL").IfNullOrEmpty(.Value("previewThumbURL"))
m.Object = New XMMediaInfo With {
.IsInternal = True,
.Thumb = m.URL,
.URL = URL,
.Type = UTypes.VideoPre
}
Return Not m.URL.IsEmptyString
End If
End With
Else
Return GetM3U8_Internal_GetURL(m, j)
End If
End If
Return False
Catch ex As Exception
Return ErrorsDescriber.Execute(EDP.ReturnValue, ex, $"[{ToStringForLog()}]: API.Xhamster.GetM3U8_Internal({URL})", False)
End Try
End Function
Private Function GetM3U8_Internal_GetURL(ByRef m As UserMedia, ByVal j As EContainer, Optional ByVal r As Integer = 0) As Boolean
Const urlNode$ = "url"
Dim node As EContainer = j({"xplayerSettings", "sources", If(r = 0, "hls", "standard")})
Dim t As UTypes = UTypes.Undefined
If node.ListExists Then
Dim url$ 'node.GetNode({New NodeParams("url", True, True, True, True, 2)}).XmlIfNothingValue
Dim jn As EContainer, jn2 As EContainer
Dim __getUrl As Func(Of EContainer, String) = Function(jj) If(jj.Contains(urlNode), jj.Value(urlNode), String.Empty)
url = __getUrl(node)
If url.IsEmptyString Then
For Each jn In node
If jn.Contains(urlNode) Then
url = __getUrl(jn)
ElseIf jn.Count > 0 Then
For Each jn2 In jn
url = __getUrl(jn2)
If Not url.IsEmptyString Then Exit For
Next
End If
If Not url.IsEmptyString Then Exit For
Next
End If
If Not url.IsEmptyString Then
If url.ToLower.EndsWith(".m3u8") Then
t = UTypes.m3u8
ElseIf url.ToLower.EndsWith(".mp4") Then
t = UTypes.Video
End If
If Not t = UTypes.Undefined Then
m.URL = url
m.Type = t
m.Object = New XMMediaInfo With {
.IsInternal = True,
.Type = t,
.URL = url,
.Thumb = j.Value({"videoModel"}, "thumbURL").IfNullOrEmpty(j.Value({"videoModel"}, "previewThumbURL"))
}
Return True
End If
End If
End If
If r = 0 Then Return GetM3U8_Internal_GetURL(m, j, r + 1)
Return False
End Function
#End Region
#Region "yt-dlp support"
#Disable Warning IDE0060
Private Function YTDLPGetInfo(ByVal URL As String, ByVal n As Integer) As SFile
#Enable Warning
Try
Dim cc As CacheKeeper = GetCache()
cc.Validate()
Dim path As SFile = cc.NewPath
Dim c$ = If(MySettings.CookiesNetscapeFile.Exists, $" --no-cookies-from-browser --cookies ""{MySettings.CookiesNetscapeFile}""", String.Empty)
Dim cmd$ = $"""{Settings.YtdlpFile}"" --write-info-json --skip-download{c} {URL} -o ""{path.PathWithSeparator}file"""
path.Exists()
Using ytdlp As New YTDLP.YTDLPBatch(TokenPersonal,, path) : ytdlp.Encoding = Settings.CMDEncoding : ytdlp.Execute(cmd) : End Using
Return SFile.GetFiles(path, "*.json",, EDP.ReturnValue).FirstOrDefault
Catch ex As Exception
Return ErrorsDescriber.Execute(EDP.SendToLog + EDP.ReturnValue, ex, $"API.Xhamster.UserData.YTDLPGetInfo({URL})", New SFile)
End Try
End Function
#End Region
#Region "DownloadSingleObject"
@@ -583,9 +779,43 @@ Namespace API.Xhamster
Protected Overrides Sub DownloadContent(ByVal Token As CancellationToken)
DownloadContentDefault(Token)
End Sub
Private Function XMMObjectExists(ByVal Media As UserMedia) As Boolean
Return Not IsNothing(Media.Object) AndAlso TypeOf Media.Object Is XMMediaInfo
End Function
Protected Overrides Function DownloadM3U8(ByVal URL As String, ByVal Media As UserMedia, ByVal DestinationFile As SFile, ByVal Token As CancellationToken) As SFile
If CBool(MySettings.UseYTDLPDownload.Value) Then
If XMMObjectExists(Media) Then Return YTDLPDownload(Media, DestinationFile, Token)
Return Nothing
Else
Media.File = DestinationFile
Return M3U8.Download(Media, Responser, MySettings.DownloadUHD.Value, Token, Progress, Not IsSingleObjectDownload, MySettings.ReencodeVideos.Value)
End If
End Function
Protected Overrides Function ValidateDownloadFile(ByVal URL As String, ByVal Media As UserMedia, ByRef Interrupt As Boolean) As Boolean
If Not Media.IsPhotoType AndAlso CBool(MySettings.UseYTDLPDownload.Value) Then
If Not Media.URL_BASE.IsEmptyString And XMMObjectExists(Media) AndAlso
Not DirectCast(Media.Object, XMMediaInfo).FormatID.IsEmptyString Then Return True
Interrupt = True
End If
Return False
End Function
Protected Overrides Function DownloadFile(ByVal URL As String, ByVal Media As UserMedia, ByVal DestinationFile As SFile, ByVal Token As CancellationToken) As SFile
Return YTDLPDownload(Media, DestinationFile, Token)
End Function
Private Function YTDLPDownload(ByVal Media As UserMedia, ByVal DestinationFile As SFile, ByVal Token As CancellationToken) As SFile
DestinationFile.Extension = "mp4"
Dim c$ = If(MySettings.CookiesNetscapeFile.Exists, $" --no-cookies-from-browser --cookies ""{MySettings.CookiesNetscapeFile}""", String.Empty)
Dim cmd$ = $"""{Settings.YtdlpFile}"" --format {DirectCast(Media.Object, XMMediaInfo).FormatID}{c} {Media.URL_BASE} -o ""{DestinationFile}"""
Using ytdlp As New YTDLP.YTDLPBatch(Token,, DestinationFile)
ytdlp.Encoding = Settings.CMDEncoding
ytdlp.CreateFileExchanger(GetCache)
If IsSingleObjectDownload Then ytdlp.SetProgress(Progress, Function(v) v / 100)
ytdlp.Execute(cmd)
End Using
Return DestinationFile
End Function
Protected Overrides Function DownloadContentDefault_ConvertWebp(ByVal m As UserMedia, ByVal Process As Boolean) As SFile
Return DownloadContentDefault_ConvertWebp_TestImg(m, Process)
End Function
#End Region
#Region "Create media"
@@ -651,7 +881,7 @@ Namespace API.Xhamster
#End Region
#Region "IDisposable support"
Protected Overrides Sub Dispose(ByVal disposing As Boolean)
If Not disposedValue And disposing Then _TempPhotoData.Clear() : SessionPosts.Clear()
If Not disposedValue And disposing Then _TempPhotoData.Clear() : SessionPosts.Clear() : ResetCache()
MyBase.Dispose(disposing)
End Sub
#End Region

View File

@@ -10,16 +10,19 @@ Imports SCrawler.API.Base
Imports SCrawler.Plugin.Attributes
Namespace API.Xhamster
Friend NotInheritable Class UserExchangeOptions : Inherits API.Base.EditorExchangeOptionsBase_P
<PSetting(Address:=SettingAddress.User, Caption:="Get moments")>
<PSetting(Address:=SettingAddress.User, Caption:=SiteSettings.GetMomentsCaption)>
Friend Property GetMoments As Boolean = False
Friend Sub New()
MyBase.New
End Sub
Friend Sub New(ByVal u As IPSite)
MyBase.New(DirectCast(u, UserData))
GetMoments = DirectCast(u, UserData).GetMoments
End Sub
Friend Overrides Sub Apply(ByRef u As IPSite)
Friend Sub New(ByVal s As SiteSettings)
MyBase.New(s)
GetMoments = s.GetMoments.Value
End Sub
Friend Overrides Sub Apply(ByRef u As UserDataBase)
MyBase.Apply(u)
DirectCast(u, UserData).GetMoments = GetMoments
End Sub

View File

@@ -121,6 +121,7 @@ Namespace API.YouTube
Friend Overrides Sub ExchangeOptionsSet(ByVal Obj As Object)
If Not Obj Is Nothing AndAlso TypeOf Obj Is UserExchangeOptions Then
With DirectCast(Obj, UserExchangeOptions)
.Apply(Me)
DownloadYTVideos = .DownloadVideos
DownloadYTShorts = .DownloadShorts
DownloadYTPlaylists = .DownloadPlaylists

View File

@@ -8,7 +8,7 @@
' but WITHOUT ANY WARRANTY
Imports SCrawler.Plugin.Attributes
Namespace API.YouTube
Friend Class UserExchangeOptions
Friend Class UserExchangeOptions : Inherits SCrawler.API.Base.EditorExchangeOptionsBase
<PSetting(Caption:="Download videos")>
Friend Property DownloadVideos As Boolean
<PSetting(Caption:="Download shorts")>
@@ -23,7 +23,14 @@ Namespace API.YouTube
Friend Property UseCookies As Boolean
<PSetting(Caption:="Channel ID", Address:=SettingAddress.User)>
Friend Property ChannelID As String
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property UserName As String
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property DownloadText As Boolean
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property DownloadTextPosts As Boolean
<PSetting(Address:=SettingAddress.None)> Friend Overrides Property DownloadTextSpecialFolder As Boolean
Friend Sub New(ByVal u As UserData)
MyBase.New(u)
_ApplyBase_Name = False
_ApplyBase_Text = False
DownloadVideos = u.DownloadYTVideos
DownloadShorts = u.DownloadYTShorts
DownloadPlaylists = u.DownloadYTPlaylists
@@ -33,6 +40,9 @@ Namespace API.YouTube
ChannelID = u.ChannelID
End Sub
Friend Sub New(ByVal s As SiteSettings)
MyBase.New(s)
_ApplyBase_Name = False
_ApplyBase_Text = False
DownloadVideos = s.DownloadVideos.Value
DownloadShorts = s.DownloadShorts.Value
DownloadPlaylists = s.DownloadPlaylists.Value

Binary file not shown.

Before

Width:  |  Height:  |  Size: 15 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 1.6 KiB

View File

@@ -17,11 +17,6 @@ Namespace DownloadObjects
Friend Class AutoDownloader : Inherits GroupParameters : Implements IIndexable, IEContainerProvider, IComparable(Of AutoDownloader)
Friend Event PauseChanged(ByVal Value As PauseModes)
Friend Event PlanChanged As Scheduler.PlanChangedEventHandler
Friend Enum Modes As Integer
None = 0
Specified = 3
Groups = 4
End Enum
Friend Const NoPauseMode As Integer = -100
Friend Enum PauseModes As Integer
Disabled = -2
@@ -188,8 +183,7 @@ Namespace DownloadObjects
End Class
#End Region
#Region "XML Names"
Private Const Name_Mode As String = "Mode"
Private Const Name_Groups As String = "Groups"
Private Const Name_Enabled As String = "Enabled"
Private Const Name_IsManual As String = "IsManual"
Private Const Name_Timer As String = "Timer"
Private Const Name_StartupDelay As String = "StartupDelay"
@@ -247,17 +241,16 @@ Namespace DownloadObjects
End Get
End Property
Friend Property Source As Scheduler
Private _Mode As Modes = Modes.None
Friend Property Mode As Modes
Private _Enabled As Boolean = False
Friend Property Enabled As Boolean
Get
Return _Mode
Return _Enabled
End Get
Set(ByVal m As Modes)
_Mode = m
If _Mode = Modes.None Then [Stop]()
Set(ByVal e As Boolean)
_Enabled = e
If Not _Enabled Then [Stop]()
End Set
End Property
Friend ReadOnly Property Groups As List(Of String)
Friend Property IsManual As Boolean = False
Friend Property Timer As Integer = DefaultTimer
Friend Property StartupDelay As Integer = 1
@@ -371,7 +364,6 @@ Namespace DownloadObjects
End Get
End Property
Friend Sub New(Optional ByVal IsNewPlan As Boolean = False)
Groups = New List(Of String)
UserKeys = New List(Of NotifiedUser)
_IsNewPlan = IsNewPlan
Initialization = False
@@ -379,10 +371,9 @@ Namespace DownloadObjects
Friend Sub New(ByVal x As EContainer)
Me.New
Initialization = True
Mode = x.Value(Name_Mode).FromXML(Of Integer)(Modes.None)
Import(x)
Enabled = x.Value(Name_Enabled).FromXML(Of Boolean)(False)
If Name.IsEmptyString Then Name = "Default"
Groups.ListAddList(x.Value(Name_Groups).StringToList(Of String)("|"), LAP.NotContainsOnly)
IsManual = x.Value(Name_IsManual).FromXML(Of Boolean)(False)
Timer = x.Value(Name_Timer).FromXML(Of Integer)(DefaultTimer)
@@ -408,8 +399,7 @@ Namespace DownloadObjects
newObj.Copy(Me)
With newObj
.Name = String.Empty
._Mode = _Mode
.Groups.ListAddList(Groups, LAP.ClearBeforeAdd)
.Enabled = Enabled
.IsManual = IsManual
.Timer = Timer
.StartupDelay = StartupDelay
@@ -441,8 +431,7 @@ Namespace DownloadObjects
End Sub
Private Function ToEContainer(Optional ByVal e As ErrorsDescriber = Nothing) As EContainer Implements IEContainerProvider.ToEContainer
Return Export(New EContainer(Scheduler.Name_Plan, String.Empty) From {
New EContainer(Name_Mode, CInt(Mode)),
New EContainer(Name_Groups, Groups.ListToString("|")),
New EContainer(Name_Enabled, Enabled.BoolToInteger),
New EContainer(Name_IsManual, IsManual.BoolToInteger),
New EContainer(Name_Timer, Timer),
New EContainer(Name_StartupDelay, StartupDelay),
@@ -467,7 +456,7 @@ Namespace DownloadObjects
If Not IsManual Or Force Then
If Init Then _StartTime = Now
_IsNewPlan = False
If Not Working And Not Mode = Modes.None Then _Working = True
If Not Working And Enabled Then _Working = True
RaiseEvent PlanChanged(Me)
End If
End Sub
@@ -556,12 +545,12 @@ Namespace DownloadObjects
Get
If _StopRequested Then _Working = False
Return (Working Or IsManual) And ((IsManual And _ForceStartRequested) Or (Not IsManual And NextExecutionDate < Now And (Not IsPaused Or IgnorePause)) Or _ForceStartRequested) And
Not _StopRequested And Not Mode = Modes.None And (Not Downloader.Working Or IgnoreDownloaderWorking)
Not _StopRequested And Enabled And (Not Downloader.Working Or IgnoreDownloaderWorking)
End Get
End Property
Friend ReadOnly Property NextDate As Date?
Get
If Not _StopRequested And Not Mode = Modes.None Then
If Not _StopRequested And Enabled Then
If IsManual Or _ForceStartRequested Then
Return Now.AddYears(-10)
ElseIf Not IsPaused And Not IsManual And Working Then
@@ -583,8 +572,6 @@ Namespace DownloadObjects
Dim Keys As New List(Of String)
Try
Dim users As New List(Of IUserData)
Dim GName$
Dim i%
Dim doRound% = -1, doLim% = Settings.Plugins.Count
Dim DownloadedUsersCount% = 0
Dim DownloadedSubscriptionsCount% = 0
@@ -614,16 +601,9 @@ Namespace DownloadObjects
Catch n_ex As Exception
End Try
End Sub
Select Case Mode
Case Modes.Specified : users.ListAddList(DownloadGroup.GetUsers(Me))
Case Modes.Groups
If Groups.Count > 0 And Settings.Groups.Count > 0 Then
For Each GName In Groups
i = Settings.Groups.IndexOf(GName)
If i >= 0 Then users.ListAddList(Settings.Groups(i).GetUsers, LAP.IgnoreICopier, LAP.NotContainsOnly)
Next
End If
End Select
If Enabled Then users.ListAddList(DownloadGroup.GetUsers(Me))
If users.Count > 0 Then
Keys.ListAddList(users.Select(Function(u) u.Key))
With Downloader
@@ -699,7 +679,6 @@ Namespace DownloadObjects
If Not disposedValue And disposing Then
[Stop]()
UserKeys.ListClearDispose()
Groups.Clear()
End If
MyBase.Dispose(disposing)
End Sub

View File

@@ -25,19 +25,14 @@ Namespace DownloadObjects
Me.components = New System.ComponentModel.Container()
Dim CONTAINER_MAIN As System.Windows.Forms.ToolStripContainer
Dim TP_MODE As System.Windows.Forms.TableLayoutPanel
Dim ActionButton1 As PersonalUtilities.Forms.Controls.Base.ActionButton = New PersonalUtilities.Forms.Controls.Base.ActionButton()
Dim resources As System.ComponentModel.ComponentResourceManager = New System.ComponentModel.ComponentResourceManager(GetType(AutoDownloaderEditorForm))
Dim ActionButton2 As PersonalUtilities.Forms.Controls.Base.ActionButton = New PersonalUtilities.Forms.Controls.Base.ActionButton()
Dim ActionButton3 As PersonalUtilities.Forms.Controls.Base.ActionButton = New PersonalUtilities.Forms.Controls.Base.ActionButton()
Dim TP_NOTIFY As System.Windows.Forms.TableLayoutPanel
Dim ActionButton4 As PersonalUtilities.Forms.Controls.Base.ActionButton = New PersonalUtilities.Forms.Controls.Base.ActionButton()
Dim ActionButton5 As PersonalUtilities.Forms.Controls.Base.ActionButton = New PersonalUtilities.Forms.Controls.Base.ActionButton()
Dim resources As System.ComponentModel.ComponentResourceManager = New System.ComponentModel.ComponentResourceManager(GetType(AutoDownloaderEditorForm))
Dim ActionButton1 As PersonalUtilities.Forms.Controls.Base.ActionButton = New PersonalUtilities.Forms.Controls.Base.ActionButton()
Dim ActionButton2 As PersonalUtilities.Forms.Controls.Base.ActionButton = New PersonalUtilities.Forms.Controls.Base.ActionButton()
Dim TT_MAIN As System.Windows.Forms.ToolTip
Me.DEF_GROUP = New SCrawler.DownloadObjects.Groups.GroupDefaults()
Me.OPT_SPEC = New System.Windows.Forms.RadioButton()
Me.OPT_ENABLED = New System.Windows.Forms.RadioButton()
Me.OPT_DISABLED = New System.Windows.Forms.RadioButton()
Me.OPT_GROUP = New System.Windows.Forms.RadioButton()
Me.TXT_GROUPS = New PersonalUtilities.Forms.Controls.TextBoxExtended()
Me.CH_NOTIFY = New System.Windows.Forms.CheckBox()
Me.CH_SHOW_PIC = New System.Windows.Forms.CheckBox()
Me.CH_SHOW_PIC_USER = New System.Windows.Forms.CheckBox()
@@ -54,7 +49,6 @@ Namespace DownloadObjects
CONTAINER_MAIN.SuspendLayout()
Me.DEF_GROUP.SuspendLayout()
TP_MODE.SuspendLayout()
CType(Me.TXT_GROUPS, System.ComponentModel.ISupportInitialize).BeginInit()
TP_NOTIFY.SuspendLayout()
CType(Me.TXT_TIMER, System.ComponentModel.ISupportInitialize).BeginInit()
CType(Me.NUM_DELAY, System.ComponentModel.ISupportInitialize).BeginInit()
@@ -66,7 +60,7 @@ Namespace DownloadObjects
'CONTAINER_MAIN.ContentPanel
'
CONTAINER_MAIN.ContentPanel.Controls.Add(Me.DEF_GROUP)
CONTAINER_MAIN.ContentPanel.Size = New System.Drawing.Size(476, 519)
CONTAINER_MAIN.ContentPanel.Size = New System.Drawing.Size(476, 494)
CONTAINER_MAIN.Dock = System.Windows.Forms.DockStyle.Fill
CONTAINER_MAIN.LeftToolStripPanelVisible = False
CONTAINER_MAIN.Location = New System.Drawing.Point(0, 0)
@@ -82,7 +76,6 @@ Namespace DownloadObjects
Me.DEF_GROUP.ColumnCount = 1
Me.DEF_GROUP.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Percent, 100.0!))
Me.DEF_GROUP.Controls.Add(TP_MODE, 0, 0)
Me.DEF_GROUP.Controls.Add(Me.TXT_GROUPS, 0, 12)
Me.DEF_GROUP.Controls.Add(TP_NOTIFY, 0, 13)
Me.DEF_GROUP.Controls.Add(Me.TXT_TIMER, 0, 15)
Me.DEF_GROUP.Controls.Add(Me.NUM_DELAY, 0, 16)
@@ -111,21 +104,18 @@ Namespace DownloadObjects
Me.DEF_GROUP.RowStyles.Add(New System.Windows.Forms.RowStyle(System.Windows.Forms.SizeType.Absolute, 28.0!))
Me.DEF_GROUP.RowStyles.Add(New System.Windows.Forms.RowStyle(System.Windows.Forms.SizeType.Absolute, 25.0!))
Me.DEF_GROUP.RowStyles.Add(New System.Windows.Forms.RowStyle(System.Windows.Forms.SizeType.Percent, 100.0!))
Me.DEF_GROUP.Size = New System.Drawing.Size(476, 519)
Me.DEF_GROUP.Size = New System.Drawing.Size(476, 494)
Me.DEF_GROUP.TabIndex = 0
'
'TP_MODE
'
TP_MODE.CellBorderStyle = System.Windows.Forms.TableLayoutPanelCellBorderStyle.[Single]
TP_MODE.ColumnCount = 3
TP_MODE.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Percent, 33.33333!))
TP_MODE.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Percent, 33.33333!))
TP_MODE.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Percent, 33.33333!))
TP_MODE.ColumnCount = 2
TP_MODE.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Percent, 50.0!))
TP_MODE.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Percent, 50.0!))
TP_MODE.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Absolute, 20.0!))
TP_MODE.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Absolute, 20.0!))
TP_MODE.Controls.Add(Me.OPT_SPEC, 1, 0)
TP_MODE.Controls.Add(Me.OPT_ENABLED, 1, 0)
TP_MODE.Controls.Add(Me.OPT_DISABLED, 0, 0)
TP_MODE.Controls.Add(Me.OPT_GROUP, 2, 0)
TP_MODE.Dock = System.Windows.Forms.DockStyle.Fill
TP_MODE.Location = New System.Drawing.Point(1, 1)
TP_MODE.Margin = New System.Windows.Forms.Padding(0)
@@ -135,18 +125,18 @@ Namespace DownloadObjects
TP_MODE.Size = New System.Drawing.Size(474, 25)
TP_MODE.TabIndex = 0
'
'OPT_SPEC
'OPT_ENABLED
'
Me.OPT_SPEC.AutoSize = True
Me.OPT_SPEC.Dock = System.Windows.Forms.DockStyle.Fill
Me.OPT_SPEC.Location = New System.Drawing.Point(161, 4)
Me.OPT_SPEC.Name = "OPT_SPEC"
Me.OPT_SPEC.Size = New System.Drawing.Size(150, 17)
Me.OPT_SPEC.TabIndex = 3
Me.OPT_SPEC.TabStop = True
Me.OPT_SPEC.Text = "Specified"
TT_MAIN.SetToolTip(Me.OPT_SPEC, "Select parameters")
Me.OPT_SPEC.UseVisualStyleBackColor = True
Me.OPT_ENABLED.AutoSize = True
Me.OPT_ENABLED.Dock = System.Windows.Forms.DockStyle.Fill
Me.OPT_ENABLED.Location = New System.Drawing.Point(240, 4)
Me.OPT_ENABLED.Name = "OPT_ENABLED"
Me.OPT_ENABLED.Size = New System.Drawing.Size(230, 17)
Me.OPT_ENABLED.TabIndex = 3
Me.OPT_ENABLED.TabStop = True
Me.OPT_ENABLED.Text = "Enabled"
TT_MAIN.SetToolTip(Me.OPT_ENABLED, "Select parameters")
Me.OPT_ENABLED.UseVisualStyleBackColor = True
'
'OPT_DISABLED
'
@@ -154,48 +144,13 @@ Namespace DownloadObjects
Me.OPT_DISABLED.Dock = System.Windows.Forms.DockStyle.Fill
Me.OPT_DISABLED.Location = New System.Drawing.Point(4, 4)
Me.OPT_DISABLED.Name = "OPT_DISABLED"
Me.OPT_DISABLED.Size = New System.Drawing.Size(150, 17)
Me.OPT_DISABLED.Size = New System.Drawing.Size(229, 17)
Me.OPT_DISABLED.TabIndex = 0
Me.OPT_DISABLED.TabStop = True
Me.OPT_DISABLED.Text = "Disabled"
TT_MAIN.SetToolTip(Me.OPT_DISABLED, "Automation disabled")
Me.OPT_DISABLED.UseVisualStyleBackColor = True
'
'OPT_GROUP
'
Me.OPT_GROUP.AutoSize = True
Me.OPT_GROUP.Dock = System.Windows.Forms.DockStyle.Fill
Me.OPT_GROUP.Location = New System.Drawing.Point(318, 4)
Me.OPT_GROUP.Name = "OPT_GROUP"
Me.OPT_GROUP.Size = New System.Drawing.Size(152, 17)
Me.OPT_GROUP.TabIndex = 4
Me.OPT_GROUP.TabStop = True
Me.OPT_GROUP.Text = "Groups"
TT_MAIN.SetToolTip(Me.OPT_GROUP, "Download groups")
Me.OPT_GROUP.UseVisualStyleBackColor = True
'
'TXT_GROUPS
'
ActionButton1.BackgroundImage = CType(resources.GetObject("ActionButton1.BackgroundImage"), System.Drawing.Image)
ActionButton1.Name = "Edit"
ActionButton2.BackgroundImage = CType(resources.GetObject("ActionButton2.BackgroundImage"), System.Drawing.Image)
ActionButton2.Name = "Info"
ActionButton2.Tag = PersonalUtilities.Forms.Controls.Base.ActionButton.DefaultButtons.Info
ActionButton2.ToolTipText = "Open group"
ActionButton3.BackgroundImage = CType(resources.GetObject("ActionButton3.BackgroundImage"), System.Drawing.Image)
ActionButton3.Name = "Clear"
Me.TXT_GROUPS.Buttons.Add(ActionButton1)
Me.TXT_GROUPS.Buttons.Add(ActionButton2)
Me.TXT_GROUPS.Buttons.Add(ActionButton3)
Me.TXT_GROUPS.CaptionText = "Groups"
Me.TXT_GROUPS.CaptionWidth = 50.0R
Me.TXT_GROUPS.Dock = System.Windows.Forms.DockStyle.Fill
Me.TXT_GROUPS.Location = New System.Drawing.Point(4, 331)
Me.TXT_GROUPS.Name = "TXT_GROUPS"
Me.TXT_GROUPS.Size = New System.Drawing.Size(468, 22)
Me.TXT_GROUPS.TabIndex = 1
Me.TXT_GROUPS.TextBoxReadOnly = True
'
'TP_NOTIFY
'
TP_NOTIFY.ColumnCount = 4
@@ -266,9 +221,9 @@ Namespace DownloadObjects
'
'TXT_TIMER
'
ActionButton4.BackgroundImage = CType(resources.GetObject("ActionButton4.BackgroundImage"), System.Drawing.Image)
ActionButton4.Name = "Refresh"
Me.TXT_TIMER.Buttons.Add(ActionButton4)
ActionButton1.BackgroundImage = CType(resources.GetObject("ActionButton1.BackgroundImage"), System.Drawing.Image)
ActionButton1.Name = "Refresh"
Me.TXT_TIMER.Buttons.Add(ActionButton1)
Me.TXT_TIMER.CaptionText = "Timer"
Me.TXT_TIMER.CaptionToolTipEnabled = True
Me.TXT_TIMER.CaptionToolTipText = "Timer (in minutes)"
@@ -281,9 +236,9 @@ Namespace DownloadObjects
'
'NUM_DELAY
'
ActionButton5.BackgroundImage = CType(resources.GetObject("ActionButton5.BackgroundImage"), System.Drawing.Image)
ActionButton5.Name = "Refresh"
Me.NUM_DELAY.Buttons.Add(ActionButton5)
ActionButton2.BackgroundImage = CType(resources.GetObject("ActionButton2.BackgroundImage"), System.Drawing.Image)
ActionButton2.Name = "Refresh"
Me.NUM_DELAY.Buttons.Add(ActionButton2)
Me.NUM_DELAY.CaptionText = "Delay"
Me.NUM_DELAY.CaptionToolTipEnabled = True
Me.NUM_DELAY.CaptionToolTipText = "Startup delay"
@@ -348,7 +303,6 @@ Namespace DownloadObjects
Me.DEF_GROUP.PerformLayout()
TP_MODE.ResumeLayout(False)
TP_MODE.PerformLayout()
CType(Me.TXT_GROUPS, System.ComponentModel.ISupportInitialize).EndInit()
TP_NOTIFY.ResumeLayout(False)
TP_NOTIFY.PerformLayout()
CType(Me.TXT_TIMER, System.ComponentModel.ISupportInitialize).EndInit()
@@ -357,12 +311,10 @@ Namespace DownloadObjects
End Sub
Private WithEvents DEF_GROUP As DownloadObjects.Groups.GroupDefaults
Private WithEvents TXT_GROUPS As PersonalUtilities.Forms.Controls.TextBoxExtended
Private WithEvents OPT_SPEC As RadioButton
Private WithEvents OPT_ENABLED As RadioButton
Private WithEvents OPT_DISABLED As RadioButton
Private WithEvents CH_NOTIFY As CheckBox
Private WithEvents TXT_TIMER As PersonalUtilities.Forms.Controls.TextBoxExtended
Private WithEvents OPT_GROUP As RadioButton
Private WithEvents LBL_LAST_TIME_UP As Label
Private WithEvents NUM_DELAY As PersonalUtilities.Forms.Controls.TextBoxExtended
Private WithEvents CH_SHOW_PIC As CheckBox

View File

@@ -129,85 +129,6 @@
<metadata name="TT_MAIN.TrayLocation" type="System.Drawing.Point, System.Drawing, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a">
<value>17, 17</value>
</metadata>
<assembly alias="System.Drawing" name="System.Drawing, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a" />
<data name="ActionButton1.BackgroundImage" type="System.Drawing.Bitmap, System.Drawing" mimetype="application/x-microsoft.net.object.bytearray.base64">
<value>
iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAALGOfPtRkwAAACBjSFJNAACH
DwAAjA8AAP1SAACBQAAAfXkAAOmLAAA85QAAGcxzPIV3AAAKOWlDQ1BQaG90b3Nob3AgSUNDIHByb2Zp
bGUAAEjHnZZ3VFTXFofPvXd6oc0w0hl6ky4wgPQuIB0EURhmBhjKAMMMTWyIqEBEEREBRZCggAGjoUis
iGIhKKhgD0gQUGIwiqioZEbWSnx5ee/l5ffHvd/aZ+9z99l7n7UuACRPHy4vBZYCIJkn4Ad6ONNXhUfQ
sf0ABniAAaYAMFnpqb5B7sFAJC83F3q6yAn8i94MAUj8vmXo6U+ng/9P0qxUvgAAyF/E5mxOOkvE+SJO
yhSkiu0zIqbGJIoZRomZL0pQxHJijlvkpZ99FtlRzOxkHlvE4pxT2clsMfeIeHuGkCNixEfEBRlcTqaI
b4tYM0mYzBXxW3FsMoeZDgCKJLYLOKx4EZuImMQPDnQR8XIAcKS4LzjmCxZwsgTiQ7mkpGbzuXHxArou
S49uam3NoHtyMpM4AoGhP5OVyOSz6S4pyalMXjYAi2f+LBlxbemiIluaWltaGpoZmX5RqP+6+Dcl7u0i
vQr43DOI1veH7a/8UuoAYMyKarPrD1vMfgA6tgIgd/8Pm+YhACRFfWu/8cV5aOJ5iRcIUm2MjTMzM424
HJaRuKC/6386/A198T0j8Xa/l4fuyollCpMEdHHdWClJKUI+PT2VyeLQDf88xP848K/zWBrIieXwOTxR
RKhoyri8OFG7eWyugJvCo3N5/6mJ/zDsT1qca5Eo9Z8ANcoISN2gAuTnPoCiEAESeVDc9d/75oMPBeKb
F6Y6sTj3nwX9+65wifiRzo37HOcSGExnCfkZi2viawnQgAAkARXIAxWgAXSBITADVsAWOAI3sAL4gWAQ
DtYCFogHyYAPMkEu2AwKQBHYBfaCSlAD6kEjaAEnQAc4DS6Ay+A6uAnugAdgBIyD52AGvAHzEARhITJE
geQhVUgLMoDMIAZkD7lBPlAgFA5FQ3EQDxJCudAWqAgqhSqhWqgR+hY6BV2ArkID0D1oFJqCfoXewwhM
gqmwMqwNG8MM2An2hoPhNXAcnAbnwPnwTrgCroOPwe3wBfg6fAcegZ/DswhAiAgNUUMMEQbigvghEUgs
wkc2IIVIOVKHtCBdSC9yCxlBppF3KAyKgqKjDFG2KE9UCIqFSkNtQBWjKlFHUe2oHtQt1ChqBvUJTUYr
oQ3QNmgv9Cp0HDoTXYAuRzeg29CX0HfQ4+g3GAyGhtHBWGE8MeGYBMw6TDHmAKYVcx4zgBnDzGKxWHms
AdYO64dlYgXYAux+7DHsOewgdhz7FkfEqeLMcO64CBwPl4crxzXhzuIGcRO4ebwUXgtvg/fDs/HZ+BJ8
Pb4LfwM/jp8nSBN0CHaEYEICYTOhgtBCuER4SHhFJBLVidbEACKXuIlYQTxOvEIcJb4jyZD0SS6kSJKQ
tJN0hHSedI/0ikwma5MdyRFkAXknuZF8kfyY/FaCImEk4SXBltgoUSXRLjEo8UISL6kl6SS5VjJHslzy
pOQNyWkpvJS2lIsUU2qDVJXUKalhqVlpirSptJ90snSxdJP0VelJGayMtoybDFsmX+awzEWZMQpC0aC4
UFiULZR6yiXKOBVD1aF6UROoRdRvqP3UGVkZ2WWyobJZslWyZ2RHaAhNm+ZFS6KV0E7QhmjvlygvcVrC
WbJjScuSwSVzcopyjnIcuUK5Vrk7cu/l6fJu8onyu+U75B8poBT0FQIUMhUOKlxSmFakKtoqshQLFU8o
3leClfSVApXWKR1W6lOaVVZR9lBOVd6vfFF5WoWm4qiSoFKmclZlSpWiaq/KVS1TPaf6jC5Ld6In0Svo
PfQZNSU1TzWhWq1av9q8uo56iHqeeqv6Iw2CBkMjVqNMo1tjRlNV01czV7NZ874WXouhFa+1T6tXa05b
RztMe5t2h/akjpyOl06OTrPOQ12yroNumm6d7m09jB5DL1HvgN5NfVjfQj9ev0r/hgFsYGnANThgMLAU
vdR6KW9p3dJhQ5Khk2GGYbPhqBHNyMcoz6jD6IWxpnGE8W7jXuNPJhYmSSb1Jg9MZUxXmOaZdpn+aqZv
xjKrMrttTjZ3N99o3mn+cpnBMs6yg8vuWlAsfC22WXRbfLS0suRbtlhOWWlaRVtVWw0zqAx/RjHjijXa
2tl6o/Vp63c2ljYCmxM2v9ga2ibaNtlOLtdZzllev3zMTt2OaVdrN2JPt4+2P2Q/4qDmwHSoc3jiqOHI
dmxwnHDSc0pwOub0wtnEme/c5jznYuOy3uW8K+Lq4Vro2u8m4xbiVun22F3dPc692X3Gw8Jjncd5T7Sn
t+duz2EvZS+WV6PXzAqrFetX9HiTvIO8K72f+Oj78H26fGHfFb57fB+u1FrJW9nhB/y8/Pb4PfLX8U/z
/z4AE+AfUBXwNNA0MDewN4gSFBXUFPQm2Dm4JPhBiG6IMKQ7VDI0MrQxdC7MNaw0bGSV8ar1q66HK4Rz
wzsjsBGhEQ0Rs6vdVu9dPR5pEVkQObRGZ03WmqtrFdYmrT0TJRnFjDoZjY4Oi26K/sD0Y9YxZ2O8Yqpj
ZlgurH2s52xHdhl7imPHKeVMxNrFlsZOxtnF7YmbineIL4+f5rpwK7kvEzwTahLmEv0SjyQuJIUltSbj
kqOTT/FkeIm8nhSVlKyUgVSD1ILUkTSbtL1pM3xvfkM6lL4mvVNAFf1M9Ql1hVuFoxn2GVUZbzNDM09m
SWfxsvqy9bN3ZE/kuOd8vQ61jrWuO1ctd3Pu6Hqn9bUboA0xG7o3amzM3zi+yWPT0c2EzYmbf8gzySvN
e70lbEtXvnL+pvyxrR5bmwskCvgFw9tst9VsR23nbu/fYb5j/45PhezCa0UmReVFH4pZxde+Mv2q4quF
nbE7+0ssSw7uwuzi7Rra7bD7aKl0aU7p2B7fPe1l9LLCstd7o/ZeLV9WXrOPsE+4b6TCp6Jzv+b+Xfs/
VMZX3qlyrmqtVqreUT13gH1g8KDjwZYa5ZqimveHuIfu1nrUttdp15UfxhzOOPy0PrS+92vG140NCg1F
DR+P8I6MHA082tNo1djYpNRU0gw3C5unjkUeu/mN6zedLYYtta201qLj4Ljw+LNvo78dOuF9ovsk42TL
d1rfVbdR2grbofbs9pmO+I6RzvDOgVMrTnV32Xa1fW/0/ZHTaqerzsieKTlLOJt/duFczrnZ86nnpy/E
XRjrjup+cHHVxds9AT39l7wvXbnsfvlir1PvuSt2V05ftbl66hrjWsd1y+vtfRZ9bT9Y/NDWb9nffsPq
RudN65tdA8sHzg46DF645Xrr8m2v29fvrLwzMBQydHc4cnjkLvvu5L2key/vZ9yff7DpIfph4SOpR+WP
lR7X/aj3Y+uI5ciZUdfRvidBTx6Mscae/5T+04fx/Kfkp+UTqhONk2aTp6fcp24+W/1s/Hnq8/npgp+l
f65+ofviu18cf+mbWTUz/pL/cuHX4lfyr468Xva6e9Z/9vGb5Dfzc4Vv5d8efcd41/s+7P3EfOYH7IeK
j3ofuz55f3q4kLyw8Bv3hPP74uYdwgAAAAlwSFlzAAALEwAACxMBAJqcGAAAAahJREFUOE9j+P//P8l4
vaOjPYyNIYkPO1lZsa1wdNy42sHh3Hxb22KQGFaF2LC4qjjroUP7n97s6vx/Ny/3/ypn54+LbGwisSpG
x+aaouwZren/u5f2/3/18tX/qzNn/l/i4XGSgYFBFasGZKwjzcJ6YVnU152blvw3LHH53zCl/ufatWu+
T+1vDALJY9UEwxrijExHZgd+/Xy1Hcg98BNkCMglMM0gjKEJhuX5GVh2TvD+/O5c0///P9b///qo819P
lgmKZhBG0QTDMjwMzJs7XT+9OVHz///XFf+/PWj7j00zCKNwQFiah4FtXbPjp8d78////7bo/4/79Tg1
gzAKR1mUg3lOocXbe9uz/v9/M/H/1zuVeDWDMJwhJcDBvK4p4tb1DQn//r/u+f/zRh5BzSAMZyyrdVh9
c33B9//32159vZr2hxjNIAwm1GUE3e+ur/n9/+Ls/592Nf9fUun3khjNIMzAysTAv6g6+OT/E33/j09N
+zWpMuImsZpBmMHIQK9x19T8/03x1ufE+TkqsCnChxmUlFWuyEpJtAHTtT42BfjxfwYAtlm0ShMkSB4A
AAAASUVORK5CYII=
</value>
</data>
<data name="ActionButton2.BackgroundImage" type="System.Drawing.Bitmap, System.Drawing" mimetype="application/x-microsoft.net.object.bytearray.base64">
<value>
iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAAIGNIUk0AAHolAACAgwAA+f8AAIDpAAB1
MAAA6mAAADqYAAAXb5JfxUYAAAAJcEhZcwAADsQAAA7EAZUrDhsAAAFQSURBVFhH7ZfNDcIwFIMZoXcm
YBtGYRHECIgTR1ZhBsS9YoJgQ1Poi5sfqhIOWPqkqvV7dWlI0oVzriry5Dd5HSS0PFwasAEn0AJn4Dle
o6fpykaVHYDNwB7YG6ZgzWiQrABosAbqaXNh7bprN1AyAAp3b42msuva9ooGYIFpELA931D2FI+VxzAI
gTIdAEb+7KpBz+p4RclQyifoXwdKwgAwcMAl3/mEAOz9GJgokQGyR/sHr8CzlwFwgU+vCuagUQE4gSjz
HGxUAM5iyiyxUp4IJ5QEAYomHCvlidCiJAigjKNYKU8M6B/g9wJUH4TV/4ZFE5GV8kSQE1HRVGylPBHC
qbh0MbJSnhH0YtQFyFqOiZXyCOLLMQVDckNCrJRHEN+QeMGY3JJZKY8hb0vmxQLTYAplm1IvFNbblnuh
Qb0Pk3exGZjv06wW8uT3cIs7jQnSONrSxH0AAAAASUVORK5CYII=
</value>
</data>
<data name="ActionButton3.BackgroundImage" type="System.Drawing.Bitmap, System.Drawing" mimetype="application/x-microsoft.net.object.bytearray.base64">
<value>
iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAALGPC/xhBQAAAAlwSFlzAAAO
xAAADsQBlSsOGwAAAIZJREFUOE+1j10KwCAMgz2b755xl/IsvnaL2K20UfbDAmEako+ZROSTafjE12Go
tbbB43rK5xSAQq1VYFtmeQBoqZTSreVZvgTknM8yyyjA/qodsDF9gspD2Bj6B+DH+NqzhQQAG+POMnSX
AFuc5QFgn6ClHh5iOQVAKNixyucB8NY0vG9JOzzyhrdq5IRgAAAAAElFTkSuQmCC
</value>
</data>
<metadata name="TP_NOTIFY.GenerateMember" type="System.Boolean, mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
<value>False</value>
</metadata>
@@ -216,36 +137,37 @@
This means that if any user data has been downloaded with the plan, a simple notification will be shown with the number of users downloaded.
The 'Image' and 'User icon' parameters will be ignored.</value>
</data>
<data name="ActionButton4.BackgroundImage" type="System.Drawing.Bitmap, System.Drawing" mimetype="application/x-microsoft.net.object.bytearray.base64">
<assembly alias="System.Drawing" name="System.Drawing, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a" />
<data name="ActionButton1.BackgroundImage" type="System.Drawing.Bitmap, System.Drawing" mimetype="application/x-microsoft.net.object.bytearray.base64">
<value>
iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAALGOfPtRkwAAACBjSFJNAAB6
JQAAgIMAAPn/AACA6QAAdTAAAOpgAAA6mAAAF2+SX8VGAAAACXBIWXMAAAsTAAALEwEAmpwYAAACOElE
QVQ4T2P4//8/QczOJyyqHpzfiE0OQwAZC8iqszAzs7CJ69o4BR768V/W2jcGXQ0KB4aFNS3dDQtnrbCb
ePCK48wTN1wXXXzge/jXf/clV55zC4hIIatF0cjIyMikElzc57z0wX+XHd/+2+//99/ywP//xlu//tdb
+eK/4Zp3/1WTOhYzARViNUAluKjTdf37/0ZTTn9TbdhwXblhwwW1/qOP1Ja9+K8w+95/6cm3/6v2Xvkv
qKjniGGAoIqRpW3/4e8S9uGdzFz82gwMDFxAzCxm4ZegtuLDf+VJ1/8rZM25IqLvnM/CximCYYCic1QN
v7x2JIwPwyrJ3XNUylddE9G2TWNmZOBDl4czmJiZMSRBmFdSyYyJgUEQmxwIYxWEYXZBCUls4sgYq6CA
prWNbtG8nXKeaVPR5XiVjSxEzf0yYXy4BBMLO6eQjoOXZvrkbbazrv53Xf/2v4CSbjBMXkhBl1/CMyNZ
qWnvGy5pNQ+YONwAfjXzAOupl/47LLr333L50/96q9/8l23YdES6cO5KuYqVW+R7Tj6SnfP0v4hryjyY
HhQDmFjYeHVKFp7WX/Xuv9Kq9/+Vd/z7r7rv/3+l7f//y676DEwDN/9L+BVvYkKLCTgDhNkkVUyVlr74
qbbz73/VOTc/qsy89kWx+9h7qbQpJwS1bbOAscGGrB6EUTggLOqf16C55ft/HlnNAFZOXgVWdi4FRgYG
VnR1MIwhwMTCyqEQ37qEmZVDFF0OE/9nAACtFF4Ey6OP+wAAAABJRU5ErkJggg==
JQAAgIMAAPn/AACA6QAAdTAAAOpgAAA6mAAAF2+SX8VGAAAACXBIWXMAAAsPAAALDwGS+QOlAAACM0lE
QVQ4T2P4//8/AyHMzicsqh6c34guDsIYAshYQFadhZmZhU1c18Yp8NCP/7LWvjHoajA0gbCwpqW7YeGs
FXYTD15xnHnihuuiiw98D//6777kynNuAREpnAYwMjIyqQQX9zkvffDfZce3//b7//23PPD/v/HWr//1
Vr74b7jm3X/VpI7FTIyMjFgNUAku6nRd//6/0ZTT31QbNlxXbthwQa3/6CO1ZS/+K8y+91968u3/qr1X
/gsq6jliGCCoYmRp23/4u4R9eCczF782AwMDFwMDA7OYhV+C2ooP/5UnXf+vkDXnioi+cz4LG6cIhgGK
zlE1/PLakcguArsquXuOSvmqayLatmnMjAx86PJwBhMzM4YkCPNKKpkxMTAIootjGIANswtKSKKLoWMM
ARAW0LS20S2at1POM20quhyvspGFqLlfJoYBTCzsnEI6Dl6a6ZO32c66+t91/dv/Akq6wTB5IQVdfgnP
jGSlpr1vuKTVPDAM4FczD7Ceeum/w6J7/y2XP/2vt/rNf9mGTUekC+eulKtYuUW+5+Qj2TlP/4u4psxD
dhGSC9h4dUoWntZf9e6/0qr3/5V3/Puvuu//f6Xt///Lrvr8X3ryzf8SfsWbmNBiAsV/bJIqpkpLX/xU
2/n3v+qcmx9VZl77oth97L1U2pQTgtq2WUwMDGzI6jEMAGFR/7wGzS3f//PIagawcvIqsLJzKTAyMLCi
q8NpABMLK4dCfOsSZlYOUXQ5bBgArRReBMoH61gAAAAASUVORK5CYII=
</value>
</data>
<data name="ActionButton5.BackgroundImage" type="System.Drawing.Bitmap, System.Drawing" mimetype="application/x-microsoft.net.object.bytearray.base64">
<data name="ActionButton2.BackgroundImage" type="System.Drawing.Bitmap, System.Drawing" mimetype="application/x-microsoft.net.object.bytearray.base64">
<value>
iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAALGOfPtRkwAAACBjSFJNAAB6
JQAAgIMAAPn/AACA6QAAdTAAAOpgAAA6mAAAF2+SX8VGAAAACXBIWXMAAAsTAAALEwEAmpwYAAACOElE
QVQ4T2P4//8/QczOJyyqHpzfiE0OQwAZC8iqszAzs7CJ69o4BR768V/W2jcGXQ0KB4aFNS3dDQtnrbCb
ePCK48wTN1wXXXzge/jXf/clV55zC4hIIatF0cjIyMikElzc57z0wX+XHd/+2+//99/ywP//xlu//tdb
+eK/4Zp3/1WTOhYzARViNUAluKjTdf37/0ZTTn9TbdhwXblhwwW1/qOP1Ja9+K8w+95/6cm3/6v2Xvkv
qKjniGGAoIqRpW3/4e8S9uGdzFz82gwMDFxAzCxm4ZegtuLDf+VJ1/8rZM25IqLvnM/CximCYYCic1QN
v7x2JIwPwyrJ3XNUylddE9G2TWNmZOBDl4czmJiZMSRBmFdSyYyJgUEQmxwIYxWEYXZBCUls4sgYq6CA
prWNbtG8nXKeaVPR5XiVjSxEzf0yYXy4BBMLO6eQjoOXZvrkbbazrv53Xf/2v4CSbjBMXkhBl1/CMyNZ
qWnvGy5pNQ+YONwAfjXzAOupl/47LLr333L50/96q9/8l23YdES6cO5KuYqVW+R7Tj6SnfP0v4hryjyY
HhQDmFjYeHVKFp7WX/Xuv9Kq9/+Vd/z7r7rv/3+l7f//y676DEwDN/9L+BVvYkKLCTgDhNkkVUyVlr74
qbbz73/VOTc/qsy89kWx+9h7qbQpJwS1bbOAscGGrB6EUTggLOqf16C55ft/HlnNAFZOXgVWdi4FRgYG
VnR1MIwhwMTCyqEQ37qEmZVDFF0OE/9nAACtFF4Ey6OP+wAAAABJRU5ErkJggg==
JQAAgIMAAPn/AACA6QAAdTAAAOpgAAA6mAAAF2+SX8VGAAAACXBIWXMAAAsPAAALDwGS+QOlAAACM0lE
QVQ4T2P4//8/AyHMzicsqh6c34guDsIYAshYQFadhZmZhU1c18Yp8NCP/7LWvjHoajA0gbCwpqW7YeGs
FXYTD15xnHnihuuiiw98D//6777kynNuAREpnAYwMjIyqQQX9zkvffDfZce3//b7//23PPD/v/HWr//1
Vr74b7jm3X/VpI7FTIyMjFgNUAku6nRd//6/0ZTT31QbNlxXbthwQa3/6CO1ZS/+K8y+91968u3/qr1X
/gsq6jliGCCoYmRp23/4u4R9eCczF782AwMDFwMDA7OYhV+C2ooP/5UnXf+vkDXnioi+cz4LG6cIhgGK
zlE1/PLakcguArsquXuOSvmqayLatmnMjAx86PJwBhMzM4YkCPNKKpkxMTAIootjGIANswtKSKKLoWMM
ARAW0LS20S2at1POM20quhyvspGFqLlfJoYBTCzsnEI6Dl6a6ZO32c66+t91/dv/Akq6wTB5IQVdfgnP
jGSlpr1vuKTVPDAM4FczD7Ceeum/w6J7/y2XP/2vt/rNf9mGTUekC+eulKtYuUW+5+Qj2TlP/4u4psxD
dhGSC9h4dUoWntZf9e6/0qr3/5V3/Puvuu//f6Xt///Lrvr8X3ryzf8SfsWbmNBiAsV/bJIqpkpLX/xU
2/n3v+qcmx9VZl77oth97L1U2pQTgtq2WUwMDGzI6jEMAGFR/7wGzS3f//PIagawcvIqsLJzKTAyMLCi
q8NpABMLK4dCfOsSZlYOUXQ5bBgArRReBMoH61gAAAAASUVORK5CYII=
</value>
</data>
</root>

View File

@@ -9,17 +9,14 @@
Imports SCrawler.DownloadObjects.Groups
Imports PersonalUtilities.Forms
Imports PersonalUtilities.Forms.Controls.Base
Imports DModes = SCrawler.DownloadObjects.AutoDownloader.Modes
Namespace DownloadObjects
Friend Class AutoDownloaderEditorForm
Private WithEvents MyDefs As DefaultFormOptions
Private ReadOnly MyGroups As List(Of String)
Private ReadOnly Property Plan As AutoDownloader
Friend Sub New(ByRef _Plan As AutoDownloader)
InitializeComponent()
Plan = _Plan
MyDefs = New DefaultFormOptions(Me, Settings.Design)
MyGroups.ListAddList(Plan.Groups, LAP.NotContainsOnly)
End Sub
Private Class AutomationTimerChecker : Inherits FieldsCheckerProviderBase
Public Overrides Property ErrorMessage As String
@@ -45,19 +42,12 @@ Namespace DownloadObjects
.MyViewInitialize(True)
.AddOkCancelToolbar()
With Plan
Select Case .Mode
Case DModes.None : OPT_DISABLED.Checked = True
Case DModes.Specified : OPT_SPEC.Checked = True
Case DModes.Groups : OPT_GROUP.Checked = True
End Select
If Enabled Then OPT_ENABLED.Checked = True Else OPT_DISABLED.Checked = True
TXT_GROUPS.CaptionWidth = GroupDefaults.CaptionWidthDefault
TXT_TIMER.CaptionWidth = GroupDefaults.CaptionWidthDefault
NUM_DELAY.CaptionWidth = GroupDefaults.CaptionWidthDefault
DEF_GROUP.Set(Plan)
If MyGroups.Count > 0 Then TXT_GROUPS.Text = MyGroups.ListToString
If Settings.Groups.Count = 0 Then TXT_GROUPS.Clear() : TXT_GROUPS.Enabled = False
CH_NOTIFY.Checked = .ShowNotifications
CH_NOTIFY_SIMPLE.Checked = .ShowSimpleNotification
CH_SHOW_PIC.Checked = .ShowPictureDownloaded
@@ -79,27 +69,14 @@ Namespace DownloadObjects
If DEF_GROUP.TXT_NAME.IsEmptyString And Settings.Automation.Count = 0 Then DEF_GROUP.TXT_NAME.Text = "Default"
End With
End Sub
Private Sub AutoDownloaderEditorForm_Disposed(sender As Object, e As EventArgs) Handles Me.Disposed
MyGroups.Clear()
End Sub
Private Sub AutoDownloaderEditorForm_KeyDown(sender As Object, e As KeyEventArgs) Handles Me.KeyDown
Try
If e = ShowUsersButtonKey AndAlso Not OPT_DISABLED.Checked Then
Dim users As New List(Of API.Base.IUserData)
If OPT_GROUP.Checked Then
If MyGroups.Count > 0 Then
Dim i%
For Each groupName$ In MyGroups
i = Settings.Groups.IndexOf(groupName)
If i >= 0 Then users.ListAddList(DownloadGroup.GetUsers(Settings.Groups(i)), LAP.NotContainsOnly, LAP.IgnoreICopier)
Next
End If
Else
Using g As New GroupParameters
DEF_GROUP.Get(g)
users.ListAddList(DownloadGroup.GetUsers(g))
users.ListAddList(DownloadGroup.GetUsers(g), LAP.IgnoreICopier)
End Using
End If
GroupUsersViewer.Show(users, $"S {DEF_GROUP.TXT_NAME.Text}")
users.Clear()
End If
@@ -110,14 +87,8 @@ Namespace DownloadObjects
Private Sub MyDefs_ButtonOkClick(ByVal Sender As Object, ByVal e As KeyHandleEventArgs) Handles MyDefs.ButtonOkClick
If MyDefs.MyFieldsChecker.AllParamsOK Then
With Plan
Select Case True
Case OPT_DISABLED.Checked : .Mode = DModes.None
Case OPT_SPEC.Checked : .Mode = DModes.Specified
Case OPT_GROUP.Checked : .Mode = DModes.Groups
End Select
.Enabled = OPT_ENABLED.Checked
DEF_GROUP.Get(Plan)
.Groups.Clear()
.Groups.ListAddList(MyGroups)
.ShowNotifications = CH_NOTIFY.Checked
.ShowSimpleNotification = CH_NOTIFY_SIMPLE.Checked
.ShowPictureDownloaded = CH_SHOW_PIC.Checked
@@ -131,42 +102,20 @@ Namespace DownloadObjects
MyDefs.CloseForm()
End If
End Sub
Private Sub TXT_GROUPS_ActionOnButtonClick(ByVal Sender As ActionButton, ByVal e As EventArgs) Handles TXT_GROUPS.ActionOnButtonClick
Select Case Sender.DefaultButton
Case ActionButton.DefaultButtons.Edit
Using f As New LabelsForm(MyGroups, (From g As DownloadGroup In Settings.Groups Where Not g.IsViewFilter Select g.Name)) With {
.Text = "Groups (F3 to edit)",
.Icon = My.Resources.GroupByIcon_16,
.IsGroups = True
}
f.ShowDialog()
If f.DialogResult = DialogResult.OK Then MyGroups.ListAddList(f.LabelsList, LAP.ClearBeforeAdd) : TXT_GROUPS.Text = MyGroups.ListToString
End Using
Case ActionButton.DefaultButtons.Clear : MyGroups.Clear()
Case ActionButton.DefaultButtons.Info
Try
If MyGroups.Count > 0 Then
Dim i% = Settings.Groups.IndexOf(MyGroups(0))
If i >= 0 Then
Using gf As New GroupEditorForm(Settings.Groups(i)) : gf.ShowDialog() : End Using
End If
End If
Catch ex As Exception
ErrorsDescriber.Execute(EDP.LogMessageValue, ex, "Show group")
End Try
End Select
End Sub
Private Sub ChangeEnabled() Handles OPT_DISABLED.CheckedChanged,
OPT_SPEC.CheckedChanged, OPT_GROUP.CheckedChanged,
OPT_ENABLED.CheckedChanged,
CH_NOTIFY.CheckedChanged, CH_NOTIFY_SIMPLE.CheckedChanged
DEF_GROUP.Enabled = OPT_SPEC.Checked
TXT_GROUPS.Enabled = OPT_GROUP.Checked
TXT_TIMER.Enabled = Not OPT_DISABLED.Checked
NUM_DELAY.Enabled = Not OPT_DISABLED.Checked
CH_NOTIFY.Enabled = Not OPT_DISABLED.Checked
Dim __enabled As Boolean = Not OPT_DISABLED.Checked
DEF_GROUP.Enabled = __enabled
TXT_TIMER.Enabled = __enabled
NUM_DELAY.Enabled = __enabled
CH_NOTIFY.Enabled = __enabled
CH_NOTIFY_SIMPLE.Enabled = CH_NOTIFY.Enabled And CH_NOTIFY.Checked
CH_SHOW_PIC.Enabled = CH_NOTIFY.Checked And Not OPT_DISABLED.Checked And Not CH_NOTIFY_SIMPLE.Checked
CH_SHOW_PIC_USER.Enabled = CH_NOTIFY.Checked And Not OPT_DISABLED.Checked And Not CH_NOTIFY_SIMPLE.Checked
If Settings.Labels.Count = 0 Then DEF_GROUP.LabelsEnabled = False
If Settings.Groups.Count = 0 Then DEF_GROUP.GroupsEnabled = False
End Sub
Private Sub NUM_DELAY_ActionOnButtonClick(ByVal Sender As ActionButton, ByVal e As EventArgs) Handles NUM_DELAY.ActionOnButtonClick
If Sender.DefaultButton = ActionButton.DefaultButtons.Clear Then NUM_DELAY.Value = 0

View File

@@ -144,7 +144,7 @@ Namespace DownloadObjects
If UpdateBase Then UpdateBaseButton(Not p = PauseModes.Disabled)
If Not VerifyAll OrElse Settings.Automation.All(Function(ByVal plan As AutoDownloader) As Boolean
If plan.Mode = AutoDownloader.Modes.None Then
If Not plan.Enabled Then
Return True
Else
Return plan.Pause = p

View File

@@ -507,24 +507,7 @@ Namespace DownloadObjects
Private Sub ShowPlanUsers()
Try
If _LatestSelected.ValueBetween(0, Settings.Automation.Count - 1) Then
With Settings.Automation(_LatestSelected)
Dim users As New List(Of API.Base.IUserData)
If Not .Mode = AutoDownloader.Modes.None Then
If .Mode = AutoDownloader.Modes.Groups Then
If .Groups.Count > 0 Then
Dim i%
For Each groupName$ In .Groups
i = Settings.Groups.IndexOf(groupName)
If i >= 0 Then users.ListAddList(Groups.DownloadGroup.GetUsers(Settings.Groups(i)), LAP.NotContainsOnly, LAP.IgnoreICopier)
Next
End If
Else
users.ListAddList(Groups.DownloadGroup.GetUsers(.Self))
End If
End If
Groups.GroupUsersViewer.Show(users, $"S { .Name}")
users.Clear()
End With
With Settings.Automation(_LatestSelected) : Groups.GroupUsersViewer.Show(Groups.DownloadGroup.GetUsers(.Self), $"S { .Name}") : End With
End If
Catch ex As Exception
ErrorsDescriber.Execute(EDP.LogMessageValue, ex, "Show plan users")

View File

@@ -16,6 +16,7 @@ Namespace DownloadObjects
Friend Event DownloadDone As NotificationEventHandler
Friend Event ProgressChanged(ByVal Main As Boolean, ByVal IsMaxValue As Boolean, ByVal IsDone As Boolean)
Friend Event FeedFilesChanged As TDownloader.FeedFilesChangedEventHandler
Friend Event KeyDown As KeyEventHandler
#End Region
#Region "Declarations"
#Region "Controls"
@@ -126,6 +127,10 @@ Namespace DownloadObjects
TP_MAIN.Controls.Add(LBL_INFO, 0, 1)
End If
For Each btt As Button In {BTT_OPEN, BTT_START, BTT_STOP}
If Not btt Is Nothing Then AddHandler btt.KeyDown, AddressOf BTT_KeyDown
Next
With Job
.Progress = New MyProgressExt(PR_MAIN, PR_PRE, LBL_INFO) With {.ResetProgressOnMaximumChanges = False}
With DirectCast(.Progress, MyProgressExt)
@@ -149,6 +154,9 @@ Namespace DownloadObjects
.Dock = DockStyle.Fill
}
End Sub
Private Sub BTT_KeyDown(ByVal Sender As Object, ByVal e As KeyEventArgs)
RaiseEvent KeyDown(Sender, e)
End Sub
#End Region
Friend Function [Get]() As TableLayoutPanel
Return TP_MAIN

View File

@@ -43,6 +43,7 @@ Friend Class DownloadSavedPostsForm
For Each j As DownloadProgress In JobsList
AddHandler j.DownloadDone, AddressOf Jobs_DownloadDone
AddHandler j.FeedFilesChanged, AddressOf Jobs_FeedFilesChanged
AddHandler j.KeyDown, AddressOf DownloadSavedPostsForm_KeyDown
TP_MAIN.RowStyles.Add(New RowStyle(SizeType.Absolute, 60))
TP_MAIN.RowCount += 1
TP_MAIN.Controls.Add(j.Get, 0, TP_MAIN.RowStyles.Count - 1)
@@ -54,6 +55,9 @@ Friend Class DownloadSavedPostsForm
MaximumSize = s
End If
End Sub
Private Sub DownloadSavedPostsForm_KeyDown(sender As Object, e As KeyEventArgs) Handles Me.KeyDown, BTT_DOWN_ALL.KeyDown, BTT_STOP_ALL.KeyDown
If e.KeyCode = Keys.Escape Then Close()
End Sub
Private Sub DownloadSavedPostsForm_Closing(sender As Object, e As CancelEventArgs) Handles Me.Closing
e.Cancel = True
Hide()

View File

@@ -26,7 +26,19 @@ Namespace DownloadObjects
Friend WithEvents MyDefs As DefaultFormOptions
Private WithEvents MyRange As RangeSwitcherToolbar(Of UserMediaD)
Private ReadOnly DataList As List(Of UserMediaD)
#Region "Buttons"
Private WithEvents BTT_DELETE_SELECTED As ToolStripButton
Private WithEvents BTT_COPY_SELECTED_T As ToolStripButton
Private WithEvents BTT_MOVE_SELECTED_T As ToolStripButton
Private WithEvents BTT_FAV_T As ToolStripButton
Private WithEvents BTT_FEED_ADD_T As ToolStripDropDownButton
Private WithEvents BTT_SELECT_ALL_T As ToolStripButton
Private WithEvents BTT_SELECT_NONE_T As ToolStripButton
Private WithEvents BTT_INVERT_T As ToolStripButton
Private WithEvents BTT_LOAD_CURRENT_T As ToolStripButton
Private WithEvents BTT_LOAD_FAV_T As ToolStripButton
Private WithEvents BTT_LOAD_T As ToolStripDropDownButton
#End Region
Private DataRows As Integer = 10
Private DataColumns As Integer = 1
Private FeedEndless As Boolean = False
@@ -65,8 +77,10 @@ Namespace DownloadObjects
If Not CurrentFilter Is Nothing Then
With CurrentFilter
If .Types.Count > 0 AndAlso Not .Types.Any(Function(t) FilterTypesConversion(t, d)) Then Return False
#Disable Warning BC42109
#Disable Warning BC42109, BC42104
If .Sites.Count > 0 AndAlso Not .Sites.Contains(d.UserInfo.Site) Then Return False
If .Users.Count > 0 AndAlso Not .Users.Contains(d.UserInfo) Then Return False
If .Labels.Count > 0 AndAlso d.User.Labels.Count > 0 AndAlso Not d.User.Labels.ListContains(.Labels) Then Return False
#Enable Warning
End With
End If
@@ -99,15 +113,15 @@ Namespace DownloadObjects
End Sub
Private Sub FeedRemoveCheckedMedia(ByVal MediaList As IEnumerable(Of UserMediaD), Optional ByVal OverriddenNames As List(Of String) = Nothing,
Optional ByVal RemoveChecked As Boolean = True, Optional ByVal ExcludingNames As IEnumerable(Of String) = Nothing,
Optional ByVal RemoveFromDataListOnly As Boolean = False)
Optional ByVal IsAddAndRemove As Boolean = False)
Try
If FeedMode = FeedModes.Special Then
If LoadedFeedNames.Count > 0 Then
If FeedMode = FeedModes.Saved Then Exit Sub
Dim dataRemoved As Boolean = False
If OverriddenNames.ListExists And Not LoadedFeedNames.ListContains(OverriddenNames) Then Exit Sub
If Not RemoveFromDataListOnly Then
If FeedMode = FeedModes.Special And OverriddenNames.ListExists And Not LoadedFeedNames.ListContains(OverriddenNames) Then Exit Sub
Dim eNames As IEnumerable(Of String) = If(ExcludingNames, New String() {})
With If(OverriddenNames, LoadedFeedNames)
If FeedMode = FeedModes.Special And .ListExists Then
.ForEach(Sub(ByVal feedName As String)
If Not eNames.Contains(feedName) Then
Dim indx% = Settings.Feeds.IndexOf(feedName)
@@ -116,25 +130,33 @@ Namespace DownloadObjects
End If
End If
End Sub)
End With
ElseIf FeedMode = FeedModes.Current And Not OverriddenNames.ListExists And IsAddAndRemove Then
dataRemoved = Downloader.Files.ListDisposeRemove(MediaList) > 0
'Downloader.FilesSave()
Else
Exit Sub
End If
If RemoveFromDataListOnly Then
RefillSpecialFeedsData()
ElseIf dataRemoved Then
DataList.ListDisposeRemove(MediaList)
If RemoveChecked Then
End With
If dataRemoved Then DataList.ListDisposeRemove(MediaList)
Select Case FeedMode
Case FeedModes.Special
If RemoveChecked And IsAddAndRemove Then
If RemoveCheckedMedia(False) Then RefillAfterDelete()
Else
RefillSpecialFeedsData()
End If
End If
End If
ElseIf FeedMode = FeedModes.Current Then
If OverriddenNames Is Nothing AndAlso Downloader.Files.ListDisposeRemove(MediaList) > 0 AndAlso RemoveCheckedMedia(False) Then
DataList.ListDisposeRemove(MediaList)
Case FeedModes.Current
If dataRemoved Then
If RemoveChecked Then
RemoveCheckedMedia(False)
RefillAfterDelete()
Else
RefillList()
End If
End If
End Select
Catch ex As Exception
ErrorsDescriber.Execute(EDP.SendToLog, ex, "[DownloadFeedForm.FeedRemoveCheckedMedia]")
End Try
@@ -149,13 +171,84 @@ Namespace DownloadObjects
MyRange = New RangeSwitcherToolbar(Of UserMediaD)(ToolbarTOP)
DataList = New List(Of UserMediaD)
LoadedFeedNames = New List(Of String)
BTT_DELETE_SELECTED = New ToolStripButton With {
.Text = "Delete selected",
.Text = "Delete",
.AutoToolTip = True,
.ToolTipText = "Delete marked files",
.ToolTipText = "Delete selected files",
.Image = My.Resources.DeletePic_24,
.DisplayStyle = ToolStripItemDisplayStyle.ImageAndText
}
BTT_COPY_SELECTED_T = New ToolStripButton With {
.Text = "Copy",
.AutoToolTip = True,
.ToolTipText = "Copy selected files",
.Image = My.Resources.PastePic_32,
.DisplayStyle = ToolStripItemDisplayStyle.ImageAndText
}
BTT_MOVE_SELECTED_T = New ToolStripButton With {
.Text = "Move",
.AutoToolTip = True,
.ToolTipText = "Move selected files",
.Image = My.Resources.CutPic_48,
.DisplayStyle = ToolStripItemDisplayStyle.ImageAndText
}
BTT_FAV_T = New ToolStripButton With {
.Text = "Favorite",
.AutoToolTip = True,
.ToolTipText = "Add checked to Favorite",
.Image = My.Resources.HeartPic_32,
.DisplayStyle = ToolStripItemDisplayStyle.ImageAndText
}
BTT_FEED_ADD_T = New ToolStripDropDownButton With {
.Text = "Add",
.AutoToolTip = True,
.ToolTipText = "Add checked to special feed..." & vbCr & "Right click to add to multiple feeds",
.Image = My.Resources.RSSPic_512,
.DisplayStyle = ToolStripItemDisplayStyle.ImageAndText
}
BTT_LOAD_CURRENT_T = New ToolStripButton With {
.Text = "Current",
.AutoToolTip = True,
.ToolTipText = "Load current feed",
.Image = My.Resources.ArrowDownPic_Blue_24,
.DisplayStyle = ToolStripItemDisplayStyle.ImageAndText
}
BTT_LOAD_FAV_T = New ToolStripButton With {
.Text = "Favorite",
.AutoToolTip = True,
.ToolTipText = "Load Favorite",
.Image = My.Resources.HeartPic_32,
.DisplayStyle = ToolStripItemDisplayStyle.ImageAndText
}
BTT_LOAD_T = New ToolStripDropDownButton With {
.Text = "Load",
.AutoToolTip = True,
.ToolTipText = "Load special feed..." & vbCr & "Right click to load multiple feeds",
.Image = My.Resources.RSSPic_512,
.DisplayStyle = ToolStripItemDisplayStyle.ImageAndText
}
BTT_SELECT_ALL_T = New ToolStripButton With {
.Text = "All",
.AutoToolTip = True,
.ToolTipText = "Select all",
.DisplayStyle = ToolStripItemDisplayStyle.Text
}
BTT_SELECT_NONE_T = New ToolStripButton With {
.Text = "None",
.AutoToolTip = True,
.ToolTipText = "Select none",
.DisplayStyle = ToolStripItemDisplayStyle.Text
}
BTT_INVERT_T = New ToolStripButton With {
.Text = "Invert",
.AutoToolTip = True,
.ToolTipText = "Invert selection",
.DisplayStyle = ToolStripItemDisplayStyle.Text
}
FILTERS = New FeedFilterCollection
BTT_FILTER.Image = My.Resources.FilterPic
BTT_FILTER_SIMPLE.Image = My.Resources.FilterPic
@@ -181,17 +274,29 @@ Namespace DownloadObjects
.ToolTip(RCI.GoTo) = "GoTo (Ctrl+G)"
.AddThisToolbar()
End With
ToolbarTOP.Items.AddRange({New ToolStripSeparator, BTT_DELETE_SELECTED})
ToolbarTOP.Items.AddRange({New ToolStripSeparator, BTT_DELETE_SELECTED,
New ToolStripSeparator, BTT_COPY_SELECTED_T, BTT_MOVE_SELECTED_T,
New ToolStripSeparator, BTT_FAV_T, BTT_FEED_ADD_T,
New ToolStripSeparator, BTT_LOAD_CURRENT_T, BTT_LOAD_FAV_T, BTT_LOAD_T,
New ToolStripSeparator, BTT_SELECT_ALL_T, BTT_SELECT_NONE_T, BTT_INVERT_T})
With Settings
With .Feeds
.Load()
AddHandler .FeedAdded, AddressOf Feed_FeedAdded
AddHandler .FeedRemoved, AddressOf Feed_FeedRemoved
If .Count = 0 OrElse (.Count = 1 AndAlso .Item(0).IsFavorite) Then
BTT_FEED_ADD_T.Enabled = False
BTT_FEED_ADD_T.Visible = False
BTT_LOAD_T.Enabled = False
BTT_LOAD_T.Visible = False
End If
If .Count > 0 Then
For Each feed As FeedSpecial In .Self
If Not feed.IsFavorite Then
AddNewFeedItem(BTT_LOAD_SPEC, feed, My.Resources.RSSPic_512, AddressOf Feed_SPEC_LOAD)
AddNewFeedItem(BTT_LOAD_T, feed, My.Resources.RSSPic_512, AddressOf Feed_SPEC_LOAD)
AddNewFeedItem(BTT_FEED_ADD_SPEC, feed, My.Resources.RSSPic_512, AddressOf Feed_SPEC_ADD)
AddNewFeedItem(BTT_FEED_ADD_T, feed, My.Resources.RSSPic_512, AddressOf Feed_SPEC_ADD)
AddNewFeedItem(BTT_FEED_ADD_SPEC_REMOVE, feed, My.Resources.RSSPic_512, AddressOf Feed_SPEC_ADD_REMOVE)
AddNewFeedItem(BTT_FEED_REMOVE_SPEC, feed, My.Resources.RSSPic_512, AddressOf Feed_SPEC_REMOVE)
AddNewFeedItem(BTT_FEED_DELETE_SPEC, feed, My.Resources.DeletePic_24, AddressOf Feed_SPEC_DELETE)
@@ -260,11 +365,11 @@ Namespace DownloadObjects
End Sub
#End Region
#Region "Feeds handlers"
Private Overloads Sub AddNewFeedItem(ByVal Destination As ToolStripMenuItem, ByVal Feed As FeedSpecial, ByVal Image As Image,
Private Overloads Sub AddNewFeedItem(Of T As ToolStripDropDownItem)(ByVal Destination As T, ByVal Feed As FeedSpecial, ByVal Image As Image,
ByVal Handler As EventHandler, Optional ByVal Insert As Boolean = False)
AddNewFeedItem(Destination, ToolbarTOP, Feed, Image, Handler, Insert)
End Sub
Friend Overloads Shared Function AddNewFeedItem(ByVal Destination As ToolStripMenuItem, ByVal Toolbar As ToolStrip,
Friend Overloads Shared Function AddNewFeedItem(ByVal Destination As ToolStripDropDownItem, ByVal Toolbar As ToolStrip,
ByVal Feed As FeedSpecial, ByVal Image As Image,
ByVal Handler As EventHandler, Optional ByVal Insert As Boolean = False) As ToolStripMenuItem
Dim item As New ToolStripMenuItem(Feed.Name, Image) With {.Tag = Feed}
@@ -280,7 +385,9 @@ Namespace DownloadObjects
End Function
Private Sub Feed_FeedAdded(ByVal Source As FeedSpecialCollection, ByVal Feed As FeedSpecial)
AddNewFeedItem(BTT_LOAD_SPEC, Feed, My.Resources.RSSPic_512, AddressOf Feed_SPEC_LOAD, True)
AddNewFeedItem(BTT_LOAD_T, Feed, My.Resources.RSSPic_512, AddressOf Feed_SPEC_LOAD, True)
AddNewFeedItem(BTT_FEED_ADD_SPEC, Feed, My.Resources.RSSPic_512, AddressOf Feed_SPEC_ADD, True)
AddNewFeedItem(BTT_FEED_ADD_T, Feed, My.Resources.RSSPic_512, AddressOf Feed_SPEC_ADD, True)
AddNewFeedItem(BTT_FEED_ADD_SPEC_REMOVE, Feed, My.Resources.RSSPic_512, AddressOf Feed_SPEC_ADD_REMOVE, True)
AddNewFeedItem(BTT_FEED_REMOVE_SPEC, Feed, My.Resources.RSSPic_512, AddressOf Feed_SPEC_REMOVE, True)
AddNewFeedItem(BTT_FEED_DELETE_SPEC, Feed, My.Resources.DeletePic_24, AddressOf Feed_SPEC_DELETE, True)
@@ -288,15 +395,17 @@ Namespace DownloadObjects
End Sub
Private Overloads Sub Feed_FeedRemoved(ByVal Source As FeedSpecialCollection, ByVal Feed As FeedSpecial)
Feed_FeedRemoved(BTT_LOAD_SPEC, Feed)
Feed_FeedRemoved(BTT_LOAD_T, Feed)
Feed_FeedRemoved(BTT_FEED_ADD_SPEC, Feed)
Feed_FeedRemoved(BTT_FEED_ADD_T, Feed)
Feed_FeedRemoved(BTT_FEED_REMOVE_SPEC, Feed)
Feed_FeedRemoved(BTT_FEED_DELETE_SPEC, Feed)
Feed_FeedRemoved(BTT_FEED_CLEAR_SPEC, Feed)
End Sub
Private Overloads Sub Feed_FeedRemoved(ByVal Destination As ToolStripMenuItem, ByVal Feed As FeedSpecial)
Private Overloads Sub Feed_FeedRemoved(ByVal Destination As ToolStripDropDownItem, ByVal Feed As FeedSpecial)
Feed_FeedRemoved(Destination, ToolbarTOP, Feed)
End Sub
Friend Overloads Shared Sub Feed_FeedRemoved(ByVal Destination As ToolStripMenuItem, ByVal Toolbar As ToolStrip, ByVal Feed As FeedSpecial)
Friend Overloads Shared Sub Feed_FeedRemoved(ByVal Destination As ToolStripDropDownItem, ByVal Toolbar As ToolStrip, ByVal Feed As FeedSpecial)
Try
With Destination
ControlInvokeFast(Toolbar, .Self,
@@ -333,7 +442,7 @@ Namespace DownloadObjects
Dim c As IEnumerable(Of UserMediaD) = GetCheckedMedia()
If c.ListExists Then
f.Add(c)
FeedRemoveCheckedMedia(c,,, {f.Name})
FeedRemoveCheckedMedia(c,,, {f.Name}, True)
End If
End If
End Sub
@@ -352,7 +461,7 @@ Namespace DownloadObjects
Dim m As IEnumerable(Of UserMediaD) = GetCheckedMedia()
If m.ListExists Then
f.Remove(m)
FeedRemoveCheckedMedia(m, {f.Name}.ToList)
FeedRemoveCheckedMedia(m, {f.Name}.ToList,,, False)
End If
End If
End Sub
@@ -471,7 +580,7 @@ Namespace DownloadObjects
#Region "Toolbar controls"
#Region "Feed"
#Region "Load"
Private Sub BTT_LOAD_SESSION_CURRENT_Click(sender As Object, e As EventArgs) Handles BTT_LOAD_SESSION_CURRENT.Click
Private Sub BTT_LOAD_SESSION_CURRENT_Click(sender As Object, e As EventArgs) Handles BTT_LOAD_SESSION_CURRENT.Click, BTT_LOAD_CURRENT_T.Click
FeedChangeMode(FeedModes.Current)
RefillList(True, False)
End Sub
@@ -586,7 +695,7 @@ Namespace DownloadObjects
End Sub
#End Region
#Region "Move/Copy"
Private Sub BTT_COPY_MOVE_TO_Click(sender As Object, e As EventArgs) Handles BTT_COPY_TO.Click, BTT_MOVE_TO.Click
Private Sub BTT_COPY_MOVE_TO_Click(sender As Object, e As EventArgs) Handles BTT_COPY_TO.Click, BTT_MOVE_TO.Click, BTT_COPY_SELECTED_T.Click, BTT_MOVE_SELECTED_T.Click
MoveCopyFiles(True, sender, Nothing, Nothing)
End Sub
Private Sub BTT_COPY_MOVE_SPEC_TO_Click(sender As Object, e As EventArgs) Handles BTT_COPY_SPEC_TO.Click, BTT_MOVE_SPEC_TO.Click
@@ -596,7 +705,7 @@ Namespace DownloadObjects
ByVal FeedMediaData As FeedMedia, Optional ByVal GetChecked As Boolean = True) As Boolean
Dim MsgTitle$ = "Copy/Move checked files"
Try
Dim isCopy As Boolean = Not Sender Is Nothing AndAlso (Sender Is BTT_COPY_TO OrElse Sender Is BTT_COPY_SPEC_TO)
Dim isCopy As Boolean = Not Sender Is Nothing AndAlso (Sender Is BTT_COPY_TO OrElse Sender Is BTT_COPY_SPEC_TO OrElse Sender Is BTT_COPY_SELECTED_T)
Dim moveOptions As FeedMoveCopyTo = Nothing
Dim ff As SFile = Nothing, ffInit As SFile = Nothing, df As SFile = Nothing
Dim data As IEnumerable(Of UserMediaD) = Nothing
@@ -959,10 +1068,13 @@ Namespace DownloadObjects
End Sub
#End Region
#Region "Load fav, spec"
Private Sub BTT_LOAD_FAV_Click(sender As Object, e As EventArgs) Handles BTT_LOAD_FAV.Click
Private Sub BTT_LOAD_FAV_Click(sender As Object, e As EventArgs) Handles BTT_LOAD_FAV.Click, BTT_LOAD_FAV_T.Click
FeedChangeMode(FeedModes.Special, {FeedSpecial.FavoriteName})
RefillSpecialFeedsData(False)
End Sub
Private Sub BTT_LOAD_T_MouseDown(sender As Object, e As MouseEventArgs) Handles BTT_LOAD_T.MouseDown
If e.Button = MouseButtons.Right Then BTT_LOAD_SPEC_Click(sender, e)
End Sub
Private Sub BTT_LOAD_SPEC_Click(sender As Object, e As EventArgs) Handles BTT_LOAD_SPEC.Click
With FeedSpecialCollection.ChooseFeeds(False)
If .ListExists Then
@@ -996,20 +1108,23 @@ Namespace DownloadObjects
End Sub
#End Region
#Region "Add remove fav spec"
Private Sub BTT_FEED_ADD_FAV_Click(sender As Object, e As EventArgs) Handles BTT_FEED_ADD_FAV.Click, BTT_FEED_ADD_FAV_REMOVE.Click
Private Sub BTT_FEED_ADD_FAV_Click(sender As Object, e As EventArgs) Handles BTT_FEED_ADD_FAV.Click, BTT_FEED_ADD_FAV_REMOVE.Click, BTT_FAV_T.Click
Dim m As IEnumerable(Of UserMediaD) = GetCheckedMedia()
If m.ListExists Then
Settings.Feeds.Favorite.Add(m)
If sender Is BTT_FEED_ADD_FAV_REMOVE Then FeedRemoveCheckedMedia(m,,, {FeedSpecial.FavoriteName})
If sender Is BTT_FEED_ADD_FAV_REMOVE Then FeedRemoveCheckedMedia(m,,, {FeedSpecial.FavoriteName}, True)
End If
End Sub
Private Sub BTT_FEED_REMOVE_FAV_Click(sender As Object, e As EventArgs) Handles BTT_FEED_REMOVE_FAV.Click
Dim m As IEnumerable(Of UserMediaD) = GetCheckedMedia()
If m.ListExists Then
Settings.Feeds.Favorite.Remove(m)
If FeedMode = FeedModes.Special Then FeedRemoveCheckedMedia(m, {FeedSpecial.FavoriteName}.ToList)
If FeedMode = FeedModes.Special Then FeedRemoveCheckedMedia(m, {FeedSpecial.FavoriteName}.ToList,,, False)
End If
End Sub
Private Sub BTT_FEED_ADD_T_MouseDown(sender As Object, e As MouseEventArgs) Handles BTT_FEED_ADD_T.MouseDown
If e.Button = MouseButtons.Right Then BTT_FEED_ADD_SPEC_Click(sender, e)
End Sub
Private Sub BTT_FEED_ADD_SPEC_Click(sender As Object, e As EventArgs) Handles BTT_FEED_ADD_SPEC.Click, BTT_FEED_ADD_SPEC_REMOVE.Click
Dim c As IEnumerable(Of UserMediaD) = GetCheckedMedia()
If c.ListExists Then
@@ -1020,7 +1135,7 @@ Namespace DownloadObjects
f.Add(c)
End Sub)
End With
If sender Is BTT_FEED_ADD_SPEC_REMOVE Then FeedRemoveCheckedMedia(c,,, names)
If sender Is BTT_FEED_ADD_SPEC_REMOVE Then FeedRemoveCheckedMedia(c,,, names, True)
names.Clear()
Else
MsgBoxE({"You haven't selected media to add to your feed(s)", "Add to feed(s)"}, vbExclamation)
@@ -1036,7 +1151,7 @@ Namespace DownloadObjects
f.Remove(c)
End Sub)
End With
If FeedMode = FeedModes.Special Then FeedRemoveCheckedMedia(c, names)
If FeedMode = FeedModes.Special Then FeedRemoveCheckedMedia(c, names,,, False)
Else
MsgBoxE({"You haven't selected media to remove from your feed(s)", "Remove from feed(s)"}, vbExclamation)
End If
@@ -1268,10 +1383,10 @@ Namespace DownloadObjects
End Try
End Sub
#End Region
Private Sub BTT_CHECK_ALL_NONE_Click(sender As Object, e As EventArgs) Handles BTT_CHECK_ALL.Click, BTT_CHECK_NONE.Click, BTT_CHECK_INVERT.Click
Private Sub BTT_CHECK_ALL_NONE_Click(sender As Object, e As EventArgs) Handles BTT_CHECK_ALL.Click, BTT_CHECK_NONE.Click, BTT_CHECK_INVERT.Click, BTT_SELECT_ALL_T.Click, BTT_SELECT_NONE_T.Click, BTT_INVERT_T.Click
Try
Dim checked As Boolean = sender Is BTT_CHECK_ALL
Dim isInvert As Boolean = sender Is BTT_CHECK_INVERT
Dim checked As Boolean = sender Is BTT_CHECK_ALL Or sender Is BTT_SELECT_ALL_T
Dim isInvert As Boolean = sender Is BTT_CHECK_INVERT Or sender Is BTT_INVERT_T
ControlInvokeFast(TP_DATA, Sub()
With TP_DATA
If .Controls.Count > 0 Then
@@ -1408,8 +1523,10 @@ Namespace DownloadObjects
ErrorsDescriber.Execute(EDP.LogMessageValue, ex, "Download subscription media")
End Try
End Sub
Private Sub FeedMedia_FeedAddWithRemove(ByVal Sender As FeedMedia, ByVal Feeds As IEnumerable(Of String), ByVal Media As UserMediaD, ByVal RemoveOperation As Boolean)
FeedRemoveCheckedMedia({Media},, False, Feeds, RemoveOperation)
Private Sub FeedMedia_FeedRemoveCheckedMedia(ByVal Sender As FeedMedia, ByVal Media As UserMediaD, ByVal Names As IEnumerable(Of String),
ByVal IsOverriddenNames As Boolean, ByVal IsAddAndRemove As Boolean)
FeedRemoveCheckedMedia({Media}, CObj(If(IsOverriddenNames, Names.ListIfNothing, Nothing)), False,
CObj(If(IsOverriddenNames, Nothing, Names)), IsAddAndRemove)
End Sub
#End Region
#Region "Delete / Remove"
@@ -1616,7 +1733,7 @@ Namespace DownloadObjects
AddHandler .MediaDownload, AddressOf FeedMedia_Download
AddHandler .MediaMove, AddressOf FeedMedia_MediaMove
AddHandler .MediaCopy, AddressOf FeedMedia_MediaCopy
AddHandler .FeedAddWithRemove, AddressOf FeedMedia_FeedAddWithRemove
AddHandler .FeedRemoveCheckedMedia, AddressOf FeedMedia_FeedRemoveCheckedMedia
End With
If de.Data.Type = UTypes.Text OrElse de.Data.PostTextFile.IsEmptyString Then Exit For
Next

View File

@@ -18,24 +18,28 @@ Namespace DownloadObjects
Private Const Name_Types As String = "Types"
Private Const Name_Users As String = "Users"
Private Const Name_Sites As String = "Sites"
Private Const Name_Labels As String = "Labels"
#End Region
#Region "Properties"
Friend Property Name As String
Friend ReadOnly Property Types As List(Of UTypes)
Friend ReadOnly Property Users As List(Of UserInfo)
Friend ReadOnly Property Sites As List(Of String)
Friend ReadOnly Property Labels As List(Of String)
#End Region
#Region "Initializers"
Friend Sub New()
Types = New List(Of UTypes)
Users = New List(Of UserInfo)
Sites = New List(Of String)
Labels = New List(Of String)
End Sub
Friend Sub New(ByVal e As EContainer)
Me.New
Name = e.Value(Name_Name)
Types.ListAddList(e.Value(Name_Types).StringToList(Of Integer)(","))
Sites.ListAddList(e.Value(Name_Sites).StringToList(Of String)("|"))
Labels.ListAddList(e.Value(Name_Labels).StringToList(Of String)("|"))
If If(e(Name_Users)?.Count, 0) > 0 Then
Users.ListAddList(e(Name_Users), LAP.IgnoreICopier)
Users.RemoveAll(Function(u) Not u.File.Exists)
@@ -75,8 +79,9 @@ Namespace DownloadObjects
ee.Add(New EContainer(Name_Name, Name))
ee.Add(New EContainer(Name_Types, Types.ListToString(",")))
ee.Add(New EContainer(Name_Sites, Sites.ListToString("|")))
ee.Add(New EContainer(Name_Labels, Labels.ListToString("|")))
If Users.Count > 0 Then
ee.Add(New EContainer(Name_Users, String.Empty))
ee.Add(New EContainer(Name_Users, String.Empty) With {.AllowSameNames = True})
ee(Name_Users).AddRange(Users)
End If
Return ee
@@ -95,6 +100,8 @@ Namespace DownloadObjects
Users.ListAddList(.Users, LAP.NotContainsOnly)
Sites.Clear()
Sites.ListAddList(.Sites, LAP.NotContainsOnly)
Labels.Clear()
Labels.ListAddList(.Labels, LAP.NotContainsOnly)
End With
Return Me
End Function
@@ -126,8 +133,15 @@ Namespace DownloadObjects
End Get
Set(ByVal f As FeedFilter)
_TEMP = f
If _TEMP Is Nothing And _CurrentFilterName.IsEmptyString And Not _CurrentFilterNameLast.IsEmptyString Then _
If _TEMP Is Nothing Then
If Not _CurrentFilterNameLast.IsEmptyString Then
_CurrentFilterName = _CurrentFilterNameLast
Else
_CurrentFilterName = String.Empty
End If
Else
_CurrentFilterName = String.Empty
End If
End Set
End Property
Friend ReadOnly Property Current(Optional ByVal Any As Boolean = True, Optional ByVal GetTemp As Boolean = True) As FeedFilter

View File

@@ -30,6 +30,8 @@ Namespace DownloadObjects
Dim resources As System.ComponentModel.ComponentResourceManager = New System.ComponentModel.ComponentResourceManager(GetType(FeedFilterForm))
Dim ActionButton2 As PersonalUtilities.Forms.Controls.Base.ActionButton = New PersonalUtilities.Forms.Controls.Base.ActionButton()
Dim ActionButton3 As PersonalUtilities.Forms.Controls.Base.ActionButton = New PersonalUtilities.Forms.Controls.Base.ActionButton()
Dim ActionButton4 As PersonalUtilities.Forms.Controls.Base.ActionButton = New PersonalUtilities.Forms.Controls.Base.ActionButton()
Dim ActionButton5 As PersonalUtilities.Forms.Controls.Base.ActionButton = New PersonalUtilities.Forms.Controls.Base.ActionButton()
Me.TP_MAIN = New System.Windows.Forms.TableLayoutPanel()
Me.CH_T_ALL = New System.Windows.Forms.CheckBox()
Me.CH_T_IMG = New System.Windows.Forms.CheckBox()
@@ -43,6 +45,7 @@ Namespace DownloadObjects
Me.LIST_USERS = New System.Windows.Forms.CheckedListBox()
Me.TXT_NAME = New PersonalUtilities.Forms.Controls.TextBoxExtended()
Me.TXT_SITE = New PersonalUtilities.Forms.Controls.TextBoxExtended()
Me.TXT_LABELS = New PersonalUtilities.Forms.Controls.TextBoxExtended()
CONTAINER_MAIN = New System.Windows.Forms.ToolStripContainer()
TP_TYPES = New System.Windows.Forms.TableLayoutPanel()
TP_USERS = New System.Windows.Forms.TableLayoutPanel()
@@ -55,6 +58,7 @@ Namespace DownloadObjects
TP_USERS_2.SuspendLayout()
CType(Me.TXT_NAME, System.ComponentModel.ISupportInitialize).BeginInit()
CType(Me.TXT_SITE, System.ComponentModel.ISupportInitialize).BeginInit()
CType(Me.TXT_LABELS, System.ComponentModel.ISupportInitialize).BeginInit()
Me.SuspendLayout()
'
'CONTAINER_MAIN
@@ -78,16 +82,18 @@ Namespace DownloadObjects
Me.TP_MAIN.ColumnCount = 1
Me.TP_MAIN.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Percent, 100.0!))
Me.TP_MAIN.Controls.Add(TP_TYPES, 0, 1)
Me.TP_MAIN.Controls.Add(TP_USERS, 0, 3)
Me.TP_MAIN.Controls.Add(TP_USERS, 0, 4)
Me.TP_MAIN.Controls.Add(Me.TXT_NAME, 0, 0)
Me.TP_MAIN.Controls.Add(Me.TXT_SITE, 0, 2)
Me.TP_MAIN.Controls.Add(Me.TXT_LABELS, 0, 3)
Me.TP_MAIN.Dock = System.Windows.Forms.DockStyle.Fill
Me.TP_MAIN.Location = New System.Drawing.Point(0, 0)
Me.TP_MAIN.Name = "TP_MAIN"
Me.TP_MAIN.RowCount = 4
Me.TP_MAIN.RowCount = 5
Me.TP_MAIN.RowStyles.Add(New System.Windows.Forms.RowStyle(System.Windows.Forms.SizeType.Absolute, 28.0!))
Me.TP_MAIN.RowStyles.Add(New System.Windows.Forms.RowStyle(System.Windows.Forms.SizeType.Absolute, 25.0!))
Me.TP_MAIN.RowStyles.Add(New System.Windows.Forms.RowStyle(System.Windows.Forms.SizeType.Absolute, 28.0!))
Me.TP_MAIN.RowStyles.Add(New System.Windows.Forms.RowStyle(System.Windows.Forms.SizeType.Absolute, 28.0!))
Me.TP_MAIN.RowStyles.Add(New System.Windows.Forms.RowStyle(System.Windows.Forms.SizeType.Percent, 100.0!))
Me.TP_MAIN.Size = New System.Drawing.Size(522, 336)
Me.TP_MAIN.TabIndex = 0
@@ -178,13 +184,13 @@ Namespace DownloadObjects
TP_USERS.Controls.Add(TP_USERS_2, 0, 0)
TP_USERS.Controls.Add(Me.LIST_USERS, 0, 1)
TP_USERS.Dock = System.Windows.Forms.DockStyle.Fill
TP_USERS.Location = New System.Drawing.Point(0, 81)
TP_USERS.Location = New System.Drawing.Point(0, 109)
TP_USERS.Margin = New System.Windows.Forms.Padding(0)
TP_USERS.Name = "TP_USERS"
TP_USERS.RowCount = 2
TP_USERS.RowStyles.Add(New System.Windows.Forms.RowStyle(System.Windows.Forms.SizeType.Absolute, 25.0!))
TP_USERS.RowStyles.Add(New System.Windows.Forms.RowStyle(System.Windows.Forms.SizeType.Percent, 100.0!))
TP_USERS.Size = New System.Drawing.Size(522, 255)
TP_USERS.Size = New System.Drawing.Size(522, 227)
TP_USERS.TabIndex = 3
'
'TP_USERS_2
@@ -206,7 +212,7 @@ Namespace DownloadObjects
TP_USERS_2.RowStyles.Add(New System.Windows.Forms.RowStyle(System.Windows.Forms.SizeType.Percent, 100.0!))
TP_USERS_2.RowStyles.Add(New System.Windows.Forms.RowStyle(System.Windows.Forms.SizeType.Absolute, 25.0!))
TP_USERS_2.Size = New System.Drawing.Size(522, 25)
TP_USERS_2.TabIndex = 0
TP_USERS_2.TabIndex = 4
'
'CH_U_USE
'
@@ -258,8 +264,8 @@ Namespace DownloadObjects
Me.LIST_USERS.FormattingEnabled = True
Me.LIST_USERS.Location = New System.Drawing.Point(3, 28)
Me.LIST_USERS.Name = "LIST_USERS"
Me.LIST_USERS.Size = New System.Drawing.Size(516, 224)
Me.LIST_USERS.TabIndex = 1
Me.LIST_USERS.Size = New System.Drawing.Size(516, 196)
Me.LIST_USERS.TabIndex = 5
'
'TXT_NAME
'
@@ -298,6 +304,25 @@ Namespace DownloadObjects
Me.TXT_SITE.TabIndex = 2
Me.TXT_SITE.TextBoxReadOnly = True
'
'TXT_LABELS
'
ActionButton4.BackgroundImage = CType(resources.GetObject("ActionButton4.BackgroundImage"), System.Drawing.Image)
ActionButton4.Name = "Edit"
ActionButton4.Tag = PersonalUtilities.Forms.Controls.Base.ActionButton.DefaultButtons.Edit
ActionButton5.BackgroundImage = CType(resources.GetObject("ActionButton5.BackgroundImage"), System.Drawing.Image)
ActionButton5.Name = "Clear"
ActionButton5.Tag = PersonalUtilities.Forms.Controls.Base.ActionButton.DefaultButtons.Clear
Me.TXT_LABELS.Buttons.Add(ActionButton4)
Me.TXT_LABELS.Buttons.Add(ActionButton5)
Me.TXT_LABELS.CaptionText = "Labels"
Me.TXT_LABELS.CaptionWidth = 40.0R
Me.TXT_LABELS.Dock = System.Windows.Forms.DockStyle.Fill
Me.TXT_LABELS.Location = New System.Drawing.Point(3, 84)
Me.TXT_LABELS.Name = "TXT_LABELS"
Me.TXT_LABELS.Size = New System.Drawing.Size(516, 22)
Me.TXT_LABELS.TabIndex = 3
Me.TXT_LABELS.TextBoxReadOnly = True
'
'FeedFilterForm
'
Me.AutoScaleDimensions = New System.Drawing.SizeF(6.0!, 13.0!)
@@ -317,6 +342,7 @@ Namespace DownloadObjects
TP_USERS_2.PerformLayout()
CType(Me.TXT_NAME, System.ComponentModel.ISupportInitialize).EndInit()
CType(Me.TXT_SITE, System.ComponentModel.ISupportInitialize).EndInit()
CType(Me.TXT_LABELS, System.ComponentModel.ISupportInitialize).EndInit()
Me.ResumeLayout(False)
End Sub
@@ -333,5 +359,6 @@ Namespace DownloadObjects
Private WithEvents TXT_NAME As PersonalUtilities.Forms.Controls.TextBoxExtended
Private WithEvents TP_MAIN As TableLayoutPanel
Private WithEvents TXT_SITE As PersonalUtilities.Forms.Controls.TextBoxExtended
Private WithEvents TXT_LABELS As PersonalUtilities.Forms.Controls.TextBoxExtended
End Class
End Namespace

View File

@@ -133,7 +133,7 @@
<data name="ActionButton1.BackgroundImage" type="System.Drawing.Bitmap, System.Drawing" mimetype="application/x-microsoft.net.object.bytearray.base64">
<value>
iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAALGPC/xhBQAAAAlwSFlzAAAO
xAAADsQBlSsOGwAAAHpJREFUOE+1kVEKgDAMQ3e2/e+MXqpn6W/HxM7SpkIVB4HxSMKiTUTaFwVQ1X25
wgAADsIBFShKgAAAAHpJREFUOE+1kVEKgDAMQ3e2/e+MXqpn6W/HxM7SpkIVB4HxSMKiTUTaFwVQ1X25
DjMfSxskHBYsAxHJkjUjHgrUNMY4peaMPxb03rcZMVhgn2oDKAwn+L0aROH/Cny4NAGFSx8x+10ZDwV2
gt+LOCxQsw1nPBS8VQBVTTzyhrdZSUm7AAAAAElFTkSuQmCC
</value>
@@ -185,7 +185,7 @@
RudN65tdA8sHzg46DF645Xrr8m2v29fvrLwzMBQydHc4cnjkLvvu5L2key/vZ9yff7DpIfph4SOpR+WP
lR7X/aj3Y+uI5ciZUdfRvidBTx6Mscae/5T+04fx/Kfkp+UTqhONk2aTp6fcp24+W/1s/Hnq8/npgp+l
f65+ofviu18cf+mbWTUz/pL/cuHX4lfyr468Xva6e9Z/9vGb5Dfzc4Vv5d8efcd41/s+7P3EfOYH7IeK
j3ofuz55f3q4kLyw8Bv3hPP74uYdwgAAAAlwSFlzAAALEwAACxMBAJqcGAAAAZlJREFUOE9j+P//PwOp
j3ofuz55f3q4kLyw8Bv3hPP74uYdwgAAAAlwSFlzAAALEQAACxEBf2RfkQAAAZlJREFUOE9j+P//PwOp
eL2joz2MjSGJDztZWbGtcHTcuNrB4dx8W9tikgwQVxVnPXRo/9ObXZ3/7+bl/l/l7PxxkY1NJIZCbNhc
U5Q9ozX9f/fS/v+vXr76f3XmzP9LPDxOMjAwqGIoRsc60iysF5ZFfd25acl/wxKX/w1T6n+uXbvm+9T+
xiCQPIYGZKwhzsh0ZHbg189X2////3/gJ8gQkEtgmvEaIM/PwLJzgvfnd+ea/v//sf7/10ed/3qyTFA0
@@ -198,7 +198,72 @@
<data name="ActionButton3.BackgroundImage" type="System.Drawing.Bitmap, System.Drawing" mimetype="application/x-microsoft.net.object.bytearray.base64">
<value>
iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAALGPC/xhBQAAAAlwSFlzAAAO
xAAADsQBlSsOGwAAAHpJREFUOE+1kVEKgDAMQ3e2/e+MXqpn6W/HxM7SpkIVB4HxSMKiTUTaFwVQ1X25
wgAADsIBFShKgAAAAHpJREFUOE+1kVEKgDAMQ3e2/e+MXqpn6W/HxM7SpkIVB4HxSMKiTUTaFwVQ1X25
DjMfSxskHBYsAxHJkjUjHgrUNMY4peaMPxb03rcZMVhgn2oDKAwn+L0aROH/Cny4NAGFSx8x+10ZDwV2
gt+LOCxQsw1nPBS8VQBVTTzyhrdZSUm7AAAAAElFTkSuQmCC
</value>
</data>
<data name="ActionButton4.BackgroundImage" type="System.Drawing.Bitmap, System.Drawing" mimetype="application/x-microsoft.net.object.bytearray.base64">
<value>
iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAALGOfPtRkwAAACBjSFJNAACH
DwAAjA8AAP1SAACBQAAAfXkAAOmLAAA85QAAGcxzPIV3AAAKOWlDQ1BQaG90b3Nob3AgSUNDIHByb2Zp
bGUAAEjHnZZ3VFTXFofPvXd6oc0w0hl6ky4wgPQuIB0EURhmBhjKAMMMTWyIqEBEEREBRZCggAGjoUis
iGIhKKhgD0gQUGIwiqioZEbWSnx5ee/l5ffHvd/aZ+9z99l7n7UuACRPHy4vBZYCIJkn4Ad6ONNXhUfQ
sf0ABniAAaYAMFnpqb5B7sFAJC83F3q6yAn8i94MAUj8vmXo6U+ng/9P0qxUvgAAyF/E5mxOOkvE+SJO
yhSkiu0zIqbGJIoZRomZL0pQxHJijlvkpZ99FtlRzOxkHlvE4pxT2clsMfeIeHuGkCNixEfEBRlcTqaI
b4tYM0mYzBXxW3FsMoeZDgCKJLYLOKx4EZuImMQPDnQR8XIAcKS4LzjmCxZwsgTiQ7mkpGbzuXHxArou
S49uam3NoHtyMpM4AoGhP5OVyOSz6S4pyalMXjYAi2f+LBlxbemiIluaWltaGpoZmX5RqP+6+Dcl7u0i
vQr43DOI1veH7a/8UuoAYMyKarPrD1vMfgA6tgIgd/8Pm+YhACRFfWu/8cV5aOJ5iRcIUm2MjTMzM424
HJaRuKC/6386/A198T0j8Xa/l4fuyollCpMEdHHdWClJKUI+PT2VyeLQDf88xP848K/zWBrIieXwOTxR
RKhoyri8OFG7eWyugJvCo3N5/6mJ/zDsT1qca5Eo9Z8ANcoISN2gAuTnPoCiEAESeVDc9d/75oMPBeKb
F6Y6sTj3nwX9+65wifiRzo37HOcSGExnCfkZi2viawnQgAAkARXIAxWgAXSBITADVsAWOAI3sAL4gWAQ
DtYCFogHyYAPMkEu2AwKQBHYBfaCSlAD6kEjaAEnQAc4DS6Ay+A6uAnugAdgBIyD52AGvAHzEARhITJE
geQhVUgLMoDMIAZkD7lBPlAgFA5FQ3EQDxJCudAWqAgqhSqhWqgR+hY6BV2ArkID0D1oFJqCfoXewwhM
gqmwMqwNG8MM2An2hoPhNXAcnAbnwPnwTrgCroOPwe3wBfg6fAcegZ/DswhAiAgNUUMMEQbigvghEUgs
wkc2IIVIOVKHtCBdSC9yCxlBppF3KAyKgqKjDFG2KE9UCIqFSkNtQBWjKlFHUe2oHtQt1ChqBvUJTUYr
oQ3QNmgv9Cp0HDoTXYAuRzeg29CX0HfQ4+g3GAyGhtHBWGE8MeGYBMw6TDHmAKYVcx4zgBnDzGKxWHms
AdYO64dlYgXYAux+7DHsOewgdhz7FkfEqeLMcO64CBwPl4crxzXhzuIGcRO4ebwUXgtvg/fDs/HZ+BJ8
Pb4LfwM/jp8nSBN0CHaEYEICYTOhgtBCuER4SHhFJBLVidbEACKXuIlYQTxOvEIcJb4jyZD0SS6kSJKQ
tJN0hHSedI/0ikwma5MdyRFkAXknuZF8kfyY/FaCImEk4SXBltgoUSXRLjEo8UISL6kl6SS5VjJHslzy
pOQNyWkpvJS2lIsUU2qDVJXUKalhqVlpirSptJ90snSxdJP0VelJGayMtoybDFsmX+awzEWZMQpC0aC4
UFiULZR6yiXKOBVD1aF6UROoRdRvqP3UGVkZ2WWyobJZslWyZ2RHaAhNm+ZFS6KV0E7QhmjvlygvcVrC
WbJjScuSwSVzcopyjnIcuUK5Vrk7cu/l6fJu8onyu+U75B8poBT0FQIUMhUOKlxSmFakKtoqshQLFU8o
3leClfSVApXWKR1W6lOaVVZR9lBOVd6vfFF5WoWm4qiSoFKmclZlSpWiaq/KVS1TPaf6jC5Ld6In0Svo
PfQZNSU1TzWhWq1av9q8uo56iHqeeqv6Iw2CBkMjVqNMo1tjRlNV01czV7NZ874WXouhFa+1T6tXa05b
RztMe5t2h/akjpyOl06OTrPOQ12yroNumm6d7m09jB5DL1HvgN5NfVjfQj9ev0r/hgFsYGnANThgMLAU
vdR6KW9p3dJhQ5Khk2GGYbPhqBHNyMcoz6jD6IWxpnGE8W7jXuNPJhYmSSb1Jg9MZUxXmOaZdpn+aqZv
xjKrMrttTjZ3N99o3mn+cpnBMs6yg8vuWlAsfC22WXRbfLS0suRbtlhOWWlaRVtVWw0zqAx/RjHjijXa
2tl6o/Vp63c2ljYCmxM2v9ga2ibaNtlOLtdZzllev3zMTt2OaVdrN2JPt4+2P2Q/4qDmwHSoc3jiqOHI
dmxwnHDSc0pwOub0wtnEme/c5jznYuOy3uW8K+Lq4Vro2u8m4xbiVun22F3dPc692X3Gw8Jjncd5T7Sn
t+duz2EvZS+WV6PXzAqrFetX9HiTvIO8K72f+Oj78H26fGHfFb57fB+u1FrJW9nhB/y8/Pb4PfLX8U/z
/z4AE+AfUBXwNNA0MDewN4gSFBXUFPQm2Dm4JPhBiG6IMKQ7VDI0MrQxdC7MNaw0bGSV8ar1q66HK4Rz
wzsjsBGhEQ0Rs6vdVu9dPR5pEVkQObRGZ03WmqtrFdYmrT0TJRnFjDoZjY4Oi26K/sD0Y9YxZ2O8Yqpj
ZlgurH2s52xHdhl7imPHKeVMxNrFlsZOxtnF7YmbineIL4+f5rpwK7kvEzwTahLmEv0SjyQuJIUltSbj
kqOTT/FkeIm8nhSVlKyUgVSD1ILUkTSbtL1pM3xvfkM6lL4mvVNAFf1M9Ql1hVuFoxn2GVUZbzNDM09m
SWfxsvqy9bN3ZE/kuOd8vQ61jrWuO1ctd3Pu6Hqn9bUboA0xG7o3amzM3zi+yWPT0c2EzYmbf8gzySvN
e70lbEtXvnL+pvyxrR5bmwskCvgFw9tst9VsR23nbu/fYb5j/45PhezCa0UmReVFH4pZxde+Mv2q4quF
nbE7+0ssSw7uwuzi7Rra7bD7aKl0aU7p2B7fPe1l9LLCstd7o/ZeLV9WXrOPsE+4b6TCp6Jzv+b+Xfs/
VMZX3qlyrmqtVqreUT13gH1g8KDjwZYa5ZqimveHuIfu1nrUttdp15UfxhzOOPy0PrS+92vG140NCg1F
DR+P8I6MHA082tNo1djYpNRU0gw3C5unjkUeu/mN6zedLYYtta201qLj4Ljw+LNvo78dOuF9ovsk42TL
d1rfVbdR2grbofbs9pmO+I6RzvDOgVMrTnV32Xa1fW/0/ZHTaqerzsieKTlLOJt/duFczrnZ86nnpy/E
XRjrjup+cHHVxds9AT39l7wvXbnsfvlir1PvuSt2V05ftbl66hrjWsd1y+vtfRZ9bT9Y/NDWb9nffsPq
RudN65tdA8sHzg46DF645Xrr8m2v29fvrLwzMBQydHc4cnjkLvvu5L2key/vZ9yff7DpIfph4SOpR+WP
lR7X/aj3Y+uI5ciZUdfRvidBTx6Mscae/5T+04fx/Kfkp+UTqhONk2aTp6fcp24+W/1s/Hnq8/npgp+l
f65+ofviu18cf+mbWTUz/pL/cuHX4lfyr468Xva6e9Z/9vGb5Dfzc4Vv5d8efcd41/s+7P3EfOYH7IeK
j3ofuz55f3q4kLyw8Bv3hPP74uYdwgAAAAlwSFlzAAALEAAACxABrSO9dQAAAZlJREFUOE9j+P//PwOp
eL2joz2MjSGJDztZWbGtcHTcuNrB4dx8W9tikgwQVxVnPXRo/9ObXZ3/7+bl/l/l7PxxkY1NJIZCbNhc
U5Q9ozX9f/fS/v+vXr76f3XmzP9LPDxOMjAwqGIoRsc60iysF5ZFfd25acl/wxKX/w1T6n+uXbvm+9T+
xiCQPIYGZKwhzsh0ZHbg189X2////3/gJ8gQkEtgmvEaIM/PwLJzgvfnd+ea/v//sf7/10ed/3qyTFA0
4zRAhoeBeXOn66c3J2r+//+64v+3B23/sWnGaoA0DwPbumbHT4/35v///23R/x/363FqxjBAWZSDeU6h
xdt727P+/38z8f/XO5V4NaMYICXAwbyuKeLW9Q0J//6/7vn/80YeQc0oBiyrdVh9c33B9//32159vZr2
hxjNcAPUZQTd766v+f3/4uz/n3Y1/19S6feSGM1gA1iZGPgXVQef/H+i7//xqWm/JlVG3CRWM9gAIwO9
xl1T8/83xVufE+fnqEBXQAgzKCmrXJGVkmhjYGDQR5ckBgMAtlm0SiCu/g8AAAAASUVORK5CYII=
</value>
</data>
<data name="ActionButton5.BackgroundImage" type="System.Drawing.Bitmap, System.Drawing" mimetype="application/x-microsoft.net.object.bytearray.base64">
<value>
iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAALGPC/xhBQAAAAlwSFlzAAAO
wQAADsEBuJFr7QAAAHpJREFUOE+1kVEKgDAMQ3e2/e+MXqpn6W/HxM7SpkIVB4HxSMKiTUTaFwVQ1X25
DjMfSxskHBYsAxHJkjUjHgrUNMY4peaMPxb03rcZMVhgn2oDKAwn+L0aROH/Cny4NAGFSx8x+10ZDwV2
gt+LOCxQsw1nPBS8VQBVTTzyhrdZSUm7AAAAAElFTkSuQmCC
</value>

View File

@@ -6,6 +6,7 @@
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY
Imports SCrawler.API.Base
Imports PersonalUtilities.Forms
Imports PersonalUtilities.Forms.Controls.Base
Imports UTypes = SCrawler.API.Base.UserMedia.Types
@@ -105,6 +106,7 @@ Namespace DownloadObjects
End If
UpdateSitesText()
UpdateLabelsText()
.EndLoaderOperations()
RefillList(True)
@@ -143,21 +145,29 @@ Namespace DownloadObjects
Return DirectCast(Obj, DataUserTmp).UserInfo
End Function
End Structure
Private SitePredicate As Predicate(Of IUserData) = Function(d) MyFilter.Sites.Count = 0 OrElse MyFilter.Sites.Contains(d.Site)
Private LabelPredicate As Predicate(Of IUserData) = Function(d) MyFilter.Labels.Count = 0 OrElse MyFilter.Labels.ListContains(d.Labels)
Private Sub RefillList(Optional ByVal Init As Boolean = False)
If Not MyDefs.Initializing Then
If Not Init Then ApplyFilter()
LIST_USERS.Items.Clear()
Dim dataUsers As New List(Of DataUserTmp)
If CH_U_SHOW_ALL.Checked Or MyData.Count = 0 Then
dataUsers.ListAddList(Settings.UsersList)
Else
dataUsers.ListAddList(MyData.Select(Function(d) d.UserInfo), LAP.NotContainsOnly)
'dataUsers.ListAddList(Settings.UsersList)
If Settings.Users.Count > 0 Then dataUsers.ListAddList(From __d As IUserData In Settings.GetUsers(Function(____d) True)
Where SitePredicate(__d) And LabelPredicate(__d)
Select DirectCast(__d, UserDataBase).User)
ElseIf MyData.Count > 0 Then
'dataUsers.ListAddList(MyData.Select(Function(d) d.UserInfo), LAP.NotContainsOnly)
dataUsers.ListAddList((From __d As IUserData In MyData.Select(Function(____d) ____d.User)
Where SitePredicate(__d) And LabelPredicate(__d)
Select DirectCast(__d, UserDataBase).User), LAP.NotContainsOnly)
End If
Dim i%
If dataUsers.Count > 0 Then
dataUsers.Sort()
With MyFilter
If .Sites.Count > 0 Then dataUsers.RemoveAll(Function(d) Not .Sites.Contains(d.UserInfo.Site))
'If .Sites.Count > 0 Then dataUsers.RemoveAll(Function(d) Not .Sites.Contains(d.UserInfo.Site))
If dataUsers.Count > 0 Then
dataUsers.ForEach(Sub(d) LIST_USERS.Items.Add(d, True))
If .Users.Count > 0 Then
@@ -243,10 +253,30 @@ Namespace DownloadObjects
End Select
If refill Then RefillList()
End Sub
Private Sub TXT_LABELS_ActionOnButtonClick(ByVal Sender As Object, ByVal e As ActionButtonEventArgs) Handles TXT_LABELS.ActionOnButtonClick
Dim refill As Boolean = False
Select Case e.DefaultButton
Case ActionButton.DefaultButtons.Edit
Using f As New LabelsForm(MyFilter.Labels, False)
f.ShowDialog()
If f.DialogResult = DialogResult.OK Then
refill = Not MyFilter.Labels.ListEquals(f.LabelsList)
MyFilter.Labels.ListAddList(f.LabelsList, LAP.NotContainsOnly, LAP.ClearBeforeAdd)
UpdateLabelsText()
End If
End Using
Case ActionButton.DefaultButtons.Clear : refill = MyFilter.Labels.Count > 0 : MyFilter.Labels.Clear() : UpdateLabelsText()
End Select
If refill Then RefillList()
End Sub
Private Sub UpdateSitesText()
TXT_SITE.Clear()
TXT_SITE.Text = MyFilter.Sites.ListToString
End Sub
Private Sub UpdateLabelsText()
TXT_LABELS.Clear()
TXT_LABELS.Text = MyFilter.Labels.ListToString
End Sub
#End Region
End Class
End Namespace

View File

@@ -12,6 +12,7 @@ Imports PersonalUtilities.Forms
Imports PersonalUtilities.Tools
Imports SCrawler.API.Base
Imports UserMediaD = SCrawler.DownloadObjects.TDownloader.UserMediaD
Imports ImageRenderer2 = SCrawler.UserImage.ImageRenderer2
Namespace DownloadObjects
<ToolboxItem(False), DesignTimeVisible(False)>
Public Class FeedMedia
@@ -20,7 +21,8 @@ Namespace DownloadObjects
Friend Event MediaDeleted(ByVal Sender As Object)
Friend Event MediaDeletedText(ByVal Sender As Object)
Friend Event MediaDownload As EventHandler
Friend Event FeedAddWithRemove(ByVal Sender As FeedMedia, ByVal Feeds As IEnumerable(Of String), ByVal Media As UserMediaD, ByVal RemoveOperation As Boolean)
Friend Event FeedRemoveCheckedMedia(ByVal Sender As FeedMedia, ByVal Media As UserMediaD, ByVal Names As IEnumerable(Of String),
ByVal IsOverriddenNames As Boolean, ByVal IsAddAndRemove As Boolean)
Friend Event MediaMove As MediaMoveCopyEventHandler
Friend Event MediaCopy As MediaMoveCopyEventHandler
#End Region
@@ -153,10 +155,12 @@ Namespace DownloadObjects
End Function
#End Region
#Region "Initializers"
Private Sub FileCheckSpecialFolders(ByRef f As SFile, ByVal ExtractText As Boolean)
Private Sub FileCheckSpecialFolders(ByRef f As SFile, ByVal ExtractText As Boolean, ByVal OrigFile As SFile)
If Not File.Exists Then
If ExtractText Then
f.Path = $"{File.Path.CSFilePS}{UserDataBase.PostTextSpecialFolderDefault}"
If Not f.Exists Then f.Path = OrigFile.Path
If Not f.Exists Then f.Path = $"{OrigFile.Path.CSFilePS}{UserDataBase.PostTextSpecialFolderDefault}"
ElseIf Media.Data.Type = UserMedia.Types.Video Then
f.Path = $"{File.Path.CSFilePS}Video"
End If
@@ -165,42 +169,6 @@ Namespace DownloadObjects
Public Sub New()
InitializeComponent()
End Sub
Private Class ImageRenderer2 : Inherits ImageRenderer
Friend NativeFormat As String = Nothing
Friend ImgErr As Exception = Nothing
Friend Sub New(ByVal ImgPath As SFile, Optional ByVal e As ErrorsDescriber = Nothing)
MyBase.New()
Try
If ImgPath.Exists(SFO.File, False) Then
OriginalImageBytes = SFile.GetBytes(ImgPath, EDP.ThrowException)
Try
OriginalImage = GetImage(OriginalImageBytes)
Catch exInternal As Exception
HasError = True
ImgErr = exInternal
NativeFormat = GetTrueFormat(OriginalImageBytes, EDP.ReturnValue)
End Try
End If
Address = ImgPath
Catch ex As Exception
HasError = True
NativeFormat = GetTrueFormat(OriginalImageBytes, EDP.ReturnValue)
If Not e.Exists Then e = EDP.ThrowException
ErrorsDescriber.Execute(e, ex, $"ImageRenderer2.New({ImgPath})")
End Try
End Sub
Friend Shared Function GetTrueFormat(ByVal Img() As Byte, Optional ByVal e As ErrorsDescriber = Nothing) As String
Try
Using ms As New MemoryStream(Img, 0, Img.Length)
Return System.Windows.Media.Imaging.BitmapDecoder.Create(ms, Windows.Media.Imaging.BitmapCreateOptions.PreservePixelFormat,
Windows.Media.Imaging.BitmapCacheOption.OnLoad).Metadata.Format
End Using
Catch ex As Exception
If Not e.Exists Then e = EDP.ThrowException
Return ErrorsDescriber.Execute(e, ex, "[ImageRenderer2.GetTrueFormat()]")
End Try
End Function
End Class
Friend Sub New(ByVal Media As UserMediaD, ByVal Width As Integer, ByVal Height As Integer, ByVal IsSession As Boolean, ByVal ExtractText As Boolean)
Try
InitializeComponent()
@@ -238,7 +206,17 @@ Namespace DownloadObjects
End With
If Not imgFile.Exists Then
Settings.Cache.Validate()
If GetWebFile(Media.Data.URL, imgFile, EDP.None) AndAlso imgFile.Exists Then File = UserImage.ConvertWebp(imgFile, Nothing)
If GetWebFile(Media.Data.URL, imgFile, EDP.None) AndAlso imgFile.Exists Then
File = UserImage.ConvertWebp(imgFile, Nothing)
ElseIf Not IsNothing(Media.Data.Object) AndAlso TypeOf Media.Data.Object Is IThumbList AndAlso
DirectCast(Media.Data.Object, IThumbList).Thumbs.ListExists Then
With DirectCast(Media.Data.Object, IThumbList).Thumbs
For Each __tmpUrl$ In .Self
If GetWebFile(__tmpUrl, imgFile, EDP.None) AndAlso imgFile.Exists Then _
File = UserImage.ConvertWebp(imgFile, Nothing) : Exit For
Next
End With
End If
Else
File = imgFile
End If
@@ -248,18 +226,18 @@ Namespace DownloadObjects
LBL_TITLE.Dispose()
TP_MAIN.RowStyles(1).Height = 0
File = If(ExtractText, Media.Data.PostTextFile, Media.Data.File)
FileCheckSpecialFolders(File, ExtractText)
FileCheckSpecialFolders(File, ExtractText, Media.Data.File)
End If
If Not File.Exists And Not IsSubscription Then
If Not Media.Data.SpecialFolder.IsEmptyString Then
File = If(ExtractText, Media.Data.PostTextFile, Media.Data.File)
File.Path = $"{File.Path.CSFilePS}{Media.Data.SpecialFolder}".CSFileP
FileCheckSpecialFolders(File, ExtractText)
FileCheckSpecialFolders(File, ExtractText, Media.Data.File)
End If
End If
If File.Exists Then
If File.Exists Or IsSubscription Then
Information = $"Type: {IIf(ExtractText, UserMedia.Types.Text.ToString, Media.Data.Type.ToString)}"
Information.StringAppendLine($"File: {File.File}")
Information.StringAppendLine($"Address: {File}")
@@ -290,7 +268,7 @@ Namespace DownloadObjects
Dim webpConverted As Boolean = False
Dim isWebp As Boolean = False
tmpMediaFile = UserImage.ConvertWebp(tmpMediaFile, Nothing,,, webpConverted)
If tmpMediaFile.IsEmptyString Then Throw New ArgumentNullException With {.HelpLink = 1}
If tmpMediaFile.IsEmptyString And Not IsSubscription Then Throw New ArgumentNullException With {.HelpLink = 1}
Try
For kConv As Byte = 0 To 1
If kConv = 1 Then tmpMediaFile = UserImage.ConvertWebp(tmpMediaFile, Nothing, True, isWebp, webpConverted)
@@ -435,11 +413,11 @@ Namespace DownloadObjects
End Function
Private Sub Feed_SPEC_ADD_REMOVE(ByVal Source As ToolStripMenuItem, ByVal e As EventArgs)
Dim f As FeedSpecial = Feed_SPEC_ADD_Impl(Source)
If Not f Is Nothing Then RaiseEvent FeedAddWithRemove(Me, {f.Name}, Media, False)
If Not f Is Nothing Then RaiseEvent FeedRemoveCheckedMedia(Me, Media, {f.Name}, False, True)
End Sub
Private Sub Feed_SPEC_REMOVE(ByVal Source As ToolStripMenuItem, ByVal e As EventArgs)
Dim f As FeedSpecial = Source.Tag
If Not f Is Nothing AndAlso Not f.Disposed Then f.Remove(Media) : RaiseEvent FeedAddWithRemove(Me, {f.Name}, Media, True)
If Not f Is Nothing AndAlso Not f.Disposed Then f.Remove(Media) : RaiseEvent FeedRemoveCheckedMedia(Me, Media, {f.Name}, True, False)
End Sub
#End Region
#Region "Dispose"
@@ -598,14 +576,14 @@ Namespace DownloadObjects
With Settings.Feeds.Favorite
If Not .Contains(Media) Then .Add(Media)
BTT_FEED_ADD_FAV.ControlChangeColor(True, False)
If sender Is BTT_FEED_ADD_FAV_REMOVE Then RaiseEvent FeedAddWithRemove(Me, {FeedSpecial.FavoriteName}, Media, False)
If sender Is BTT_FEED_ADD_FAV_REMOVE Then RaiseEvent FeedRemoveCheckedMedia(Me, Media, {FeedSpecial.FavoriteName}, False, True)
End With
End Sub
Private Sub BTT_FEED_ADD_SPEC_Click(sender As Object, e As EventArgs) Handles BTT_FEED_ADD_SPEC.Click, BTT_FEED_ADD_SPEC_REMOVE.Click
With FeedSpecialCollection.ChooseFeeds(True)
If .ListExists Then
.ForEach(Sub(f) f.Add(Media))
If sender Is BTT_FEED_ADD_SPEC_REMOVE Then RaiseEvent FeedAddWithRemove(Me, .Select(Function(f) f.Name), Media, False)
If sender Is BTT_FEED_ADD_SPEC_REMOVE Then RaiseEvent FeedRemoveCheckedMedia(Me, Media, .Select(Function(f) f.Name), False, True)
End If
End With
End Sub
@@ -613,14 +591,14 @@ Namespace DownloadObjects
With Settings.Feeds.Favorite
If .Contains(Media) Then .Remove(Media)
BTT_FEED_ADD_FAV.ControlChangeColor(True)
RaiseEvent FeedAddWithRemove(Me, {FeedSpecial.FavoriteName}, Media, True)
RaiseEvent FeedRemoveCheckedMedia(Me, Media, {FeedSpecial.FavoriteName}, True, False)
End With
End Sub
Private Sub BTT_FEED_REMOVE_SPEC_Click(sender As Object, e As EventArgs) Handles BTT_FEED_REMOVE_SPEC.Click
With FeedSpecialCollection.ChooseFeeds(False)
If .ListExists Then
.ForEach(Sub(f) f.Remove(Media))
RaiseEvent FeedAddWithRemove(Me, .Select(Function(f) f.Name), Media, True)
RaiseEvent FeedRemoveCheckedMedia(Me, Media, .Select(Function(f) f.Name), True, False)
End If
End With
End Sub

View File

@@ -245,7 +245,7 @@ Namespace DownloadObjects.Groups
If Not Settings.Automation Is Nothing AndAlso Settings.Automation.Count > 0 Then
Dim aIncl As New List(Of String)
For Each plan As AutoDownloader In Settings.Automation
If plan.Mode = AutoDownloader.Modes.Groups AndAlso plan.Groups.Count > 0 AndAlso plan.Groups.Contains(Name) Then aIncl.Add(plan.Name)
If plan.Groups.Count > 0 AndAlso plan.Groups.Contains(Name) Then aIncl.Add(plan.Name)
Next
If aIncl.Count > 0 Then
MsgBoxE({$"The '{Name}' group cannot be deleted because it is included in the following scheduler plans:{vbCr}{vbCr}" &
@@ -285,6 +285,7 @@ Namespace DownloadObjects.Groups
Try
If Settings.Users.Count > 0 Then
With Instance
If TypeOf .Self Is AutoDownloader AndAlso Not DirectCast(.Self, AutoDownloader).Enabled Then Return Nothing
Dim downDate As Date? = Nothing
If .DaysNumber > 0 Then
With Now.AddDays(- .DaysNumber) : downDate = New Date(.Year, .Month, .Day, 0, 0, 0) : End With
@@ -363,10 +364,32 @@ Namespace DownloadObjects.Groups
Dim CheckSites As Predicate(Of IUserData) = Function(user) _
(.Sites.Count = 0 OrElse .Sites.Contains(user.Site)) AndAlso
(.SitesExcluded.Count = 0 OrElse Not .SitesExcluded.Contains(user.Site))
Dim users As IEnumerable(Of IUserData) =
Settings.GetUsers(Function(user) CheckLabels.Invoke(user) AndAlso CheckSites.Invoke(user) AndAlso
Dim users As New List(Of IUserData)
Dim l As New ListAddParams(LAP.IgnoreICopier)
If Not .GroupsOnly Or (.GroupsOnly And .Groups.Count = 0) Then
users.ListAddList(Settings.GetUsers(Function(user) CheckLabels.Invoke(user) AndAlso CheckSites.Invoke(user) AndAlso
CheckParams.Invoke(user) AndAlso CheckSubscription.Invoke(user) AndAlso
CheckDays.Invoke(user) AndAlso CheckDateRange.Invoke(user))
CheckDays.Invoke(user) AndAlso CheckDateRange.Invoke(user)), l)
End If
If Settings.Groups.Count > 0 Then
Dim i%
Dim groupName$
l.NotContainsOnly = True
If .Groups.Count > 0 Then
For Each groupName In .Groups
i = Settings.Groups.IndexOf(groupName)
If i >= 0 Then users.ListAddList(Settings.Groups(i).GetUsers, l)
Next
End If
l.DisableDispose = True
If .GroupsExcluded.Count > 0 Then
For Each groupName In .GroupsExcluded
i = Settings.Groups.IndexOf(groupName)
If i >= 0 Then users.ListDisposeRemove(Settings.Groups(i).GetUsers, l)
Next
End If
End If
If .UsersCount <> 0 And users.ListExists Then
users = users.ListTake(If(.UsersCount > 0, -1, -2), Math.Abs(.UsersCount))
If .UsersCount < 0 Then users = users.ListReverse

Some files were not shown because too many files have changed in this diff Show More